1c 2C> \ingroup geom 3C> @{ 4 block data geom_data 5C$Id$ 6 implicit none 7#include "nwc_const.fh" 8#include "geomP.fh" 9c 10 integer i ! For implied do in data staements 11 data ngeom_rtdb /0/ 12 data active /max_geom*.false./ 13c 14c--> names of the 3-dimensional space groups 15c 16 data (sym_spgnames(i),i=1,95) / 17 & 'P1','P-1','P2','P2_1','C2', 18 & 'Pm','Pc','Cm','Cc','P2/m', 19 & 'P2_1/m','C2/m','P2/c','P2_1/c','C2/c', 20 & 'P222','P222_1','P2_12_12','P2_12_12_1','C222_1', 21 & 'C222','F222','I222','I2_12_12_1','Pmm2', 22 & 'Pmc2_1','Pcc2','Pma2','Pca2_1','Pnc2', 23 & 'Pmn2_1','Pba2','Pna2_1','Pnn2','Cmm2', 24 & 'Cmc2_1','Ccc2','Amm2','Abm2','Ama2', 25 & 'Aba2','Fmm2','Fdd2','Imm2','Iba2', 26 & 'Ima2','Pmmm','Pnnn','Pccm','Pban', 27 & 'Pmma','Pnna','Pmna','Pcca','Pbam', 28 & 'Pccn','Pbcm','Pnnm','Pmmn','Pbcn', 29 & 'Pbca','Pnma','Cmcm','Cmca','Cmmm', 30 & 'Cccm','Cmma','Ccca','Fmmm','Fddd', 31 & 'Immm','Ibam','Ibca','Imma','P4', 32 & 'P4_1','P4_2','P4_3','I4','I4_1', 33 & 'P-4','I-4','P4/m','P4_2/m','P4/n', 34 & 'P4_2/n','I4/m','I4_1/a','P422','P42_12', 35 & 'P4_122','P4_12_12','P4_222','P4_22_12','P4_322'/ 36 data (sym_spgnames(i),i=96,190)/ 37 & 'P4_32_12','I422','I4_122','P4mm','P4bm', 38 & 'P4_2cm','P4_2nm','P4cc','P4nc','P4_2mc', 39 & 'P4_2bc','I4mm','I4cm','I4_1md','I4_1cd', 40 & 'P-42m','P-42c','P-42_1m','P-42_1c','P-4m2', 41 & 'P-4c2','P-4b2','P-4n2','I-4m2','I-4c2', 42 & 'I-42m','I-42d','P4/mmm','P4/mcc','P4/nbm', 43 & 'P4/nnc','P4/mbm','P4/mnc','P4/nmm','P4/ncc', 44 & 'P4_2/mmc','P4_2/mcm','P4_2/nbc','P4_2/nnm','P4_2/mbc', 45 & 'P4_2/mnm','P4_2/nmc','P4_2/ncm','I4/mmm','I4/mcm', 46 & 'I4_1/amd','I4_1/acd','P3','P3_1','P3_2', 47 & 'R3','P-3','R-3','P312','P321', 48 & 'P3_112','P3_121','P3_212','P3_221','R32', 49 & 'P3m1','P31m','P3c1','P31c','R3m', 50 & 'R3c','P-31m','P-31c','P-3m1','P-3c1', 51 & 'R-3m','R-3c','P6','P6_1','P6_5', 52 & 'P6_2','P6_4','P6_3','P-6','P6/m', 53 & 'P6_3/m','P622','P6_122','P6_522','P6_222', 54 & 'P6_422','P6_322','P6mm','P6cc','P6_3cm', 55 & 'P6_3mc','P-6m2','P-6c2','P-62m','P-62c'/ 56 data (sym_spgnames(i),i=191,230)/ 57 & 'P6/mmm','P6/mcc','P6_3/mcm','P6_3/mmc','P23', 58 & 'F23','I23','P2_13','I2_13','Pm-3', 59 & 'Pn-3','Fm-3','Fd-3','Im-3','Pa-3', 60 & 'Ia-3','P432','P4_232','F432','F4_132', 61 & 'I432','P4_332','P4_132','I4_132','P-43m', 62 & 'F-43m','I-43m','P-43n','F-43c','I-43d', 63 & 'Pm-3m','Pn-3n','Pm-3n','Pn-3m','Fm-3m', 64 & 'Fm-3c','Fd-3m','Fd-3c','Im-3m','Ia-3d'/ 65c 66c--> names of the extra 3-dimensional space groups 67c 68c *** extra triclinic groups *** 69 data (sym_spgnames(i),i=231,240)/ 70 & 'A1', 'B1', 'C1', 'F1', 'I1', 71 & 'A-1','B-1','C-1','F-1','I-1'/ 72c 73c *** extra monoclinic groups - 45 groups - y-axis unique*** 74c data (sym_spgnames(i),i=241,285)/ 75c & 'P121', 'B121', 76c & 'P12_11', 'B12_11', 77c & 'C121','A121',I121','F121', 78c & 'P1m1','B1m1', 79c & 'P1c1','P1a1','P1n1','B1a1','B1d1', 80c & 'C1m1','A1m1','I1m1','F1m1', 81c & 'C1c1','A1a1','I1a1','F1d1' 82c & 'P12/m1','B12/m1', 83c & 'P12_1/m1','B12_1/m1', 84c & 'C12/m1','A12/m1','I12/m1','F12/m1', 85c & 'P12/c1','P12/a1','P12/n1','B12/a1','B12/d1', 86c & 'P12_1/c1','P12_1/a1','P12_1/n1','B12_1/a1','B12_1/d1', 87c & 'C12/c1','A12/a1','I12/a1','F12/d1'/ 88c 89c *** extra monoclinic groups - 45 groups - z-axis unique *** 90c data (sym_spgnames(i),i=286,330)/ 91c & 'P112','C112', 92c & 'P112_1','C112_1', 93c & 'A112','B112','I112','F112', 94c & 'P11m','C11m', 95c & 'P11a','P11b','P11n','C11a','C11d', 96c & 'A11m','B11m','I11m','F11m', 97c & 'A11a','B11b','I11a','F11d', 98c & 'P112/m','C112/m' 99c & 'P112_1/m','C112_1/m' 100c & 'A112/m','B112/m','I112/m','F112/m', 101c & 'P112/a','P112/b','P112/n','C112/a','C112/d' 102c & 'P112_1/a','P112_1/b','P112_1/n','C112_1/a','C112_1/d', 103c & 'A112/a','B112/b','I112/a','F112/d'/ 104c 105c *** extra monoclinic groups - 45 groups - x-axis unique *** 106c data (sym_spgnames(i),i=331,375)/ 107c & 'P211','A211', 108c & 'P2_111','A2_111', 109c & 'B211','C211','I211','F211', 110c & 'Pm11','Am11', 111c & 'Pb11','Pc11','Pn11','Ab11','Ad11', 112c & 'Bm11','Cm11','Im11','Fm11', 113c & 'Bb11','Cc11','Ib11','Fd11', 114c & 'P2/m11','A2/m11', 115c & 'P2_1/m11','A2_1/m11', 116c & 'B2/m11','C2/m11','I2/m11','F2/m11', 117c & 'P2/b11','P2/c11','P2/n11','A2/b11','A2/d11', 118c & 'P2_1/b11','P2_1/c11','P2_1/n11','A2_1/b11','A2_1/d11', 119c & 'B2_1/b11','C2/c11','I2/b11','F2/d11'/ 120c 121c *** extra orthorhombic groups *** 122c data (sym_spgnames(i),i=???,???)/ 123c & / 124c 125c *** extra tetragonal groups *** 126c data (sym_spgnames(i),i=???,???)/ 127c & / 128c 129c *** extra trigonal groups *** 130c data (sym_spgnames(i),i=???,???)/ 131c & / 132 133c--> names of the 3-dimensional space groups, without _ for car files 134c 135 data (sym_carnames(i),i=1,95) / 136 & 'P1','P-1','P2','P21','C2', 137 & 'Pm','Pc','Cm','Cc','P2/m', 138 & 'P21/m','C2/m','P2/c','P21/c','C2/c', 139 & 'P222','P2221','P21212','P212121','C2221', 140 & 'C222','F222','I222','I212121','Pmm2', 141 & 'Pmc21','Pcc2','Pma2','Pca21','Pnc2', 142 & 'Pmn21','Pba2','Pna21','Pnn2','Cmm2', 143 & 'Cmc21','Ccc2','Amm2','Abm2','Ama2', 144 & 'Aba2','Fmm2','Fdd2','Imm2','Iba2', 145 & 'Ima2','Pmmm','Pnnn','Pccm','Pban', 146 & 'Pmma','Pnna','Pmna','Pcca','Pbam', 147 & 'Pccn','Pbcm','Pnnm','Pmmn','Pbcn', 148 & 'Pbca','Pnma','Cmcm','Cmca','Cmmm', 149 & 'Cccm','Cmma','Ccca','Fmmm','Fddd', 150 & 'Immm','Ibam','Ibca','Imma','P4', 151 & 'P41','P42','P43','I4','I41', 152 & 'P-4','I-4','P4/m','P42/m','P4/n', 153 & 'P42/n','I4/m','I41/a','P422','P4212', 154 & 'P4122','P41212','P4222','P42212','P4322'/ 155 data (sym_carnames(i),i=96,190)/ 156 & 'P43212','I422','I4122','P4mm','P4bm', 157 & 'P42cm','P42nm','P4cc','P4nc','P42mc', 158 & 'P42bc','I4mm','I4cm','I41md','I41cd', 159 & 'P-42m','P-42c','P-421m','P-421c','P-4m2', 160 & 'P-4c2','P-4b2','P-4n2','I-4m2','I-4c2', 161 & 'I-42m','I-42d','P4/mmm','P4/mcc','P4/nbm', 162 & 'P4/nnc','P4/mbm','P4/mnc','P4/nmm','P4/ncc', 163 & 'P42/mmc','P42/mcm','P42/nbc','P42/nnm','P42/mbc', 164 & 'P42/mnm','P42/nmc','P42/ncm','I4/mmm','I4/mcm', 165 & 'I41/amd','I41/acd','P3','P31','P32', 166 & 'R3','P-3','R-3','P312','P321', 167 & 'P3112','P3121','P3212','P3221','R32', 168 & 'P3m1','P31m','P3c1','P31c','R3m', 169 & 'R3c','P-31m','P-31c','P-3m1','P-3c1', 170 & 'R-3m','R-3c','P6','P61','P65', 171 & 'P62','P64','P63','P-6','P6/m', 172 & 'P63/m','P622','P6122','P6522','P6222', 173 & 'P6422','P6322','P6mm','P6cc','P63cm', 174 & 'P63mc','P-6m2','P-6c2','P-62m','P-62c'/ 175 data (sym_carnames(i),i=191,230)/ 176 & 'P6/mmm','P6/mcc','P63/mcm','P63/mmc','P23', 177 & 'F23','I23','P213','I213','Pm-3', 178 & 'Pn-3','Fm-3','Fd-3','Im-3','Pa-3', 179 & 'Ia-3','P432','P4232','F432','F4132', 180 & 'I432','P4332','P4132','I4132','P-43m', 181 & 'F-43m','I-43m','P-43n','F-43c','I-43d', 182 & 'Pm-3m','Pn-3n','Pm-3n','Pn-3m','Fm-3m', 183 & 'Fm-3c','Fd-3m','Fd-3c','Im-3m','Ia-3d'/ 184 185c 186c--> names of the molecular point groups 187c 188 data sym_molgnames/ 189 & 'C1','Cs','Ci','C2','C3', 190 & 'C4','C5','C6','C7','C8', 191 & 'D2','D3','D4','D5','D6', 192 & 'C2v','C3v','C4v','C5v','C6v', 193 & 'C2h','C3h','C4h','C5h','C6h', 194 & 'D2h','D3h','D4h','D5h','D6h', 195 & 'D8h','D2d','D3d','D4d','D5d', 196 & 'D6d','S4','S6','S8','T', 197 & 'Th','Td','O','Oh','I', 198 & 'Ih'/ 199 200c 201*rak:oldest: data angstrom_to_au /1.8897265d0/ 202*rak:older: data angstrom_to_au /1.8897266d0/ 203*. match inverse of new standard. 0.529177249 204 data angstrom_to_au /1.88972598858d0/ 205 data isystype / max_geom*0/ 206c 207 end 208c 209C> \brief Check whether a given handle corresponds to a valid geometry instance 210c 211C> Checks whether a given handle corresponds to a valid and active geometry. If 212C> not a message will be printed on the output. 213c 214C> \return Returns .true. is the handle corresponds to a valid geometry, 215C> and .false. otherwise. 216c 217 logical function geom_check_handle(geom, msg) 218 implicit none 219#include "nwc_const.fh" 220#include "geomP.fh" 221#include "stdio.fh" 222c 223 integer geom !< [Input] the geometry handle 224 character*(*) msg !< [Input] the message to be included in the error 225 !< error message 226c 227 geom_check_handle = geom.gt.0 .and. geom.le.max_geom 228 if (geom_check_handle) geom_check_handle = geom_check_handle 229 $ .and. active(geom) 230c 231 if (.not. geom_check_handle) then 232 write(LuOut,*) msg,': geometry handle invalid ', geom 233 call geom_err_info(msg) 234 end if 235c 236 end 237c 238C> \brief Check whether center rank is valid 239c 240C> Tests whether a given center rank is a valid rank for a given 241C> geometry instance. If it is not an error message is generated 242C> on standard output. 243c 244C> \return Return .true. if the rank is valid, and .false. 245C> otherwise. 246 logical function geom_check_cent(geom, msg, icent) 247 implicit none 248#include "nwc_const.fh" 249#include "geomP.fh" 250#include "stdio.fh" 251c 252 integer geom !< [Input] the geometry handle 253 character*(*) msg !< [Input] the message string 254 integer icent !< [Input] the center rank 255 logical status, geom_print 256 external geom_print 257c 258 geom_check_cent = icent.gt.0 .and. icent.le.ncenter(geom) 259 if (.not. geom_check_cent) then 260 write(LuOut,*) msg,': icent invalid ', icent, 261 $ names(geom)(1:lenn(geom)) 262 call geom_err_info(msg) 263 status = geom_print(geom) 264 end if 265c 266 end 267c 268C> \brief Prints summary information about every geometry in the RTDB 269c 270C> This routine extracts information about all geometries from the RTDB. 271C> The information is summarized and printed on standard output. 272c 273 subroutine geom_print_known_geoms(rtdb) 274 implicit none 275#include "nwc_const.fh" 276#include "geomP.fh" 277#include "rtdb.fh" 278#include "mafdecls.fh" 279#include "inp.fh" 280#include "global.fh" 281#include "stdio.fh" 282c 283 integer rtdb !< [Input] the RTDB handle 284c 285 integer geom, ma_type, natom, nelem 286 character*26 date 287 character*32 name32 288 logical geom_rtdb_in, ignore 289 character*128 key 290c 291 ignore = geom_rtdb_in(rtdb) 292 if (ga_nodeid() .eq. 0) then 293 write(LuOut,*) 294 call util_print_centered(LuOut,'Geometries in the database', 295 $ 23,.true.) 296 write(LuOut,*) 297 if (ngeom_rtdb .le. 0) then 298 write(LuOut,*) ' There are no geometries in the database' 299 write(LuOut,*) 300 else 301 if (ngeom_rtdb .gt. 0) write(LuOut,3) 302 3 format( 303 $ 1x,4x,2x,'Name',28x,2x,'Natoms',2x, 304 $ 'Last Modified',/, 305 $ 1x,4x,2x,32('-'),2x,6('-'),2x,24('-')) 306 do geom = 1, ngeom_rtdb 307 key = ' ' 308 write(key,'(''geometry:'',a,'':ncenter'')') 309 $ names_rtdb(geom)(1:lenr(geom)) 310 if (.not. rtdb_get(rtdb, key, mt_int, 1, natom)) then 311 write(LuOut,*) ' Warning: geometry ', geom, 312 $ ' may be corrupt' 313 natom = -1 314 endif 315 if (.not. rtdb_get_info(rtdb, key, ma_type, 316 $ nelem, date)) then 317 write(LuOut,*) ' Warning: geometry ', geom, 318 $ ' may be corrupt' 319 date = 'unknown' 320 endif 321 name32 = names_rtdb(geom)(1:lenr(geom)) 322 write(LuOut,4) geom, name32, natom, date 323 4 format(1x,i4,2x,a32,2x,i6,2x,a26) 324 end do 325 if (ngeom_rtdb .gt. 0) then 326 if (.not. rtdb_cget(rtdb,'geometry',1,key)) 327 $ key = 'geometry' 328 write(LuOut,*) 329 write(LuOut,5) key(1:inp_strlen(key)) 330 5 format(2x,'The geometry named "',a, 331 $ '" is the default for restart') 332 endif 333 write(LuOut,*) 334 write(LuOut,*) 335 endif 336 call util_flush(LuOut) 337 endif 338c 339 end 340 logical function geom_rtdb_in(rtdb) 341 implicit none 342#include "nwc_const.fh" 343#include "geomP.fh" 344#include "rtdb.fh" 345#include "mafdecls.fh" 346#include "inp.fh" 347#include "stdio.fh" 348c 349 integer rtdb ! [input] 350 integer geom 351c 352c load in info about known geometries ... this is more 353c for diagnostic and debugging purposes 354c 355 geom_rtdb_in = .false. 356 ngeom_rtdb = 0 357 if (rtdb_get(rtdb, 'geometry:ngeom', mt_int, 1, ngeom_rtdb)) 358 $ then 359 if (ngeom_rtdb . gt. 0) then 360 if (.not. rtdb_cget(rtdb, 'geometry:names', ngeom_rtdb, 361 $ names_rtdb)) then 362 write(LuOut,*) 'geom_rtdb_in: rtdb corrupt' 363 else 364 do geom = 1, ngeom_rtdb 365 lenr(geom) = inp_strlen(names_rtdb(geom)) 366 end do 367 geom_rtdb_in = .true. 368 end if 369 end if 370 end if 371c 372 end 373 logical function geom_rtdb_out(rtdb) 374 implicit none 375#include "nwc_const.fh" 376#include "geomP.fh" 377#include "rtdb.fh" 378#include "mafdecls.fh" 379#include "inp.fh" 380#include "stdio.fh" 381c 382 integer rtdb ! [input] 383c 384c output to rtdb info about known geometries 385c 386 geom_rtdb_out = 387 $ rtdb_put(rtdb, 'geometry:ngeom', mt_int, 1, ngeom_rtdb) 388 if (ngeom_rtdb . gt. 0) then 389 geom_rtdb_out = geom_rtdb_out .and. 390 $ rtdb_cput(rtdb, 'geometry:names', ngeom_rtdb, names_rtdb) 391 endif 392 if (.not. geom_rtdb_out) 393 $ write(LuOut,*) ' geom_rtdb_out: rtdb is corrupt ' 394c 395 end 396 logical function geom_rtdb_add(rtdb, name) 397 implicit none 398#include "errquit.fh" 399#include "nwc_const.fh" 400#include "geomP.fh" 401#include "rtdb.fh" 402#include "mafdecls.fh" 403#include "inp.fh" 404#include "stdio.fh" 405c 406 integer rtdb ! [input] 407 character*(*) name ! [input] 408 integer geom 409 logical status 410 integer ln 411 logical geom_rtdb_in, geom_rtdb_out 412 external geom_rtdb_in, geom_rtdb_out 413c 414 if (ngeom_rtdb.lt.0 .or. ngeom_rtdb.gt.max_geom_rtdb) 415 $ call errquit('geom_rtdb_add: ngeom_rtdb?',ngeom_rtdb, 416 & RTDB_ERR) 417c 418c See if name is on the rtdb already 419c 420 ln = inp_strlen(name) 421 status = geom_rtdb_in(rtdb) 422 geom_rtdb_add = .true. 423 do geom = 1, ngeom_rtdb 424 if (name(1:ln) .eq. names_rtdb(geom)(1:lenr(geom))) return 425 end do 426c 427c Name is not present ... add and rewrite info 428c 429 if (ngeom_rtdb .eq. max_geom_rtdb) then 430 write(LuOut,*) ' geom_rtdb_add: too many geometries on rtdb ', 431 & name 432 geom_rtdb_add = .false. 433 return 434 end if 435 ngeom_rtdb = ngeom_rtdb + 1 436 names_rtdb(ngeom_rtdb) = name 437 lenr(ngeom_rtdb) = ln 438c 439 if (.not. geom_rtdb_out(rtdb)) then 440 write(LuOut,*) ' geom_rtdb_add: rtdb error adding ', name(1:ln) 441 geom_rtdb_add = .false. 442 return 443 end if 444c 445 geom_rtdb_add = .true. 446c 447 end 448 subroutine geom_err_info(info) 449 implicit none 450#include "nwc_const.fh" 451#include "geomP.fh" 452#include "stdio.fh" 453c 454 character*(*) info ! [input] 455 integer geom 456 integer ngeom 457c 458c For internal use of the geom routines only: print out 459c info of known geometries to aid in diagnosing a problem 460c 461 ngeom = 0 462 do geom = 1, max_geom 463 if (active(geom)) ngeom = ngeom + 1 464 end do 465 write(LuOut,1) info, ngeom 466 1 format(' ',a,': open geometies: ',i2) 467 ngeom = 0 468 do geom = 1, max_geom 469 if (active(geom)) then 470 write(LuOut,2) geom, info, names(geom)(1:lenn(geom)), 471 $ trans(geom)(1:lent(geom)) 472 2 format(' ',i2,' ',a,': "',a, '" -> "', a,'"') 473 end if 474 end do 475 if (ngeom_rtdb .gt. 0) then 476 write(LuOut,3) info, ngeom_rtdb 477 3 format(' ',a,': geometries in last accessed data base: ', i2) 478 do geom = 1, ngeom_rtdb 479 write(LuOut,4) names_rtdb(geom)(1:lenr(geom)) 480 4 format(' ',a) 481 end do 482 end if 483c 484 end 485c 486C> \brief Extract the number of centers directly from the RTDB 487c 488C> For a named geometry this function extracts the number of centers 489C> directly from the RTDB. I.e. this routine bypasses all of the usual 490C> geometry infra-structure and directly exploits the stored data 491C> format. 492c 493C> \return Return .true. if the number of centers was found 494C> successfully, and .false. otherwise. 495c 496 logical function geom_rtdb_ncent(rtdb, name, ncent) 497 implicit none 498#include "rtdb.fh" 499#include "mafdecls.fh" 500#include "inp.fh" 501 integer rtdb !< [Input] the RTDB handle 502 character*(*) name !< [Input] the geometry name 503 integer ncent !< [Output] the number of centers 504c 505c Return the number of atoms in a geometry that is 506c stored on the database ... a convenience routine. 507c 508 character*128 trans, tmp 509 integer lent 510c 511 if (.not. rtdb_cget(rtdb, name, 1, trans)) trans = name 512 lent = inp_strlen(trans) 513 tmp = 'geometry:'//trans(1:lent) 514 lent = inp_strlen(tmp) 515 tmp(lent+1:) = ':ncenter' 516 geom_rtdb_ncent = rtdb_get(rtdb, tmp, mt_int, 1, ncent) 517c 518 end 519c 520C> \brief Load a geometry from the RTDB 521C> 522C> Load a geometry from the RTDB with a specified name. 523C> The name is used also to define the name of the geometry. 524C> 525C> If no part of a geometry is found the code assumes that the geometry 526C> simply is not stored on the RTDB. If some part of a geometry is 527C> present on the RTDB but not all parts then the code assumes the 528C> RTDB has been corrupted and an additional message to that effect is 529C> printed on standard output. 530C> 531C> If loading storing the geometry was successful return .true., 532C> return .false. otherwise. 533C> 534 logical function geom_rtdb_load(rtdb, geom, name) 535 implicit none 536#include "errquit.fh" 537#include "rtdb.fh" 538#include "nwc_const.fh" 539#include "geomP.fh" 540#include "mafdecls.fh" 541#include "inp.fh" 542#include "util.fh" 543#include "global.fh" 544#include "stdio.fh" 545* integer node 546c 547 integer rtdb !< [Input] the RTDB handle 548 integer geom !< [Input] the geometry handle 549 character*(*) name !< [Input] the name of the geometry 550c 551 double precision scale 552 character*256 tmp 553 integer k, nelem, ma_type 554 logical s 555 logical geom_check_handle, geom_rtdb_in, geom_get_user_scale 556 external geom_check_handle, geom_rtdb_in, geom_get_user_scale 557 logical getsym 558c 559 geom_rtdb_load = geom_check_handle(geom, 'geom_rtdb_load') 560 if (.not. geom_rtdb_load) return 561 s = geom_rtdb_in(rtdb) 562c 563c translate the provided name 564c 565 names(geom) = name 566 lenn(geom) = inp_strlen(name) 567 trans(geom) = 'junk' 568 if (.not. rtdb_cget(rtdb, name, 1, trans(geom))) 569 $ trans(geom) = name 570* if (.not.context_rtdb_match(rtdb, name, trans(geom))) 571* $ trans(geom) = name 572 lent(geom) = inp_strlen(trans(geom)) 573c 574c now get the info from the data base 575c 576 tmp = 'geometry:'//trans(geom)(1:lent(geom)) 577 k = inp_strlen(tmp)+1 578 s = .true. 579c 580 tmp(k:) = ' ' 581 tmp(k:) = ':ncenter' 582 s = s .and. rtdb_get(rtdb, tmp, mt_int, 1, ncenter(geom)) 583 geom_rtdb_load = s 584 if (.not.s) then 585c 586c Even the first item is not present on the RTDB so this geometry 587c is simply not present. Return this information to the caller. 588c 589 return 590 else 591c 592c At least some information about this geometry is stored on the 593c RTDB. So a complete geometry specification must be found from 594c hereon, otherwise the RTDB is corrupt. 595c 596 endif 597 tmp(k:) = ' ' 598 tmp(k:) = ':coords' 599 s = s .and. rtdb_get(rtdb, tmp, mt_dbl, max_cent*3, 600 $ coords(1,1,geom)) 601 tmp(k:) = ' ' 602 tmp(k:) = ':vel' 603 s = s .and. rtdb_get(rtdb, tmp, mt_dbl, max_cent*3, 604 $ velocities(1,1,geom)) 605 tmp(k:) = ' ' 606 tmp(k:) = ':charges' 607 s = s .and. rtdb_get(rtdb, tmp, mt_dbl, max_cent, charge(1,geom)) 608 tmp(k:) = ' ' 609 tmp(k:) = ':masses' 610 s = s .and. rtdb_get(rtdb, tmp, mt_dbl, max_cent, 611 $ geom_mass(1,geom)) 612 tmp(k:) = ' ' 613 tmp(k:) = ':atomct' 614 s = s .and. rtdb_get(rtdb, tmp, mt_dbl, max_cent, 615 $ geom_atomct(1,geom)) 616C new 617 tmp(k:) = ' ' 618 tmp(k:) = ':inv nuc expon' 619 s = s .and. rtdb_get(rtdb, tmp, mt_dbl, ncenter(geom), 620 $ geom_invnucexp(1,geom)) 621C end 622 tmp(k:) = ' ' 623 tmp(k:) = ':efield' 624 s = s .and. rtdb_get(rtdb, tmp, mt_dbl, 3, efield(1,geom)) 625 626c tmp(k:) = ' ' 627c tmp(k:) = ':lattice vectors' 628c s = s .and. rtdb_get(rtdb, tmp, mt_dbl, 3, 629c $ lattice_vectors(1,geom)) 630c tmp(k:) = ' ' 631c tmp(k:) = ':lattice angles' 632c s = s .and. rtdb_get(rtdb, tmp, mt_dbl, 3, 633c $ lattice_angles(1,geom)) 634 tmp(k:) = ' ' 635 tmp(k:) = ':amatrix' 636 s = s .and. rtdb_get(rtdb, tmp, mt_dbl, 9, 637 $ amatrix(1,1,geom)) 638 639 tmp(k:) = ' ' 640 tmp(k:) = ':system type' 641 s = s .and. rtdb_get(rtdb, tmp, mt_int, 1, isystype(geom)) 642 tmp(k:) = ' ' 643 tmp(k:) = ':no. unique centers' 644 s = s .and. rtdb_get(rtdb, tmp, mt_int, 1, ncenter_unique(geom)) 645 tmp(k:) = ' ' 646 tmp(k:) = ':group number' 647 s = s .and. rtdb_get(rtdb, tmp, mt_int, 1, group_number(geom)) 648 tmp(k:) = ' ' 649 tmp(k:) = ':group name' 650 s = s .and. rtdb_cget(rtdb, tmp, 1, group_name(geom)) 651 tmp(k:) = ' ' 652 tmp(k:) = ':use_primitive' 653 s = s .and. rtdb_get(rtdb, tmp, mt_log, 1, use_primitive(geom)) 654 tmp(k:) = ' ' 655 tmp(k:) = ':primitive_center' 656 s = s .and. rtdb_cget(rtdb, tmp, 1, primitive_center(geom)) 657 tmp(k:) = ' ' 658 tmp(k:) = ':user units' 659 s = s .and. rtdb_cget(rtdb, tmp, 1, user_units(geom)) 660 tmp(k:) = ' ' 661 tmp(k:) = ':angstrom_to_au' 662 s = s .and. rtdb_get(rtdb, tmp, mt_dbl, 1, angstrom_to_au) 663 tmp(k:) = ' ' 664 tmp(k:) = ':setting number' 665 s = s .and. rtdb_get(rtdb, tmp, mt_int, 1, setting_number(geom)) 666 tmp(k:) = ' ' 667 tmp(k:) = ':recip vectors' 668 s = s .and. rtdb_get(rtdb, tmp, mt_dbl, 3, 669 $ recip_lat_vectors(1,geom)) 670 tmp(k:) = ' ' 671 tmp(k:) = ':recip angles' 672 s = s .and. rtdb_get(rtdb, tmp, mt_dbl, 3, 673 $ recip_lat_angles(1,geom)) 674 tmp(k:) = ' ' 675 tmp(k:) = ':direct volume' 676 s = s .and. rtdb_get(rtdb, tmp, mt_dbl, 1, volume_direct(geom)) 677 tmp(k:) = ' ' 678 tmp(k:) = ':unique centers' 679 s = s .and. rtdb_get(rtdb, tmp, mt_int, ncenter_unique(geom), 680 $ unique_cent(1,geom)) 681 tmp(k:) = ' ' 682 tmp(k:) = ':tags' 683 s = s .and. rtdb_cget(rtdb, tmp, max_cent, tags(1,geom)) 684 tmp(k:) = ' ' 685 tmp(k:) = ':include_bqbq' 686 s = s .and. rtdb_get(rtdb, tmp, mt_log, 1, include_bqbq(geom)) 687c 688c Zmatrix info 689c 690 tmp(k:) = ' ' 691 tmp(k:) = ':zmt_source' 692 s = s .and. rtdb_cget(rtdb, tmp, 1, zmt_source(geom)) 693 if (zmt_source(geom) .ne. ' ') then 694 tmp(k:) = ' ' 695 tmp(k:) = ':zmt_nizmat' 696 s = s .and. rtdb_get(rtdb, tmp, mt_int, 1, zmt_nizmat(geom)) 697 tmp(k:) = ' ' 698 tmp(k:) = ':zmt_izmat' 699 s = s .and. rtdb_get(rtdb, tmp, mt_int, zmt_nizmat(geom), 700 $ zmt_izmat(1,geom)) 701 tmp(k:) = ' ' 702 tmp(k:) = ':zmt_nzfrz' 703 if (rtdb_get(rtdb, tmp, mt_int, 1, zmt_nzfrz(geom))) then 704 tmp(k:) = ' ' 705 tmp(k:) = ':zmt_izfrz' 706 s = s .and. rtdb_get(rtdb, tmp, mt_int, zmt_nzfrz(geom), 707 $ zmt_izfrz(1,geom)) 708 tmp(k:) = ' ' 709 tmp(k:) = ':zmt_izfrz_val' 710 s = s .and. rtdb_get(rtdb, tmp, mt_dbl, zmt_nzfrz(geom), 711 $ zmt_izfrz_val(1,geom)) 712 endif 713 tmp(k:) = ' ' 714 tmp(k:) = ':zmt_nzvar' 715 s = s .and. rtdb_get(rtdb, tmp, mt_int, 1, zmt_nzvar(geom)) 716 tmp(k:) = ' ' 717 tmp(k:) = ':zmt_varsign' 718 s = s .and. rtdb_get(rtdb, tmp, mt_dbl, zmt_nzvar(geom), 719 $ zmt_varsign(1,geom)) 720 tmp(k:) = ' ' 721 tmp(k:) = ':zmt_varname' 722 s = s .and. rtdb_cget(rtdb, tmp, zmt_nzvar(geom), 723 $ zmt_varname(1,geom)) 724 tmp(k:) = ' ' 725 tmp(k:) = ':zmt_maxtor' 726 s = s .and. rtdb_get(rtdb, tmp, mt_int, 1, zmt_maxtor(geom)) 727 tmp(k:) = ' ' 728 tmp(k:) = ':zmt_ijbond' 729 s = s .and. rtdb_get(rtdb, tmp, mt_int, 2*max_zcoord, 730 $ zmt_ijbond(1,1,geom)) 731 tmp(k:) = ' ' 732 tmp(k:) = ':zmt_ijkang' 733 s = s .and. rtdb_get(rtdb, tmp, mt_int, 3*max_zcoord, 734 $ zmt_ijkang(1,1,geom)) 735 tmp(k:) = ' ' 736 tmp(k:) = ':zmt_ijklto' 737 s = s .and. rtdb_get(rtdb, tmp, mt_int, 4*max_zcoord, 738 $ zmt_ijklto(1,1,geom)) 739 tmp(k:) = ' ' 740 tmp(k:) = ':zmt_ijklop' 741 s = s .and. rtdb_get(rtdb, tmp, mt_int, 4*max_zcoord, 742 $ zmt_ijklop(1,1,geom)) 743 tmp(k:) = ' ' 744 tmp(k:) = ':zmt_ijklnb' 745 s = s .and. rtdb_get(rtdb, tmp, mt_int, 4*max_zcoord, 746 $ zmt_ijklnb(1,1,geom)) 747* 748 tmp(k:) = ' ' 749 tmp(k:) = ':zmt_ijbond_val' 750 s = s .and. rtdb_get(rtdb, tmp, mt_dbl, max_zcoord, 751 $ zmt_ijbond_val(1,geom)) 752 tmp(k:) = ' ' 753 tmp(k:) = ':zmt_ijkang_val' 754 s = s .and. rtdb_get(rtdb, tmp, mt_dbl, max_zcoord, 755 $ zmt_ijkang_val(1,geom)) 756 tmp(k:) = ' ' 757 tmp(k:) = ':zmt_ijklto_val' 758 s = s .and. rtdb_get(rtdb, tmp, mt_dbl, max_zcoord, 759 $ zmt_ijklto_val(1,geom)) 760 tmp(k:) = ' ' 761 tmp(k:) = ':zmt_ijklop_val' 762 s = s .and. rtdb_get(rtdb, tmp, mt_dbl, max_zcoord, 763 $ zmt_ijklop_val(1,geom)) 764 tmp(k:) = ' ' 765 tmp(k:) = ':zmt_ijklnb_val' 766 s = s .and. rtdb_get(rtdb, tmp, mt_dbl, max_zcoord, 767 $ zmt_ijklnb_val(1,geom)) 768* 769 tmp(k:) = ' ' 770 tmp(k:) = ':zmt_ijbond_frz' 771 s = s .and. rtdb_get(rtdb, tmp, mt_log, max_zcoord, 772 $ zmt_ijbond_frz(1,geom)) 773 tmp(k:) = ' ' 774 tmp(k:) = ':zmt_ijkang_frz' 775 s = s .and. rtdb_get(rtdb, tmp, mt_log, max_zcoord, 776 $ zmt_ijkang_frz(1,geom)) 777 tmp(k:) = ' ' 778 tmp(k:) = ':zmt_ijklto_frz' 779 s = s .and. rtdb_get(rtdb, tmp, mt_log, max_zcoord, 780 $ zmt_ijklto_frz(1,geom)) 781 tmp(k:) = ' ' 782 tmp(k:) = ':zmt_ijklop_frz' 783 s = s .and. rtdb_get(rtdb, tmp, mt_log, max_zcoord, 784 $ zmt_ijklop_frz(1,geom)) 785 tmp(k:) = ' ' 786 tmp(k:) = ':zmt_ijklnb_frz' 787 s = s .and. rtdb_get(rtdb, tmp, mt_log, max_zcoord, 788 $ zmt_ijklnb_val(1,geom)) 789* 790 tmp(k:) = ' ' 791 tmp(k:) = ':zmt_ijbond_nam' 792 s = s .and. rtdb_cget(rtdb, tmp, max_zcoord, 793 $ zmt_ijbond_nam(1,geom)) 794 tmp(k:) = ' ' 795 tmp(k:) = ':zmt_ijkang_nam' 796 s = s .and. rtdb_cget(rtdb, tmp, max_zcoord, 797 $ zmt_ijkang_nam(1,geom)) 798 tmp(k:) = ' ' 799 tmp(k:) = ':zmt_ijklto_nam' 800 s = s .and. rtdb_cget(rtdb, tmp, max_zcoord, 801 $ zmt_ijklto_nam(1,geom)) 802 tmp(k:) = ' ' 803 tmp(k:) = ':zmt_ijklop_nam' 804 s = s .and. rtdb_cget(rtdb, tmp, max_zcoord, 805 $ zmt_ijklop_nam(1,geom)) 806 tmp(k:) = ' ' 807 tmp(k:) = ':zmt_ijklnb_nam' 808 s = s .and. rtdb_cget(rtdb, tmp, max_zcoord, 809 $ zmt_ijklnb_nam(1,geom)) 810* 811 tmp(k:) = ' ' 812 tmp(k:) = ':zmt_cvr_scaling' 813 s = s .and. rtdb_get(rtdb, tmp, mt_dbl, 1, 814 $ zmt_cvr_scaling(geom)) 815 endif 816c 817c-- > get symmetry operators, number of operators and operator/atom 818c map from rtdb 819c 820 821 tmp(k:) = ' ' 822 tmp(k:) = ' ' 823 tmp(k:) = ':num_operators' 824 s = s .and. 825 $ rtdb_get(rtdb, tmp, mt_int, 1, sym_num_ops(geom)) 826 tmp(k:) = ' ' 827 tmp(k:) = ':operators' 828 s = s .and. 829 $ rtdb_get(rtdb, tmp, mt_dbl, max_sym_ops*3*4, 830 $ sym_ops(1,1,geom)) 831 if (sym_num_ops(geom) .gt. 0) then 832c 833c If loading into an old geometry free this memory 834c 835 if (sym_center_map_handle(geom) .ne. -1) then 836 if (.not. ma_free_heap(sym_center_map_handle(geom))) 837 $ call errquit('geom_rtdb_load: free of atom map', 0, 838 & MA_ERR) 839 end if 840c 841 tmp(k:) = ' ' 842 tmp(k:) = ' ' 843 tmp(k:) = ':map_atoms' 844 s = s .and. 845 $ rtdb_ma_get(rtdb, tmp, ma_type, nelem, 846 $ sym_center_map_handle(geom)) 847 if (nelem .ne. sym_num_ops(geom)*ncenter(geom)) call errquit 848 $ ('geom_rtdb_load: invalid no. of element in sym Tap', 849 $ nelem, RTDB_ERR) 850 if (.not. ma_get_index(sym_center_map_handle(geom), 851 $ sym_center_map_index(geom)))call errquit 852 $ ('geom_rtdb_load: bad ma handle for sym map', 0, MA_ERR) 853 else 854 sym_center_map_handle(geom) = -1 855 sym_center_map_index(geom) = 1 ! Not used but address is created 856 endif 857c 858 if (.not. s) then 859 if (ga_nodeid().eq.0) then 860 write(LuOut,*)' geom_rtdb_load: rtdb corrupt: ', 861 $ names(geom)(1:lenn(geom)), ' -> ', 862 $ trans(geom)(1:lent(geom)) 863 call geom_err_info('geom_rtdb_load') 864 endif 865 geom_rtdb_load = .false. 866 return 867 end if 868c 869c Determine if external fields are applied 870c 871 oefield(geom) = 872 $ ddot(3, efield(1,geom), 1, efield(1,geom), 1) .gt. 0.0d0 873c 874c compute effective nuclear repulsion energy, dipole and 875c interaction with external fields 876c 877 call geom_compute_values(geom) 878c 879 active(geom) = .true. 880 geom_rtdb_load = .true. 881c 882c periodic systems: find conversion factor for geometrical parameters 883c 884 if (isystype(geom) .gt. 0) then 885 if (.not. geom_get_user_scale(geom,scale)) 886 $ call errquit('geom_rtdb_load:failed get user scale',0, 887 & GEOM_ERR) 888 endif 889c 890c setup geometry related stuff particular to the dimension of the system 891c 892 if (isystype(geom) .eq. 3) then 893 call geom_3d_amatrix(geom,scale) 894 elseif(isystype(geom).eq.2) then 895 call geom_2d_amatrix(geom,scale) 896 elseif(isystype(geom).eq.1) then 897 call geom_1d(geom,scale) 898 endif 899c 900c hack to fix numerical gradient issue when symmetry changes 901c 902 if(sym_num_ops(geom) .gt. 0) then 903 if (rtdb_get(rtdb,'geom:getsym', mt_log, 1, getsym)) then 904 if(getsym) then 905 call geom_getsym(rtdb,geom,'geometry') 906 endif 907 endif 908 endif 909c 910* do node = 0, ga_nnodes()-1 911* call ga_sync 912* if (ga_nodeid() .eq. node) then 913* write(LuOut,*) ' node ', ga_nodeid() 914* call sym_print_all(geom, .true., .true., .true., .true., .true.) 915* call util_flush(LuOut) 916* endif 917* call ga_sync 918* enddo 919 920c 921 end 922c 923C> \brief Compute and store the nuclear repulsion and nuclear dipole - 924C> external field energies 925c 926C> Compute and store the energies that depend on the atomic positions, 927C> such as the nuclear - nuclear repulsion energy, and the nuclear 928C> dipole - external field interaction energy. 929c 930 subroutine geom_compute_values(geom) 931 implicit none 932#include "nwc_const.fh" 933#include "geomP.fh" 934#include "util.fh" 935#include "inp.fh" 936#include "stdio.fh" 937 integer geom !< [Input] the geometry handle 938c 939c compute effective nuclear repulsion energy, dipole and 940c interaction with external fields 941c 942c eventually need to also make the symmetry info consistent 943c and make internals/cartesians consistent 944c 945 double precision e, e_nd_ef, r, rx, ry, rz 946 integer i, j 947 logical j_is_atom, i_is_atom 948 logical geom_tag_to_element 949 external geom_tag_to_element 950 logical is_atom 951 is_atom(i) = (.not. inp_compare(.false., 'bq', tags(i,geom)(1:2))) 952c 953 e = 0.0d0 954 ndipole(1,geom) = 0.0d0 955 ndipole(2,geom) = 0.0d0 956 ndipole(3,geom) = 0.0d0 957c 958c compute nuclear dipole moment and usual nuclear repulsion energy 959c 960 do i = 1,ncenter(geom) 961 i_is_atom = is_atom(i) 962 if (include_bqbq(geom) .or. i_is_atom) then 963 do j = 1, 3 964 ndipole(j,geom) = ndipole(j,geom) + 965 $ charge(i,geom)*coords(j,i,geom) 966 end do 967 endif 968 do j = i+1, ncenter(geom) 969 j_is_atom = is_atom(j) 970 if (include_bqbq(geom) .or. (i_is_atom.or.j_is_atom)) then 971 972* r = dsqrt( 973* $ (coords(1,i,geom)-coords(1,j,geom))**2 + 974* $ (coords(2,i,geom)-coords(2,j,geom))**2 + 975* $ (coords(3,i,geom)-coords(3,j,geom))**2) 976 rx = coords(1,i,geom)-coords(1,j,geom) 977 rx = rx*rx 978 ry = coords(2,i,geom)-coords(2,j,geom) 979 ry = ry*ry 980 rz = coords(3,i,geom)-coords(3,j,geom) 981 rz = rz*rz 982 r = sqrt(rx+ry+rz) 983#ifdef FUJITSU_VPP 984 if (r > 1.d-10) e = e + charge(i,geom)*charge(j,geom)/r 985#else 986 e = e + charge(i,geom)*charge(j,geom)/r 987#endif 988 endif 989 end do 990 end do 991c 992c add in interaction of nuclear dipole with external field 993c 994 e_nd_ef = ddot(3, ndipole(1,geom), 1, efield(1,geom), 1) 995*:debug-s 996*debug: write(LuOut,*)' interaction of nuclear dipole ', 997*debug: & 'with external field is ',e_nd_ef 998*:debug-e 999 e = e + e_nd_ef 1000c 1001 erep(geom) = e 1002c 1003 if(isystype(geom).eq.0) then 1004 call sym_init_inv_op(geom) 1005 endif 1006c 1007 end 1008c 1009C> \brief Look up whether Bq - Bq interactions should be calculated 1010c 1011C> Point charges (Bq centers) have many uses in quantum chemistry 1012C> models. In some applications Bq - Bq interactions are an important 1013C> component of the energy expression, in other applications these 1014C> interactions should be omitted. This function returns what has been 1015C> specified for this interaction in this geometry instance. 1016c 1017C> \return Return .true. if Bq - Bq interactions should be evaluated, 1018C> and .false. otherwise. 1019c 1020 logical function geom_include_bqbq(geom) 1021 implicit none 1022#include "errquit.fh" 1023#include "nwc_const.fh" 1024#include "geomP.fh" 1025 integer geom !< [Input] the geometry handle 1026 logical geom_check_handle 1027 external geom_check_handle 1028c 1029 if (.not. geom_check_handle(geom, 'geom_include_bqbq')) 1030 $ call errquit('geom_include_bqbq: bad handle',0, GEOM_ERR) 1031 geom_include_bqbq = include_bqbq(geom) 1032c 1033 end 1034 logical function geom_set_bqbq(geom, value) 1035 implicit none 1036#include "nwc_const.fh" 1037#include "geomP.fh" 1038 logical value 1039 integer geom 1040 logical geom_check_handle 1041 external geom_check_handle 1042c 1043 geom_set_bqbq = geom_check_handle(geom, 'geom_set_bqbq') 1044 if (.not. geom_set_bqbq) return 1045 include_bqbq(geom) = value 1046 call geom_compute_values(geom) 1047c 1048 end 1049c 1050C> \brief Store a geometry on the RTDB 1051c 1052C> Store a geometry onto the RTDB with a specified key, if no key is specified 1053C> a key will be constructed from the current geometry name. 1054C> If storing the geometry was successful return .true., return .false. otherwise. 1055 logical function geom_rtdb_store(rtdb, geom, name) 1056 implicit none 1057#include "nwc_const.fh" 1058#include "geomP.fh" 1059#include "rtdb.fh" 1060#include "mafdecls.fh" 1061#include "util.fh" 1062#include "stdio.fh" 1063***** #include "context.fh" 1064#include "inp.fh" 1065c 1066 integer rtdb !< [Input] the RTDB handle 1067 character*(*) name !< [Input] the geometry RTDB key 1068 integer geom !< [Input] the geometry handle 1069 logical geom_check_handle, geom_rtdb_add, geom_rtdb_delete 1070 external geom_check_handle, geom_rtdb_add, geom_rtdb_delete 1071 logical s 1072 character*256 tmp 1073 integer k 1074c 1075 geom_rtdb_store = geom_check_handle(geom, 'geom_rtdb_store') 1076 if (.not. geom_rtdb_store) return 1077 if (name .ne. ' ') then 1078 names(geom) = name 1079 lenn(geom) = inp_strlen(name) 1080 end if 1081c 1082 s = geom_rtdb_delete(rtdb, name) ! Delete any old junk 1083c 1084c try to translate the name 1085c 1086 trans(geom) = 'junk' 1087 if (.not. rtdb_cget(rtdb, name, 1, trans(geom))) 1088 $ trans(geom) = name 1089* if (.not. context_rtdb_match(rtdb, name, trans(geom))) 1090* $ trans(geom) = name 1091 lent(geom) = inp_strlen(trans(geom)) 1092c 1093c now put the info into the data base 1094c 1095 tmp = 'geometry:'//trans(geom)(1:lent(geom)) 1096 k = inp_strlen(tmp)+1 1097 s = .true. 1098c 1099 tmp(k:) = ' ' 1100 tmp(k:) = ':ncenter' 1101 s = s .and. rtdb_put(rtdb, tmp, mt_int, 1, ncenter(geom)) 1102 tmp(k:) = ' ' 1103 tmp(k:) = ':coords' 1104 s = s .and. rtdb_put(rtdb, tmp, mt_dbl, ncenter(geom)*3, 1105 $ coords(1,1,geom)) 1106 tmp(k:) = ' ' 1107 tmp(k:) = ':vel' 1108 s = s .and. rtdb_put(rtdb, tmp, mt_dbl, ncenter(geom)*3, 1109 $ velocities(1,1,geom)) 1110 tmp(k:) = ' ' 1111 tmp(k:) = ':charges' 1112 s = s .and. rtdb_put(rtdb, tmp, mt_dbl, ncenter(geom), 1113 $ charge(1,geom)) 1114 tmp(k:) = ' ' 1115 tmp(k:) = ':masses' 1116 s = s .and. rtdb_put(rtdb, tmp, mt_dbl, ncenter(geom), 1117 $ geom_mass(1,geom)) 1118 tmp(k:) = ' ' 1119 tmp(k:) = ':atomct' 1120 s = s .and. rtdb_put(rtdb, tmp, mt_dbl, ncenter(geom), 1121 $ geom_atomct(1,geom)) 1122C new 1123 tmp(k:) = ' ' 1124 tmp(k:) = ':inv nuc expon' 1125 s = s .and. rtdb_put(rtdb, tmp, mt_dbl, ncenter(geom), 1126 $ geom_invnucexp(1,geom)) 1127C end 1128 tmp(k:) = ' ' 1129 tmp(k:) = ':efield' 1130 s = s .and. rtdb_put(rtdb, tmp, mt_dbl, 3, efield(1,geom)) 1131 1132c tmp(k:) = ' ' 1133c tmp(k:) = ':lattice vectors' 1134c s = s .and. rtdb_put(rtdb, tmp, mt_dbl, 3, 1135c $ lattice_vectors(1,geom)) 1136c tmp(k:) = ' ' 1137c tmp(k:) = ':lattice angles' 1138c s = s .and. rtdb_put(rtdb, tmp, mt_dbl, 3, lattice_angles(1,geom)) 1139 tmp(k:) = ' ' 1140 tmp(k:) = ':amatrix' 1141 s = s .and. rtdb_put(rtdb, tmp, mt_dbl, 9, 1142 $ amatrix(1,1,geom)) 1143 1144 tmp(k:) = ' ' 1145 tmp(k:) = ':system type' 1146 s = s .and. rtdb_put(rtdb, tmp, mt_int, 1, isystype(geom)) 1147 tmp(k:) = ' ' 1148 tmp(k:) = ':no. unique centers' 1149 s = s .and. rtdb_put(rtdb, tmp, mt_int, 1, ncenter_unique(geom)) 1150 tmp(k:) = ' ' 1151 tmp(k:) = ':group number' 1152 s = s .and. rtdb_put(rtdb, tmp, mt_int, 1, group_number(geom)) 1153 tmp(k:) = ' ' 1154 tmp(k:) = ':group name' 1155 s = s .and. rtdb_cput(rtdb, tmp, 1, group_name(geom)) 1156 tmp(k:) = ' ' 1157 tmp(k:) = ':use_primitive' 1158 s = s .and. rtdb_put(rtdb, tmp, mt_log, 1, use_primitive(geom)) 1159 tmp(k:) = ' ' 1160 tmp(k:) = ':primitive_center' 1161 s = s .and. rtdb_cput(rtdb, tmp, 1, primitive_center(geom)) 1162 tmp(k:) = ' ' 1163 tmp(k:) = ':user units' 1164 s = s .and. rtdb_cput(rtdb, tmp, 1, user_units(geom)) 1165 tmp(k:) = ' ' 1166 tmp(k:) = ':angstrom_to_au' 1167 s = s .and. rtdb_put(rtdb, tmp, mt_dbl, 1, angstrom_to_au) 1168 tmp(k:) = ' ' 1169 tmp(k:) = ':setting number' 1170 s = s .and. rtdb_put(rtdb, tmp, mt_int, 1, setting_number(geom)) 1171 tmp(k:) = ' ' 1172 tmp(k:) = ':recip vectors' 1173 s = s .and. rtdb_put(rtdb, tmp, mt_dbl, 3, 1174 $ recip_lat_vectors(1,geom)) 1175 tmp(k:) = ' ' 1176 tmp(k:) = ':recip angles' 1177 s = s .and. rtdb_put(rtdb, tmp, mt_dbl, 3, 1178 $ recip_lat_angles(1,geom)) 1179 tmp(k:) = ' ' 1180 tmp(k:) = ':direct volume' 1181 s = s .and. rtdb_put(rtdb, tmp, mt_dbl, 1, volume_direct(geom)) 1182 tmp(k:) = ' ' 1183 tmp(k:) = ':unique centers' 1184 s = s .and. rtdb_put(rtdb, tmp, mt_int, ncenter_unique(geom), 1185 $ unique_cent(1,geom)) 1186 tmp(k:) = ' ' 1187 tmp(k:) = ':tags' 1188 s = s .and. rtdb_cput(rtdb, tmp, ncenter(geom), tags(1,geom)) 1189 tmp(k:) = ' ' 1190 tmp(k:) = ':include_bqbq' 1191 s = s .and. rtdb_put(rtdb, tmp, mt_log, 1, include_bqbq(geom)) 1192c 1193c Zmatrix info 1194c 1195 tmp(k:) = ' ' 1196 tmp(k:) = ':zmt_source' 1197 s = s .and. rtdb_cput(rtdb, tmp, 1, zmt_source(geom)) 1198 if (zmt_source(geom) .ne. ' ') then 1199 tmp(k:) = ' ' 1200 tmp(k:) = ':zmt_nizmat' 1201 s = s .and. rtdb_put(rtdb, tmp, mt_int, 1, zmt_nizmat(geom)) 1202 tmp(k:) = ' ' 1203 tmp(k:) = ':zmt_izmat' 1204 s = s .and. rtdb_put(rtdb, tmp, mt_int, zmt_nizmat(geom), 1205 $ zmt_izmat(1,geom)) 1206 if (zmt_nzfrz(geom) .gt. 0) then 1207 tmp(k:) = ' ' 1208 tmp(k:) = ':zmt_nzfrz' 1209 s = s .and. rtdb_put(rtdb, tmp, mt_int, 1, zmt_nzfrz(geom)) 1210 tmp(k:) = ' ' 1211 tmp(k:) = ':zmt_izfrz' 1212 s = s .and. rtdb_put(rtdb, tmp, mt_int, zmt_nzfrz(geom), 1213 $ zmt_izfrz(1,geom)) 1214 tmp(k:) = ' ' 1215 tmp(k:) = ':zmt_izfrz_val' 1216 s = s .and. rtdb_put(rtdb, tmp, mt_dbl, zmt_nzfrz(geom), 1217 $ zmt_izfrz_val(1,geom)) 1218 endif 1219 tmp(k:) = ' ' 1220 tmp(k:) = ':zmt_nzvar' 1221 s = s .and. rtdb_put(rtdb, tmp, mt_int, 1, zmt_nzvar(geom)) 1222 tmp(k:) = ' ' 1223 tmp(k:) = ':zmt_varsign' 1224 s = s .and. rtdb_put(rtdb, tmp, mt_dbl, zmt_nzvar(geom), 1225 $ zmt_varsign(1,geom)) 1226 tmp(k:) = ' ' 1227 tmp(k:) = ':zmt_varname' 1228 s = s .and. rtdb_cput(rtdb, tmp, zmt_nzvar(geom), 1229 $ zmt_varname(1,geom)) 1230 tmp(k:) = ' ' 1231 tmp(k:) = ':zmt_maxtor' 1232 s = s .and. rtdb_put(rtdb, tmp, mt_int, 1, zmt_maxtor(geom)) 1233 tmp(k:) = ' ' 1234 tmp(k:) = ':zmt_ijbond' 1235 s = s .and. rtdb_put(rtdb, tmp, mt_int, 2*max_zcoord, 1236 $ zmt_ijbond(1,1,geom)) 1237 tmp(k:) = ' ' 1238 tmp(k:) = ':zmt_ijkang' 1239 s = s .and. rtdb_put(rtdb, tmp, mt_int, 3*max_zcoord, 1240 $ zmt_ijkang(1,1,geom)) 1241 tmp(k:) = ' ' 1242 tmp(k:) = ':zmt_ijklto' 1243 s = s .and. rtdb_put(rtdb, tmp, mt_int, 4*max_zcoord, 1244 $ zmt_ijklto(1,1,geom)) 1245 tmp(k:) = ' ' 1246 tmp(k:) = ':zmt_ijklop' 1247 s = s .and. rtdb_put(rtdb, tmp, mt_int, 4*max_zcoord, 1248 $ zmt_ijklop(1,1,geom)) 1249 tmp(k:) = ' ' 1250 tmp(k:) = ':zmt_ijklnb' 1251 s = s .and. rtdb_put(rtdb, tmp, mt_int, 4*max_zcoord, 1252 $ zmt_ijklnb(1,1,geom)) 1253* 1254 tmp(k:) = ' ' 1255 tmp(k:) = ':zmt_ijbond_val' 1256 s = s .and. rtdb_put(rtdb, tmp, mt_dbl, max_zcoord, 1257 $ zmt_ijbond_val(1,geom)) 1258 tmp(k:) = ' ' 1259 tmp(k:) = ':zmt_ijkang_val' 1260 s = s .and. rtdb_put(rtdb, tmp, mt_dbl, max_zcoord, 1261 $ zmt_ijkang_val(1,geom)) 1262 tmp(k:) = ' ' 1263 tmp(k:) = ':zmt_ijklto_val' 1264 s = s .and. rtdb_put(rtdb, tmp, mt_dbl, max_zcoord, 1265 $ zmt_ijklto_val(1,geom)) 1266 tmp(k:) = ' ' 1267 tmp(k:) = ':zmt_ijklop_val' 1268 s = s .and. rtdb_put(rtdb, tmp, mt_dbl, max_zcoord, 1269 $ zmt_ijklop_val(1,geom)) 1270 tmp(k:) = ' ' 1271 tmp(k:) = ':zmt_ijklnb_val' 1272 s = s .and. rtdb_put(rtdb, tmp, mt_dbl, max_zcoord, 1273 $ zmt_ijklnb_val(1,geom)) 1274* 1275 tmp(k:) = ' ' 1276 tmp(k:) = ':zmt_ijbond_frz' 1277 s = s .and. rtdb_put(rtdb, tmp, mt_log, max_zcoord, 1278 $ zmt_ijbond_frz(1,geom)) 1279 tmp(k:) = ' ' 1280 tmp(k:) = ':zmt_ijkang_frz' 1281 s = s .and. rtdb_put(rtdb, tmp, mt_log, max_zcoord, 1282 $ zmt_ijkang_frz(1,geom)) 1283 tmp(k:) = ' ' 1284 tmp(k:) = ':zmt_ijklto_frz' 1285 s = s .and. rtdb_put(rtdb, tmp, mt_log, max_zcoord, 1286 $ zmt_ijklto_frz(1,geom)) 1287 tmp(k:) = ' ' 1288 tmp(k:) = ':zmt_ijklop_frz' 1289 s = s .and. rtdb_put(rtdb, tmp, mt_log, max_zcoord, 1290 $ zmt_ijklop_frz(1,geom)) 1291 tmp(k:) = ' ' 1292 tmp(k:) = ':zmt_ijklnb_frz' 1293 s = s .and. rtdb_put(rtdb, tmp, mt_log, max_zcoord, 1294 $ zmt_ijklnb_val(1,geom)) 1295* 1296 tmp(k:) = ' ' 1297 tmp(k:) = ':zmt_ijbond_nam' 1298 s = s .and. rtdb_cput(rtdb, tmp, max_zcoord, 1299 $ zmt_ijbond_nam(1,geom)) 1300 tmp(k:) = ' ' 1301 tmp(k:) = ':zmt_ijkang_nam' 1302 s = s .and. rtdb_cput(rtdb, tmp, max_zcoord, 1303 $ zmt_ijkang_nam(1,geom)) 1304 tmp(k:) = ' ' 1305 tmp(k:) = ':zmt_ijklto_nam' 1306 s = s .and. rtdb_cput(rtdb, tmp, max_zcoord, 1307 $ zmt_ijklto_nam(1,geom)) 1308 tmp(k:) = ' ' 1309 tmp(k:) = ':zmt_ijklop_nam' 1310 s = s .and. rtdb_cput(rtdb, tmp, max_zcoord, 1311 $ zmt_ijklop_nam(1,geom)) 1312 tmp(k:) = ' ' 1313 tmp(k:) = ':zmt_ijklnb_nam' 1314 s = s .and. rtdb_cput(rtdb, tmp, max_zcoord, 1315 $ zmt_ijklnb_nam(1,geom)) 1316* 1317 tmp(k:) = ' ' 1318 tmp(k:) = ':zmt_cvr_scaling' 1319 s = s .and. rtdb_put(rtdb, tmp, mt_dbl, 1, 1320 $ zmt_cvr_scaling(geom)) 1321 endif 1322c 1323c-- > put symmetry operators, number of operators and operator/atom 1324c map out to rtdb 1325c 1326 tmp(k:) = ' ' 1327 tmp(k:) = ':num_operators' 1328 s = s .and. 1329 $ rtdb_put(rtdb, tmp, mt_int, 1, sym_num_ops(geom)) 1330 tmp(k:) = ' ' 1331 tmp(k:) = ':operators' 1332 s = s .and. 1333 $ rtdb_put(rtdb, tmp, mt_dbl, max_sym_ops*3*4, 1334 $ sym_ops(1,1,geom)) 1335 if (sym_num_ops(geom) .gt. 0) then 1336 tmp(k:) = ' ' 1337 tmp(k:) = ':map_atoms' 1338 s = s .and. 1339 $ rtdb_put(rtdb, tmp, mt_int, 1340 $ ncenter(geom)*sym_num_ops(geom), 1341 $ int_mb(sym_center_map_index(geom))) 1342 endif 1343 1344c 1345c 1346c insert translated name into list of known geometries 1347c 1348 s = s .and. geom_rtdb_add(rtdb, trans(geom)) 1349c 1350c check that all rtdb operations were successful 1351c 1352 if (.not. s) then 1353 write(LuOut,*) ' geom_rtdb_store: write to rtdb failed', 1354 $ names(geom)(1:lenn(geom)), ' -> ', 1355 $ trans(geom)(1:lent(geom)) 1356 call geom_err_info('geom_rtdb_store') 1357 geom_rtdb_store = .false. 1358 return 1359 end if 1360 geom_rtdb_store = .true. 1361c 1362 end 1363c 1364C> \brief Delete a geometry from the RTDB 1365c 1366C> Delete a geometry with a given name from the RTDB. 1367c 1368C> \return Return .true. if the geometry was successfully deleted, 1369C> return .false. otherwise. 1370 logical function geom_rtdb_delete(rtdb, name) 1371 implicit none 1372#include "errquit.fh" 1373#include "nwc_const.fh" 1374#include "geomP.fh" 1375#include "rtdb.fh" 1376#include "inp.fh" 1377#include "global.fh" 1378c 1379 integer rtdb !< [Input] the RTDB handle 1380 character*(*) name !< [Input] the geometry name 1381 character*256 translation, tmp, test 1382 integer lt, geom, geom2, k 1383 logical status, mode 1384 logical geom_rtdb_in, geom_rtdb_out 1385 external geom_rtdb_in, geom_rtdb_out 1386c 1387c try to translate the provided name 1388c 1389 if (.not. rtdb_cget(rtdb, name, 1, translation)) 1390 $ translation = name 1391 lt = inp_strlen(translation) 1392c 1393c locate name in list and remove 1394c 1395 status = geom_rtdb_in(rtdb) 1396 do geom = 1, ngeom_rtdb 1397 if (names_rtdb(geom)(1:lenr(geom)) .eq. translation(1:lt)) 1398 $ goto 10 1399 end do 1400 goto 11 1401 10 do geom2 = geom+1, ngeom_rtdb ! Matched 1402 names_rtdb(geom2-1) = names_rtdb(geom2) 1403 end do 1404 ngeom_rtdb = ngeom_rtdb - 1 1405 status = geom_rtdb_out(rtdb) 1406c 1407c Delete junk in rtdb even if did not find geometry in 1408c the list just in case things are a little messed up 1409c 1410 11 if (ga_nodeid() .eq. 0) then 1411 mode = rtdb_parallel(.false.) 1412c 1413c delete each entry assoicated with a geometry in the database 1414c 1415 tmp = 'geometry:'//translation(1:lt) 1416 k = inp_strlen(tmp) 1417 k = k + 1 1418 tmp(k:k) = ':' 1419c 1420 status = rtdb_first(rtdb, test) 1421 20 if (status) then 1422 if (inp_compare(.true.,tmp(1:k),test(1:k))) then 1423 if (.not. rtdb_delete(rtdb,test)) call errquit 1424 $ ('geom_rtdb_delete:failed deleting known entry',0, 1425 & RTDB_ERR) 1426 endif 1427 status = rtdb_next(rtdb, test) 1428 goto 20 1429 endif 1430 mode = rtdb_parallel(mode) ! Restore previous state 1431 endif 1432c 1433 geom_rtdb_delete = .true. 1434c 1435 end 1436c 1437C> \brief Reset the symmetry to C1 for a given geometry instance 1438c 1439C> Resets the symmetry information to C1 for the specified geometry 1440C> instance. This also frees any associated in-core data structures. 1441c 1442C> \return Return .true. if successfull, and .false. otherwise. 1443c 1444 logical function geom_strip_sym(geom) 1445 implicit none 1446#include "errquit.fh" 1447#include "nwc_const.fh" 1448#include "geomP.fh" 1449#include "mafdecls.fh" 1450c 1451c Reset the given geometry to have just C1 symmetry, freeing 1452c any associated in-core data structures. 1453c 1454 integer geom !< [Input] the geometry handle 1455 integer i 1456 logical geom_check_handle 1457 external geom_check_handle 1458c 1459 geom_strip_sym = geom_check_handle(geom, 'geom_strip_sym') 1460 if (.not. geom_strip_sym) return 1461c 1462 isystype(geom) = 0 1463 group_number(geom) = 1 1464 setting_number(geom) = 0 1465 if (sym_center_map_handle(geom) .ne. -1) then 1466 if (.not. ma_free_heap(sym_center_map_handle(geom))) 1467 $ call errquit('geom_strip_sum: free of atom map', 0, 1468 & MA_ERR) 1469 end if 1470 sym_center_map_handle(geom) = -1 1471 sym_center_map_index(geom) = 1 1472 group_name(geom) = 'C1' 1473 sym_num_ops(geom) = 0 1474 use_primitive(geom) = .false. 1475 primitive_center(geom) = 'x' 1476c 1477 ncenter_unique(geom) = ncenter(geom) 1478 do i = 1, ncenter_unique(geom) 1479 unique_cent(i,geom) = i 1480 end do 1481c 1482 end 1483c 1484C> \brief Destroy a geometry instance 1485c 1486C> Destroys a geometry instance. After this operation the geometry handle is 1487C> no longer valid. 1488C> Returns .true. if the instance was successfully destroyed, 1489C> returns .false. otherwise 1490 logical function geom_destroy(geom) 1491 implicit none 1492#include "errquit.fh" 1493#include "nwc_const.fh" 1494#include "geomP.fh" 1495#include "mafdecls.fh" 1496c 1497 integer geom !< [Input] the geometry handle 1498 integer i 1499 logical geom_check_handle, geom_check_cent 1500 external geom_check_handle, geom_check_cent 1501c 1502 geom_destroy = geom_check_handle(geom, 'geom_destroy') 1503 if (.not. geom_destroy) return 1504c 1505 active(geom) = .false. 1506* this is set for a geometry at every basis set load 1507* This info needs to be nullified when the geometry is gone 1508 do i = 1,ncenter(geom) 1509 oecpcent(i,geom) = .false. 1510 enddo 1511 geom_destroy = .true. 1512 if (sym_center_map_handle(geom) .ne. -1) then 1513 if (.not. ma_free_heap(sym_center_map_handle(geom))) 1514 $ call errquit('geom_destroy: free of atom map', 0, MA_ERR) 1515 end if 1516c 1517 end 1518c 1519C> \brief Set the point group symmetry for a geometry instance 1520c 1521C> Sets the point group or space group for a given geometry instance. 1522C> Whether the point group or the space group is used depends on the 1523C> type of geometry under consideration. 1524c 1525C> \return Return .true. if successfull, and .false. otherwise. 1526c 1527 logical function geom_group_set(geom, group) 1528 implicit none 1529#include "nwc_const.fh" 1530#include "geomP.fh" 1531#include "inp.fh" 1532c 1533 integer geom !< [Input] the geometry handle 1534 character*(*) group !< [Input] the point/space group 1535 logical geom_check_handle, geom_check_cent 1536 external geom_check_handle, geom_check_cent 1537c 1538 geom_group_set = geom_check_handle(geom, 'geom_group_set') 1539 if (.not. geom_group_set) return 1540c 1541 if (isystype(geom).eq.0) then 1542 geom_group_set = inp_match(46,.false.,group,sym_molgnames, 1543 $ group_number(geom)) 1544 else 1545 geom_group_set = inp_match(240,.false.,group,sym_spgnames, 1546 $ group_number(geom)) 1547 1548c try car file style names 1549 if (.not. geom_group_set ) then 1550 geom_group_set = inp_match(230,.false.,group,sym_carnames, 1551 $ group_number(geom)) 1552 endif 1553 1554 endif 1555c 1556 end 1557c 1558C> \brief Define velocities for the centers 1559c 1560C> In dynamics simulations the centers in the system move with a 1561C> velocity. This function allows these velocities to be stored in 1562C> a geometry instance. It is assumed that the number of centers in 1563C> the geometry has already been defined. 1564c 1565C> \return Returns .true. if the velocities were stored successfully, 1566C> and .false. otherwise. 1567c 1568 logical function geom_vel_set(geom, vel) 1569 implicit none 1570#include "nwc_const.fh" 1571#include "geomP.fh" 1572c 1573 integer geom !< [Input] the geometry handle 1574 double precision vel(3, *) !< [Input] the velocities 1575 logical geom_check_handle, geom_check_cent 1576 external geom_check_handle, geom_check_cent 1577c 1578 geom_vel_set = geom_check_handle(geom, 'geom_vel_set') 1579 if (.not. geom_vel_set) return 1580c 1581 call dcopy(3*ncenter(geom), vel, 1, velocities(1,1,geom), 1) 1582c 1583 end 1584c 1585C> \brief Retrieve the velocities of the centers 1586c 1587C> Retrieves the velocities of the centers in the specified geometry 1588C> instance. 1589c 1590C> \return Return .true. if the velocities we found successfully, 1591C> and .false. otherwise. 1592c 1593 logical function geom_vel_get(geom, vel) 1594 implicit none 1595#include "nwc_const.fh" 1596#include "geomP.fh" 1597c 1598 integer geom !< [Input] the geometry handle 1599 double precision vel(3, *) !< [Output] the center velocities 1600 logical geom_check_handle, geom_check_cent 1601 external geom_check_handle, geom_check_cent 1602c 1603 geom_vel_get = geom_check_handle(geom, 'geom_vel_get') 1604 if (.not. geom_vel_get) return 1605c 1606 call dcopy(3*ncenter(geom), velocities(1,1,geom), 1, vel, 1) 1607c 1608 end 1609 function geom_cart_set_gen(geom, i0,ncent,nt,ns, t, c, q) 1610 implicit none 1611#include "nwc_const.fh" 1612#include "geomP.fh" 1613#include "stdio.fh" 1614c 1615 logical geom_cart_set_gen 1616 integer geom ! [input] 1617 integer i0 ! [input] 1618 integer ncent ! [input] 1619 integer nt ! [input] 1620 integer ns ! [input] 1621 character*1 t(nt*ns) ! [input] 1622 double precision c(nt,3) ! [input] 1623 double precision q(nt) ! [input] 1624 logical geom_check_handle, geom_check_cent 1625 external geom_check_handle, geom_check_cent 1626 integer i,j 1627 double precision scale 1628 integer k 1629 character*16 atag 1630c 1631 geom_cart_set_gen = geom_check_handle(geom, 'geom_cart_set_gen') 1632 if (.not. geom_cart_set_gen) return 1633c 1634 if (ncent.le.0) then 1635 write(LuOut,*) ' geom_cart_set_gen: too few centers ',ncent, 1636 $ names(geom)(1:lenn(geom)) 1637 geom_cart_set_gen = .false. 1638 return 1639 else if (ncent.gt.max_cent) then 1640 write(LuOut,*) ' geom_cart_set_gen: too many centers ',ncent, 1641 $ names(geom)(1:lenn(geom)) 1642 geom_cart_set_gen = .false. 1643 return 1644 end if 1645c 1646 if (ncenter(geom).ne.ncent) then 1647 ncenter_unique(geom) = ncent ! Assume symmetry is unchanged !!!!! 1648 endif 1649 ncenter(geom) = ncent 1650 scale = angstrom_to_au 1651 do i = 1, ncent 1652 j = i0+i-1 1653 atag = "" 1654 do k=1,16 1655 atag(k:k) = t((j-1)*ns+k) 1656 end do 1657 tags(i,geom) = atag 1658 charge(i,geom) = q(j) 1659 coords(1,i,geom) = scale*c(j,1) 1660 coords(2,i,geom) = scale*c(j,2) 1661 coords(3,i,geom) = scale*c(j,3) 1662 unique_cent(i,geom) = i 1663 end do 1664c 1665 end 1666 function geom_cart_set_gen1(geom, i0,ncent,nt,ns, t, c, q) 1667 implicit none 1668#include "nwc_const.fh" 1669#include "geomP.fh" 1670#include "stdio.fh" 1671c 1672 logical geom_cart_set_gen1 1673 integer geom ! [input] 1674 integer i0 ! [input] 1675 integer ncent ! [input] 1676 integer nt ! [input] 1677 integer ns ! [input] 1678 character*1 t(nt*ns) ! [input] 1679 double precision c(3,nt) ! [input] 1680 double precision q(nt) ! [input] 1681 logical geom_check_handle, geom_check_cent 1682 external geom_check_handle, geom_check_cent 1683 integer i,j 1684 double precision scale 1685 integer k 1686 character*16 atag 1687c 1688 geom_cart_set_gen1 = geom_check_handle(geom, 'geom_cart_set') 1689 if (.not. geom_cart_set_gen1) return 1690c 1691 if (ncent.le.0) then 1692 write(LuOut,*) ' geom_cart_set: too few centers ',ncent, 1693 $ names(geom)(1:lenn(geom)) 1694 geom_cart_set_gen1 = .false. 1695 return 1696 else if (ncent.gt.max_cent) then 1697 write(LuOut,*) ' geom_cart_set: too many centers ',ncent, 1698 $ names(geom)(1:lenn(geom)) 1699 geom_cart_set_gen1 = .false. 1700 return 1701 end if 1702c 1703 if (ncenter(geom).ne.ncent) then 1704 ncenter_unique(geom) = ncent ! Assume symmetry is unchanged !!!!! 1705 endif 1706 ncenter(geom) = ncent 1707 scale = angstrom_to_au 1708 do i = 1, ncent 1709 j = i0+i-1 1710 atag = "" 1711 do k=1,16 1712 atag(k:k) = t((j-1)*ns+k) 1713 end do 1714 tags(i,geom) = atag 1715 charge(i,geom) = q(j) 1716 coords(1,i,geom) = scale*c(1,j) 1717 coords(2,i,geom) = scale*c(2,j) 1718 coords(3,i,geom) = scale*c(3,j) 1719 unique_cent(i,geom) = i 1720 end do 1721c 1722 end 1723 function geom_cart_set1(geom, i0,ncent,nt, t, c, q) 1724 implicit none 1725#include "nwc_const.fh" 1726#include "geomP.fh" 1727#include "stdio.fh" 1728c 1729 logical geom_cart_set1 1730 integer geom ! [input] 1731 integer i0 ! [input] 1732 integer ncent ! [input] 1733 integer nt ! [input] 1734 character*16 t(nt) ! [input] 1735 double precision c(nt,3) ! [input] 1736 double precision q(nt) ! [input] 1737 logical geom_check_handle, geom_check_cent 1738 external geom_check_handle, geom_check_cent 1739 integer i,j 1740 double precision scale 1741c 1742 geom_cart_set1 = geom_check_handle(geom, 'geom_cart_set') 1743 if (.not. geom_cart_set1) return 1744c 1745 if (ncent.le.0) then 1746 write(LuOut,*) ' geom_cart_set: too few centers ',ncent, 1747 $ names(geom)(1:lenn(geom)) 1748 geom_cart_set1 = .false. 1749 return 1750 else if (ncent.gt.max_cent) then 1751 write(LuOut,*) ' geom_cart_set: too many centers ',ncent, 1752 $ names(geom)(1:lenn(geom)) 1753 geom_cart_set1 = .false. 1754 return 1755 end if 1756c 1757 if (ncenter(geom).ne.ncent) then 1758 ncenter_unique(geom) = ncent ! Assume symmetry is unchanged !!!!! 1759 endif 1760 ncenter(geom) = ncent 1761 scale = angstrom_to_au 1762 do i = 1, ncent 1763 j = i0+i-1 1764 tags(i,geom) = t(j) 1765 charge(i,geom) = q(j) 1766 coords(1,i,geom) = scale*c(j,1) 1767 coords(2,i,geom) = scale*c(j,2) 1768 coords(3,i,geom) = scale*c(j,3) 1769 unique_cent(i,geom) = i 1770 end do 1771c 1772 end 1773 logical function geom_cart_set(geom, ncent, t, c, q) 1774 implicit none 1775#include "nwc_const.fh" 1776#include "geomP.fh" 1777#include "stdio.fh" 1778c 1779 integer geom ! [input] 1780 integer ncent ! [input] 1781 character*16 t(ncent) ! [input] 1782 double precision c(3, ncent) ! [input] 1783 double precision q(ncent) ! [input] 1784 logical geom_check_handle, geom_check_cent 1785 external geom_check_handle, geom_check_cent 1786 integer i 1787c 1788 geom_cart_set = geom_check_handle(geom, 'geom_cart_set') 1789 if (.not. geom_cart_set) return 1790c 1791 if (ncent.le.0) then 1792 write(LuOut,*) ' geom_cart_set: too few centers ',ncent, 1793 $ names(geom)(1:lenn(geom)) 1794 geom_cart_set = .false. 1795 return 1796 else if (ncent.gt.max_cent) then 1797 write(LuOut,*) ' geom_cart_set: too many centers ',ncent, 1798 $ names(geom)(1:lenn(geom)) 1799 geom_cart_set = .false. 1800 return 1801 end if 1802c 1803 if (ncenter(geom).ne.ncent) then 1804 ncenter_unique(geom) = ncent ! Assume symmetry is unchanged !!!!! 1805 endif 1806 ncenter(geom) = ncent 1807 do i = 1, ncent 1808 tags(i,geom) = t(i) 1809 charge(i,geom) = q(i) 1810 coords(1,i,geom) = c(1,i) 1811 coords(2,i,geom) = c(2,i) 1812 coords(3,i,geom) = c(3,i) 1813 unique_cent(i,geom) = i 1814 end do 1815c 1816 end 1817c 1818C> \brief Extract only the coordinates and charges from a geometry 1819C> instance 1820c 1821C> \return Return .true. if successfull, and .false. otherwise. 1822c 1823 logical function geom_efc_cart_get(geom, ncent, c, q) 1824 implicit none 1825#include "nwc_const.fh" 1826#include "geomP.fh" 1827c 1828 integer geom ! [Input] the geometry handle 1829 integer ncent ! [Output] the number of centers 1830 double precision c(3, ncent) ! [Output] the coordinates 1831 double precision q(ncent) ! [Output] the charges 1832 logical geom_check_handle, geom_check_cent 1833 external geom_check_handle, geom_check_cent 1834 integer i 1835c 1836c- geom_efc_cart_get = geom_check_handle(geom, 'geom_efc_cart_get') 1837c- if (.not. geom_efc_cart_get) return 1838c 1839 ncent = ncenter(geom) 1840 do i = 1, ncent 1841 q(i) = charge(i,geom) 1842 c(1,i) = coords(1,i,geom) 1843 c(2,i) = coords(2,i,geom) 1844 c(3,i) = coords(3,i,geom) 1845 end do 1846 geom_efc_cart_get = .true. 1847c 1848 end 1849c 1850C> \brief Define only the coordinates and charges of a geometry 1851C> instance 1852c 1853C> \return Return .true. if successfull, and .false. otherwise. 1854c 1855 logical function geom_efc_cart_set(geom, ncent, c, q) 1856 implicit none 1857#include "nwc_const.fh" 1858#include "geomP.fh" 1859c 1860 integer geom ! [Input] the geometry handle 1861 integer ncent ! [Input] the number of centers 1862 double precision c(3, ncent) ! [Input] the coordinates 1863 double precision q(ncent) ! [Input] the charges 1864 logical geom_check_handle, geom_check_cent 1865 external geom_check_handle, geom_check_cent 1866 integer i 1867c 1868c- geom_efc_cart_set = geom_check_handle(geom, 'geom_efc_cart_set') 1869c- if (.not. geom_efc_cart_set) return 1870c 1871 ncenter(geom) = ncent 1872 do i = 1, ncent 1873 charge(i,geom) = q(i) 1874 coords(1,i,geom) = c(1,i) 1875 coords(2,i,geom) = c(2,i) 1876 coords(3,i,geom) = c(3,i) 1877 end do 1878 geom_efc_cart_set = .true. 1879c 1880 end 1881c 1882C> \brief Extract the charges from a geometry instance 1883c 1884C> \return Return .true. if successfull, and .false. otherwise. 1885c 1886 function geom_cart_get_charges(geom, ncent,q) 1887 implicit none 1888#include "nwc_const.fh" 1889#include "geomP.fh" 1890c 1891 logical geom_cart_get_charges 1892 integer geom !< [Input] the geometry handle 1893 integer ncent !< [Output] the number of centers 1894 double precision q(ncent) !< [Output] the charges 1895 logical geom_check_handle, geom_check_cent 1896 external geom_check_handle, geom_check_cent 1897 integer i 1898c 1899 geom_cart_get_charges = geom_check_handle(geom, 'geom_cart_get') 1900 if (.not. geom_cart_get_charges) return 1901c 1902 ncent = ncenter(geom) 1903 do i = 1, ncent 1904 q(i) = charge(i,geom) 1905 end do 1906c 1907 end 1908c 1909C> \brief Extract the tags, coordinates and charges from a geometry 1910C> instance 1911c 1912C> \return Return .true. if successfull, and .false. otherwise. 1913c 1914 function geom_cart_get(geom, ncent, t, c, q) 1915 implicit none 1916#include "nwc_const.fh" 1917#include "geomP.fh" 1918c 1919 logical geom_cart_get 1920 integer geom !< [Input] the geometry handle 1921 integer ncent !< [Output] the number of centers 1922 character*16 t(ncent) !< [Output] the tags 1923 double precision c(3, ncent) !< [Output] the coordinates 1924 double precision q(ncent) !< [Output] the charges 1925 logical geom_check_handle, geom_check_cent 1926 external geom_check_handle, geom_check_cent 1927 integer i 1928c 1929 geom_cart_get = geom_check_handle(geom, 'geom_cart_get') 1930 if (.not. geom_cart_get) return 1931c 1932 ncent = ncenter(geom) 1933 do i = 1, ncent 1934 t(i) = tags(i,geom) 1935 q(i) = charge(i,geom) 1936 c(1,i) = coords(1,i,geom) 1937 c(2,i) = coords(2,i,geom) 1938 c(3,i) = coords(3,i,geom) 1939 end do 1940c 1941 end 1942 1943 function geom_cart_get1(geom, ncent, t, c) 1944 implicit none 1945#include "nwc_const.fh" 1946#include "geomP.fh" 1947c 1948 logical geom_cart_get1 1949 integer geom !< [Input] the geometry handle 1950 integer ncent !< [Output] the number of centers 1951 character*16 t(ncent) !< [Output] the tags 1952 double precision c(3, ncent) !< [Output] the coordinates 1953 logical geom_check_handle, geom_check_cent 1954 external geom_check_handle, geom_check_cent 1955 integer i 1956c 1957 geom_cart_get1 = geom_check_handle(geom, 'geom_cart_get') 1958 if (.not. geom_cart_get1) return 1959c 1960 ncent = ncenter(geom) 1961 do i = 1, ncent 1962 t(i) = tags(i,geom) 1963 c(1,i) = coords(1,i,geom) 1964 c(2,i) = coords(2,i,geom) 1965 c(3,i) = coords(3,i,geom) 1966 end do 1967c 1968 end 1969c 1970c 1971C> \brief Extract the tags, coordinates, charges and atomic numbers from 1972C> a geometry instance 1973c 1974C> Extracts the tags, coordinates, and charges from the geometry by 1975C> simply copying the data. The atomic numbers are based on a 1976C> translation of the tags. If the tag does not correspond to a chemical 1977C> element, e.g. 'X' or 'Bq', the atomic number is 0. 1978c 1979C> \return Return .true. if successfull, and .false. otherwise. 1980c 1981 function geom_cart_get2(geom, ncent, t, c, q, atnum) 1982 implicit none 1983#include "nwc_const.fh" 1984#include "geomP.fh" 1985c 1986 logical geom_cart_get2 1987 logical status_tagi 1988 integer geom !< [Input] the geometry handle 1989 integer ncent !< [Output] the number of centers 1990 character*16 t(ncent) !< [Output] the tags 1991 double precision c(3, ncent) !< [Output] the coordinates 1992 double precision q(ncent) !< [Output] the charges 1993 integer atnum(ncent) !< [Output] the atomic numbers 1994 logical geom_check_handle, geom_check_cent 1995 external geom_check_handle, geom_check_cent 1996 integer i 1997 integer iatn 1998 character*2 symi 1999 character*16 elei 2000 logical geom_tag_to_element 2001 external geom_tag_to_element 2002c 2003 geom_cart_get2 = geom_check_handle(geom, 'geom_cart_get') 2004 if (.not. geom_cart_get2) return 2005c 2006 ncent = ncenter(geom) 2007 do i = 1, ncent 2008 t(i) = tags(i,geom) 2009 q(i) = charge(i,geom) 2010 c(1,i) = coords(1,i,geom) 2011 c(2,i) = coords(2,i,geom) 2012 c(3,i) = coords(3,i,geom) 2013 status_tagi = geom_tag_to_element(t(i),symi,elei,iatn) 2014 atnum(i) = iatn ! iatn is 0 if status_tagi is false 2015 end do 2016c 2017 end 2018c 2019C> \brief Extracts the coordinates of all centers in a geometry 2020c 2021C> Extracts the coordinates of all centers in a geometry assuming 2022C> that the caller has made sure the buffer is big enough. If the 2023C> buffer is too small the results are undefined. 2024c 2025C> \return Returns .true. if the function was successfull, 2026C> and .false. otherwise. 2027 logical function geom_cart_coords_get(geom, c) 2028 implicit none 2029#include "nwc_const.fh" 2030#include "geomP.fh" 2031c 2032 integer geom !< [Input] the geometry handle 2033 double precision c(3, *) !< [Output] the Cartesian coordinates 2034 logical geom_check_handle, geom_check_cent 2035 external geom_check_handle, geom_check_cent 2036 integer i, ncent 2037c 2038 geom_cart_coords_get = 2039 $ geom_check_handle(geom, 'geom_cart_coords_get') 2040 if (.not. geom_cart_coords_get) return 2041c 2042 ncent = ncenter(geom) 2043 do i = 1, ncent 2044 c(1,i) = coords(1,i,geom) 2045 c(2,i) = coords(2,i,geom) 2046 c(3,i) = coords(3,i,geom) 2047 end do 2048c 2049 end 2050c 2051C> \brief Defines the coordinates of all centers in a geometry 2052c 2053C> Defines the coordinates of all centers in a geometry assuming 2054C> that the caller has previously defined how many centers there 2055C> are (see e.g. geom_ncent_set). 2056c 2057C> \return Returns .true. if the function was successfull, 2058C> and .false. otherwise. 2059 logical function geom_cart_coords_set(geom, c) 2060 implicit none 2061#include "nwc_const.fh" 2062#include "geomP.fh" 2063c 2064 integer geom !< [Input] the geometry handle 2065 double precision c(3, *) !< [Input] the coordinates 2066 logical geom_check_handle, geom_check_cent 2067 external geom_check_handle, geom_check_cent 2068 integer i, ncent 2069c 2070 geom_cart_coords_set = 2071 $ geom_check_handle(geom, 'geom_cart_coords_set') 2072 if (.not. geom_cart_coords_set) return 2073c 2074 ncent = ncenter(geom) 2075 do i = 1, ncent 2076 coords(1,i,geom) = c(1,i) 2077 coords(2,i,geom) = c(2,i) 2078 coords(3,i,geom) = c(3,i) 2079 end do 2080c 2081 end 2082c 2083C> \brief Extracts the coordinates and velocities of all centers in a geometry 2084c 2085C> Extracts the coordinates and velocities of all centers in a geometry assuming 2086C> that the caller has made sure the buffer is big enough. If the 2087C> buffer is too small the results are undefined. 2088c 2089C> \return Returns .true. if the function was successfull, 2090C> and .false. otherwise. 2091 logical function geom_coords_vels_get(geom, c, v) 2092 implicit none 2093#include "nwc_const.fh" 2094#include "geomP.fh" 2095c 2096 integer geom !< [Input] the geometry handle 2097 double precision c(3,*) !< [Output] cartesian coordinates 2098 double precision v(3,*) !< [Output] velocities 2099 logical geom_check_handle, geom_check_cent 2100 external geom_check_handle, geom_check_cent 2101 integer i, ncent 2102c 2103 geom_coords_vels_get = 2104 $ geom_check_handle(geom, 'geom_coords_vels_get') 2105 if (.not. geom_coords_vels_get) return 2106c 2107 ncent = ncenter(geom) 2108 do i = 1, ncent 2109 c(1,i) = coords(1,i,geom) 2110 c(2,i) = coords(2,i,geom) 2111 c(3,i) = coords(3,i,geom) 2112 v(1,i) = velocities(1,i,geom) 2113 v(2,i) = velocities(2,i,geom) 2114 v(3,i) = velocities(3,i,geom) 2115 end do 2116c 2117 end 2118c 2119C> \brief Defines the coordinates and velocities of all centers in a geometry 2120c 2121C> Defines the coordinates and velocities of all centers in a geometry assuming 2122C> that the caller has previously defined how many centers there 2123C> are (see e.g. geom_ncent_set). 2124c 2125C> \return Returns .true. if the function was successfull, 2126C> and .false. otherwise. 2127 logical function geom_coords_vels_set(geom, c, v) 2128 implicit none 2129#include "nwc_const.fh" 2130#include "geomP.fh" 2131c 2132 integer geom !< [Input] the geometry handle 2133 double precision c(3, *) !< [Input] coordinates 2134 double precision v(3, *) !< [Input] velocities 2135 logical geom_check_handle, geom_check_cent 2136 external geom_check_handle, geom_check_cent 2137 integer i, ncent 2138c 2139 geom_coords_vels_set = 2140 $ geom_check_handle(geom, 'geom_coords_vels_set') 2141 if (.not. geom_coords_vels_set) return 2142c 2143 ncent = ncenter(geom) 2144 do i = 1, ncent 2145 coords(1,i,geom) = c(1,i) 2146 coords(2,i,geom) = c(2,i) 2147 coords(3,i,geom) = c(3,i) 2148 velocities(1,i,geom) = c(1,i) 2149 velocities(2,i,geom) = c(2,i) 2150 velocities(3,i,geom) = c(3,i) 2151 end do 2152c 2153 end 2154c 2155C> \brief Look up data of a specific atom 2156c 2157C> Extracts the data, such as the tag, coordinates and charge, of a 2158C> specific center of a geometry instance. The center of interest is 2159C> given by the rank of the center. 2160c 2161C> \return Returns .true. if the function was successful, .false. otherwise. 2162 logical function geom_cent_get(geom, icent, t, c, q) 2163 implicit none 2164#include "nwc_const.fh" 2165#include "geomP.fh" 2166c 2167 integer geom !< [Input] the geometry handle 2168 integer icent !< [Input] the center rank 2169 character*16 t !< [Output] the center tag 2170 double precision c(3) !< [Output] the center coordinates 2171 double precision q !< [Output] the center charge 2172 logical geom_check_handle, geom_check_cent 2173 external geom_check_handle, geom_check_cent 2174c 2175 geom_cent_get = geom_check_handle(geom, 'geom_cent_get') 2176 if (.not. geom_cent_get) return 2177 geom_cent_get = geom_check_cent(geom, 'geom_cent_get', icent) 2178 if (.not. geom_cent_get) return 2179 2180c 2181 t = tags(icent,geom) 2182 c(1) = coords(1,icent,geom) 2183 c(2) = coords(2,icent,geom) 2184 c(3) = coords(3,icent,geom) 2185 q = charge(icent,geom) 2186 geom_cent_get = .true. 2187c 2188 end 2189c 2190C> \brief Set the data of a specific atom 2191c 2192C> Defines the data, such as the tag, coordinates and charge, of a 2193C> specific center of a geometry instance. The center of interest is 2194C> given by the rank of the center. 2195c 2196C> \return Returns .true. if the function was successful, .false. otherwise. 2197 logical function geom_cent_set(geom, icent, t, c, q) 2198 implicit none 2199#include "nwc_const.fh" 2200#include "geomP.fh" 2201c 2202 integer geom !< [Input] the geometry handle 2203 integer icent !< [Input] the center rank 2204 character*16 t !< [Input] the center tag 2205 double precision c(3) !< [Input] the center coordinates 2206 double precision q !< [Input] the center charge 2207 logical geom_check_handle, geom_check_cent 2208 external geom_check_handle, geom_check_cent 2209c 2210 geom_cent_set = geom_check_handle(geom, 'geom_cent_set') 2211 if (.not. geom_cent_set) return 2212 geom_cent_set = geom_check_cent(geom, 'geom_cent_set', icent) 2213 if (.not. geom_cent_set) return 2214c 2215 tags(icent,geom) = t 2216 coords(1,icent,geom) = c(1) 2217 coords(2,icent,geom) = c(2) 2218 coords(3,icent,geom) = c(3) 2219 charge(icent,geom) = q 2220c 2221c compute effective nuclear repulsion energy, dipole and 2222c interaction with external fields 2223c 2224c ***** commented out by EJB, Please do not uncomment w/o talking to Eric ****** 2225c call geom_compute_values(geom) 2226c ***** commented out by EJB, Please do not uncomment w/o talking to Eric ****** 2227c 2228 end 2229c 2230C> \brief Look up data of a specific atom, including velocity 2231c 2232C> Extracts the data, such as the tag, coordinates, velocity and charge, 2233C> of a specific center of a geometry instance. The center of interest 2234C> is given by the rank of the center. 2235c 2236C> \return Returns .true. if the function was successful, .false. otherwise. 2237c 2238 logical function geom_centv_get(geom, icent, t, c, v, q) 2239 implicit none 2240#include "nwc_const.fh" 2241#include "geomP.fh" 2242c 2243 integer geom !< [Input] the geometry handle 2244 integer icent !< [Input] the center rank 2245 character*16 t !< [Output] the center tag 2246 double precision c(3) !< [Output] the center coordinates 2247 double precision v(3) !< [Output] the center velocity 2248 double precision q !< [Output] the center charge 2249 logical geom_check_handle, geom_check_cent 2250 external geom_check_handle, geom_check_cent 2251c 2252 geom_centv_get = geom_check_handle(geom, 'geom_centv_get') 2253 if (.not. geom_centv_get) return 2254 geom_centv_get = geom_check_cent(geom, 'geom_centv_get', icent) 2255 if (.not. geom_centv_get) return 2256 2257c 2258 t = tags(icent,geom) 2259 c(1) = coords(1,icent,geom) 2260 c(2) = coords(2,icent,geom) 2261 c(3) = coords(3,icent,geom) 2262 v(1) = velocities(1,icent,geom) 2263 v(2) = velocities(2,icent,geom) 2264 v(3) = velocities(3,icent,geom) 2265 q = charge(icent,geom) 2266 geom_centv_get = .true. 2267c 2268 end 2269c 2270C> \brief Store the data of a specific atom, including velocity 2271c 2272C> Stores the data, such as the tag, coordinates, velocity and charge, 2273C> of a specific center of a geometry instance. The center of interest 2274C> is given by the rank of the center. 2275c 2276C> \return Returns .true. if the function was successful, .false. otherwise. 2277c 2278 logical function geom_centv_set(geom, icent, t, c, v, q) 2279 implicit none 2280#include "nwc_const.fh" 2281#include "geomP.fh" 2282c 2283 integer geom !< [Input] the geometry handle 2284 integer icent !< [Input] the center rank 2285 character*16 t !< [Input] the center tag 2286 double precision c(3) !< [Input] the center coordinates 2287 double precision v(3) !< [Input] the center velocity 2288 double precision q !< [Input] the center charge 2289 logical geom_check_handle, geom_check_cent 2290 external geom_check_handle, geom_check_cent 2291c 2292 geom_centv_set = geom_check_handle(geom, 'geom_centv_set') 2293 if (.not. geom_centv_set) return 2294 geom_centv_set = geom_check_cent(geom, 'geom_centv_set', icent) 2295 if (.not. geom_centv_set) return 2296c 2297 tags(icent,geom) = t 2298 coords(1,icent,geom) = c(1) 2299 coords(2,icent,geom) = c(2) 2300 coords(3,icent,geom) = c(3) 2301 velocities(1,icent,geom) = v(1) 2302 velocities(2,icent,geom) = v(2) 2303 velocities(3,icent,geom) = v(3) 2304 charge(icent,geom) = q 2305c 2306c compute effective nuclear repulsion energy, dipole and 2307c interaction with external fields 2308c 2309 call geom_compute_values(geom) 2310c 2311 end 2312c 2313C> \brief Get the number of centers of a geometry 2314c 2315C> Query a geometry for the number of centers in it. 2316C> The function returns .true. if geom holds a valid handle, 2317C> it returns .false. otherwise. 2318 logical function geom_ncent(geom, ncent) 2319 implicit none 2320#include "nwc_const.fh" 2321#include "geomP.fh" 2322c 2323 integer geom !< [input] the geometry handle 2324 integer ncent !< [output] the number of centers 2325 logical geom_check_handle, geom_check_cent 2326 external geom_check_handle, geom_check_cent 2327c 2328 geom_ncent = geom_check_handle(geom, 'geom_ncent') 2329 if (.not. geom_ncent) return 2330 ncent = ncenter(geom) 2331c 2332 end 2333c 2334C> \brief Set the number of centers of a geometry 2335c 2336C> Define the number of centers in a geometry. 2337C> The function returns .true. if geom holds a valid handle, 2338C> it returns .false. otherwise. 2339 logical function geom_ncent_set(geom, ncent) 2340 implicit none 2341#include "nwc_const.fh" 2342#include "geomP.fh" 2343c 2344 integer geom !< [input] the geometry handle 2345 integer ncent !< [input] the number of centers 2346 logical geom_check_handle, geom_check_cent 2347 external geom_check_handle, geom_check_cent 2348c 2349 geom_ncent_set = geom_check_handle(geom, 'geom_ncent_set') 2350 if (.not. geom_ncent_set) return 2351 ncenter(geom) = ncent 2352c 2353 end 2354c 2355C> \brief Extracts the number of symmetry unique centers 2356c 2357C> This function extracts the number of symmetry unique centers from 2358C> a geometry instance. 2359c 2360C> \return Returns .true. if successfull, and .false. otherwise. 2361c 2362 logical function geom_ncent_unique(geom, ncent) 2363 implicit none 2364#include "nwc_const.fh" 2365#include "geomP.fh" 2366c 2367 integer geom !< [Input] the geometry handle 2368 integer ncent !< [Output] the number of unique centers 2369 logical geom_check_handle, geom_check_cent 2370 external geom_check_handle, geom_check_cent 2371c 2372 geom_ncent_unique = geom_check_handle(geom, 'geom_ncent_unique') 2373 if (.not. geom_ncent_unique) return 2374 ncent = ncenter_unique(geom) 2375c 2376 end 2377c 2378C> \brief Checks whether a given center is a point charge 2379c 2380C> \return Returns .true. if the center is a point charge, and .false. 2381C> otherwise. 2382c 2383 logical function geom_isbq(geom, icent) 2384 implicit none 2385#include "nwc_const.fh" 2386#include "inp.fh" 2387#include "geomP.fh" 2388c 2389 integer geom !< [Input] the geometry handle 2390 integer icent !< [Input] the center rank 2391 logical status 2392 character*16 tag 2393 logical geom_check_handle, geom_check_cent 2394 external geom_check_handle, geom_check_cent 2395c 2396 status = geom_check_handle(geom, 'geom_cent_tag') 2397 if (.not. status) then 2398 call errquit("no geometry handle",0,0) 2399 end if 2400 status = geom_check_cent(geom, 'geom_cent_tag', icent) 2401 if (.not. status) then 2402 call errquit("no geometry center",0,0) 2403 end if 2404c 2405 tag = tags(icent,geom) 2406 geom_isbq = inp_compare(0,tag,'bq') 2407c 2408 end 2409c 2410C> \brief Look the tag of a specific center up 2411c 2412C> Extracts the tag of a specified center from the geometry instance. 2413c 2414C> \return Return .true. if the tag was found, and .false. otherwise. 2415c 2416 logical function geom_cent_tag(geom, icent, tag) 2417 implicit none 2418#include "nwc_const.fh" 2419#include "geomP.fh" 2420c 2421 integer geom !< [Input] the geometry handle 2422 integer icent !< [Input] the center rank 2423 character*16 tag !< [Output] the center tag 2424 logical geom_check_handle, geom_check_cent 2425 external geom_check_handle, geom_check_cent 2426c 2427 geom_cent_tag = geom_check_handle(geom, 'geom_cent_tag') 2428 if (.not. geom_cent_tag) return 2429 geom_cent_tag = geom_check_cent(geom, 'geom_cent_tag', icent) 2430 if (.not. geom_cent_tag) return 2431c 2432 tag = tags(icent,geom) 2433 geom_cent_tag = .true. 2434c 2435 end 2436 logical function geom_efield_set(geom, ef) 2437 implicit none 2438#include "errquit.fh" 2439#include "nwc_const.fh" 2440#include "geomP.fh" 2441c 2442 integer geom ! [input] 2443 double precision ef ! [input] 2444c 2445 call errquit('geom_efield_set: not yet!', 0, GEOM_ERR) 2446c call geom_set_values(geom) 2447 geom_efield_set = .false. 2448 end 2449 logical function geom_efield_get(geom, ef) 2450 implicit none 2451#include "nwc_const.fh" 2452#include "geomP.fh" 2453c 2454 integer geom ! [input] 2455 double precision ef(3) ! [output] 2456 logical geom_check_handle 2457 external geom_check_handle 2458 integer i 2459c 2460 if (.not. geom_check_handle(geom, 'geom_efield_get')) then 2461 geom_efield_get = .false. 2462 return 2463 end if 2464c 2465 if (oefield(geom)) then 2466 do i = 1, 3 2467 ef(i) = efield(i,geom) 2468 end do 2469 else 2470 do i = 1, 3 2471 ef(i) = 0.0d0 2472 end do 2473 endif 2474 geom_efield_get = .true. 2475 end 2476c 2477C> \brief Print the geometry in XYZ + charge format 2478c 2479C> Write the specified geometry in ASCII to the specified file. The 2480C> geometry is written in the usual XYZ format but with explicit 2481C> charges added. This also implies converting 2482C> the units of the coordinates to Angstrom. 2483c 2484C> \return Returns .true. if the geometry was successfully printed, 2485C> and .false. otherwise. 2486c 2487 logical function geom_print_xyzq(geom, unit) 2488 implicit none 2489#include "nwc_const.fh" 2490#include "geomP.fh" 2491#include "util.fh" 2492#include "inp.fh" 2493#include "stdio.fh" 2494 integer geom !< [Input] the geometry handle 2495 integer unit !< [Input] the file unit number 2496 integer j, icent 2497 double precision scale 2498 logical geom_check_handle 2499 external geom_check_handle 2500c 2501 geom_print_xyzq = .true. 2502 if (.not. geom_check_handle(geom, 'geom_print_xyzq')) then 2503 geom_print_xyzq = .false. 2504 return 2505 end if 2506c 2507 scale = 1.0d0 / angstrom_to_au 2508c 2509 do icent = 1, ncenter(geom) 2510 if(inp_compare(0,tags(icent,geom),'bq')) then 2511 write(unit,3) tags(icent,geom), 2512 $ (coords(j,icent,geom)*scale,j=1,3), 2513 $ charge(icent,geom) 2514 2515 2516 3 format(1x,a16,1x,3f15.8,3x,"charge",3x,f15.8) 2517 else 2518 write(unit,4) tags(icent,geom), 2519 $ (coords(j,icent,geom)*scale,j=1,3) 2520 2521 2522 4 format(1x,a16,1x,3f15.8) 2523 2524 end if 2525 end do 2526c 2527 end 2528c 2529C> \brief Print a geometry in PDB format 2530c 2531C> Write a geometry as ASCII and in PDB format to the specified 2532C> output unit. 2533c 2534C> \return Return .true. if successfull, and .false. otherwise. 2535c 2536 logical function geom_print_pdb(geom, unit) 2537 implicit none 2538#include "nwc_const.fh" 2539#include "geomP.fh" 2540#include "util.fh" 2541#include "inp.fh" 2542#include "stdio.fh" 2543 integer geom !< [Input] the geometry handle 2544 integer unit !< [Input] the file unit number 2545 integer j, icent 2546 double precision scale 2547 logical geom_check_handle 2548 external geom_check_handle 2549c 2550 geom_print_pdb = .true. 2551 if (.not. geom_check_handle(geom, 'geom_print_pdb')) then 2552 geom_print_pdb = .false. 2553 return 2554 end if 2555c 2556 scale = 1.0d0 / angstrom_to_au 2557c 2558 write(unit,1) 2559 1 format("####",T11,"id",T13,"name", 2560 > T38,"x",T46,"y",T54,"z",T57,"charge") 2561 2562 do icent = 1, ncenter(geom) 2563 2564 write(unit,3) icent,tags(icent,geom), 2565 $ (coords(j,icent,geom)*scale,j=1,3), 2566 $ charge(icent,geom) 2567 2568 2569 3 format("ATOM",T7,I5,T13,A4,T31,F8.3,T39,F8.3,T47,F8.3,T55,F6.2) 2570 end do 2571c 2572 end 2573c 2574C> \brief Print the geometry in XYZ format 2575c 2576C> Write the specified geometry in ASCII to the specified file. The 2577C> geometry is written in the usual XYZ format. This implies converting 2578C> the units of the coordinates to Angstrom. 2579c 2580C> \return Returns .true. if the geometry was successfully printed, 2581C> and .false. otherwise. 2582c 2583 logical function geom_print_xyz(geom, unit) 2584 implicit none 2585#include "nwc_const.fh" 2586#include "geomP.fh" 2587#include "util.fh" 2588#include "inp.fh" 2589#include "stdio.fh" 2590 integer geom !< [Input] the geometry handle 2591 integer unit !< [Input] the file unit number 2592 integer j, icent 2593 double precision scale 2594 logical geom_check_handle 2595 external geom_check_handle 2596c 2597 geom_print_xyz = .true. 2598 if (.not. geom_check_handle(geom, 'geom_print_xyz')) then 2599 geom_print_xyz = .false. 2600 return 2601 end if 2602c 2603 scale = 1.0d0 / angstrom_to_au 2604c 2605 write(unit,1) ncenter(geom) 2606 1 format(1x,i5) 2607 write(unit,2) names(geom)(1:inp_strlen(names(geom))) 2608 2 format(1x,a) 2609 do icent = 1, ncenter(geom) 2610 2611cc EJB commented this out 2612cc Convert from cartesian to crystallographic coordinates 2613cc 2614c do i = 1, 3 2615c tmp(i) = 0.0d0 2616c do j = 1, 3 2617c tmp(i) = tmp(i) + 2618c $ amatrix_inv(i,j,geom)*coords(j,icent,geom) 2619c end do 2620c tmp(i) = tmp(i)*scale ! Scale to angstrom 2621c end do 2622c write(unit,3) tags(icent,geom), (tmp(j),j=1,3) 2623 write(unit,3) tags(icent,geom), 2624 $ (coords(j,icent,geom)*scale,j=1,3) 2625 2626 2627 3 format(1x,a16,1x,3f15.8) 2628 end do 2629c 2630 end 2631 logical function mol_geom_print_xyz(geom, unit, energy) 2632 implicit none 2633#include "nwc_const.fh" 2634#include "geomP.fh" 2635#include "util.fh" 2636#include "inp.fh" 2637#include "stdio.fh" 2638 integer geom, unit 2639 integer j, icent 2640 double precision scale, energy 2641 logical geom_check_handle 2642 external geom_check_handle 2643c 2644 mol_geom_print_xyz = .true. 2645 if (.not. geom_check_handle(geom, 'mol_geom_print_xyz')) then 2646 mol_geom_print_xyz = .false. 2647 return 2648 end if 2649c 2650 scale = 1.0d0 / angstrom_to_au 2651c 2652 write(unit,1) ncenter(geom) 2653 1 format(1x,i5) 2654 write(unit,2) energy 2655 2 format(1x,f15.8) 2656 do icent = 1, ncenter(geom) 2657 write(unit,3) tags(icent,geom), 2658 $ (coords(j,icent,geom)*scale,j=1,3) 2659 2660 2661 3 format(1x,a16,1x,3f15.8) 2662 end do 2663c 2664 end 2665c 2666C> \brief Print the contents of a geometry instance 2667c 2668C> Prints the contents of a geometry instance, irrespective 2669C> of whether it is a molecule or a crystal structure. 2670C> The output is always provided on standard output. 2671c 2672C> \return Return .true. if the structure could be printed, 2673C> and .false. otherwise. 2674 logical function geom_print(geom) 2675 implicit none 2676#include "errquit.fh" 2677#include "nwc_const.fh" 2678#include "geomP.fh" 2679#include "util.fh" 2680#include "inp.fh" 2681#include "stdio.fh" 2682c 2683c Basic printing of cartesian geometry 2684c needs support for internal coords, different formats, ... 2685c 2686 integer geom !< [Input] the geometry handle 2687 integer icent, jcent 2688 integer i 2689 double precision scale, tmp(3),twopi 2690 character*80 buf 2691 logical oprint_uniq,ofinite,oprint_crystal 2692c 2693c external functions 2694 logical geom_check_handle, geom_check_cent, geom_get_user_scale, 2695 $ geom_print_zmatrix, geom_any_finuc 2696 external geom_check_handle, geom_check_cent, geom_get_user_scale, 2697 $ geom_print_zmatrix, geom_any_finuc 2698 double precision deter3 2699 external deter3 2700c 2701 if (.not. geom_check_handle(geom, 'geom_print')) then 2702 geom_print = .false. 2703 return 2704 end if 2705c 2706c All of the code seems to be commented out except for 2707c molecules so just return if this is not a molecule (RJH) 2708c 2709c ... it would be nice to have one routine that prints all 2710c possible geometries but ... 2711c 2712 2713 oprint_crystal = (isystype(geom).ne.0) 2714c if (isystype(geom) .ne. 0) then 2715c geom_print = .true. 2716c return 2717c endif 2718 2719c 2720 if (.not. geom_get_user_scale(geom, scale)) 2721 $ call errquit('geom_print: user units?',0, GEOM_ERR) 2722c 2723 buf = ' ' 2724 write(buf,1) 'Geometry', 2725 $ names(geom)(1:lenn(geom)), 2726 $ trans(geom)(1:lent(geom)) 2727 1 format(a,' "',a,'" -> "',a,'"') 2728 write(LuOut,*) 2729 write(LuOut,*) 2730 call util_print_centered(LuOut,buf,40,.true.) 2731 write(LuOut,*) 2732 write(LuOut,2) user_units(geom)(1:inp_strlen(user_units(geom))), 2733 $ scale 2734 2 format(' Output coordinates in ', a, 2735 $ ' (scale by ',f12.9,' to convert to a.u.)') 2736 if (include_bqbq(geom)) 2737 $ write(LuOut,*) ' Include Bq-Bq interactions' 2738c 2739 write(LuOut,*) 2740c 2741 write(LuOut,3) 2742 3 format(' No. Tag Charge X', 2743 $ ' Y Z'/ 2744 $ ' ---- ---------------- ---------- --------------', 2745 $ ' -------------- --------------') 2746 do icent = 1, ncenter(geom) 2747 do i = 1, 3 2748 tmp(i) = coords(i,icent,geom)/scale ! Scale units as necessary 2749 end do 2750 write(LuOut,4) icent, tags(icent,geom), charge(icent,geom), 2751 $ (tmp(i),i=1,3) 2752 4 format(' ',i4,' ',a16,' ',f10.4,3f15.8) 2753 end do 2754c 2755 if (ddot(3*ncenter(geom),velocities(1,1,geom),1, 2756 $ velocities(1,1,geom),1) .gt. 1d-10) then 2757 2758 write(LuOut,*) 2759 write(LuOut,*) 2760 call util_print_centered(LuOut,'Velocities',40,.true.) 2761 write(LuOut,3) 2762 do icent = 1, ncenter(geom) 2763 write(LuOut,4) icent, tags(icent,geom), charge(icent,geom), 2764 $ (velocities(i,icent,geom),i=1,3) 2765 end do 2766 endif 2767c 2768c print out lattice parameters 2769c 2770 if (oprint_crystal) then 2771 write(LuOut,*) 2772 write(LuOut,*) ' Lattice Parameters ' 2773 write(LuOut,*) ' ------------------ ' 2774 write(LuOut,*) 2775 write(LuOut,5) user_units(geom)(1:inp_strlen(user_units(geom))), 2776 > scale 2777 5 format(' lattice vectors in ', a, 2778 $ ' (scale by ',f12.9,' to convert to a.u.)') 2779 write(LuOut,*) 2780 write(LuOut,1241) amatrix(1,1,geom)/scale, 2781 > amatrix(2,1,geom)/scale, 2782 > amatrix(3,1,geom)/scale 2783 write(LuOut,1242) amatrix(1,2,geom)/scale, 2784 > amatrix(2,2,geom)/scale, 2785 > amatrix(3,2,geom)/scale 2786 write(LuOut,1243) amatrix(1,3,geom)/scale, 2787 > amatrix(2,3,geom)/scale, 2788 > amatrix(3,3,geom)/scale 2789 2790 write(LuOut,1232) lattice_vectors(1,geom), 2791 > lattice_vectors(2,geom), 2792 > lattice_vectors(3,geom), 2793 > lattice_angles(1,geom), 2794 > lattice_angles(2,geom), 2795 > lattice_angles(3,geom) 2796 write(LuOut,1231) deter3(amatrix(1,1,geom))/(scale**3) 2797 2798 write(LuOut,*) 2799 write(LuOut,6) 2800 6 format(' reciprocal lattice vectors in a.u.') 2801 write(LuOut,*) 2802 twopi = 8.0d0*datan(1.0d0) 2803 write(LuOut,1244) amatrix_inv(1,1,geom)*twopi, 2804 > amatrix_inv(1,2,geom)*twopi, 2805 > amatrix_inv(1,3,geom)*twopi 2806 write(LuOut,1245) amatrix_inv(2,1,geom)*twopi, 2807 > amatrix_inv(2,2,geom)*twopi, 2808 > amatrix_inv(2,3,geom)*twopi 2809 write(LuOut,1246) amatrix_inv(3,1,geom)*twopi, 2810 > amatrix_inv(3,2,geom)*twopi, 2811 > amatrix_inv(3,3,geom)*twopi 2812 2813 2814 end if 2815 2816c 2817c Only print out the masses for unique tags ... the structure 2818c should actually only store the data for unique tags. 2819c Also, keep all common output within 80 columns 2820c 2821 ofinite = geom_any_finuc(geom) 2822 write(LuOut,*) 2823 if (ofinite) then 2824 write(LuOut,*) ' Atomic Mass and Nuclear Exponent ' 2825 write(LuOut,*) ' -------------------------------- ' 2826 else 2827 write(LuOut,*) ' Atomic Mass ' 2828 write(LuOut,*) ' ----------- ' 2829 end if 2830 write(LuOut,*) 2831 do icent = 1, ncenter(geom) 2832 if (abs(geom_mass(icent,geom)).lt.1.0d-07) goto 765 2833 do jcent = 1, icent-1 2834 if (tags(icent,geom) .eq. tags(jcent,geom)) goto 765 2835 enddo 2836 if (geom_invnucexp(icent,geom) .gt. 0.0d0) then 2837 write(LuOut,43) tags(icent,geom), geom_mass(icent,geom), 2838 & 1.0d0/geom_invnucexp(icent,geom) 2839 43 format(' ',a16,' ',f10.6,1pe20.6) 2840 else 2841 write(LuOut,44) tags(icent,geom), geom_mass(icent,geom) 2842 44 format(' ',a16,' ',f10.6) 2843 end if 2844765 continue 2845 enddo 2846 2847 write(LuOut,*) 2848 if (.not.oprint_crystal) then 2849c 2850 write(LuOut,41) erep(geom) 2851 41 format(/' Effective nuclear repulsion energy (a.u.) ', f18.10/) 2852c 2853 write(LuOut,91) 2854 91 format(' Nuclear Dipole moment (a.u.) ') 2855 write(LuOut,101) 2856 101 format(' ----------------------------') 2857 write(LuOut,7) 2858 7 format(' X Y Z'/ 2859 $ ' ---------------- ---------------- ----------------') 2860 write(LuOut,8) (ndipole(i,geom), i=1,3) 2861 8 format(3(1x,f16.10)) 2862 end if 2863 write(LuOut,*) 2864c 2865 oprint_uniq = sym_num_ops(geom) .gt. 0 2866 if (oprint_uniq) then 2867 call sym_print_all(geom,.true.,oprint_uniq,.false., 2868 > .false.,.false.) 2869 endif 2870c 2871 if (zmt_source(geom) .ne. ' ' .and. 2872 $ util_print('geomzmat',print_none)) then 2873c JEM: Must pass an array, not a scalar 2874 geom_print = geom_print_zmatrix(geom,(/0.d0/),' ',.false.) 2875 else 2876 geom_print = .true. 2877 endif 2878c 2879 return 2880 1231 FORMAT(5x,' omega=',f8.1) 2881 1232 FORMAT(5x,' a= ',f8.3,' b= ',f8.3,' c= ',f8.3, 2882 > /5x,' alpha=',f8.3,' beta=',f8.3,' gamma=',f8.3) 2883 1241 FORMAT(5x,' a1=<',3f8.3,' >') 2884 1242 FORMAT(5x,' a2=<',3f8.3,' >') 2885 1243 FORMAT(5x,' a3=<',3f8.3,' >') 2886 1244 FORMAT(5x,' b1=<',3f8.3,' >') 2887 1245 FORMAT(5x,' b2=<',3f8.3,' >') 2888 1246 FORMAT(5x,' b3=<',3f8.3,' >') 2889 2890 end 2891 2892* ************************************************** 2893* * * 2894* * geom_use_primitive * 2895* * * 2896* ************************************************** 2897 logical function geom_use_primitive(geom) 2898 implicit none 2899 integer geom 2900#include "nwc_const.fh" 2901#include "geomP.fh" 2902 geom_use_primitive = use_primitive(geom) 2903 return 2904 end 2905 2906* ************************************************** 2907* * * 2908* * geom_primitive_center * 2909* * * 2910* ************************************************** 2911 character*1 function geom_primitive_center(geom) 2912 implicit none 2913 integer geom 2914#include "nwc_const.fh" 2915#include "geomP.fh" 2916 geom_primitive_center = primitive_center(geom) 2917 return 2918 end 2919 2920 2921* ************************************************** 2922* * * 2923* * geom_is_conventional * 2924* * * 2925* ************************************************** 2926 2927 logical function geom_is_conventional(geom) 2928 implicit none 2929 integer geom 2930 2931#include "errquit.fh" 2932#include "nwc_const.fh" 2933#include "geomP.fh" 2934#include "util.fh" 2935#include "inp.fh" 2936#include "stdio.fh" 2937 2938 logical value,is_convention 2939 real*8 lat(6),radtodeg 2940 2941 integer grp_num,crystal 2942 integer Triclinic,Monoclinic,Orthorhombic 2943 integer Tetragonal,Trigonal,Hexagonal,Cubic 2944 parameter (Triclinic=1,Monoclinic=2,Orthorhombic=3) 2945 parameter (Tetragonal=4,Trigonal=5,Hexagonal=6,Cubic=7) 2946 2947 logical geom_lattice_get 2948 external geom_lattice_get 2949 2950 radtodeg = 180.0d0/(4.0d0*datan(1.0d0)) 2951 2952 value = geom_lattice_get(geom,lat) 2953 lat(4) = lat(4)*radtodeg 2954 lat(5) = lat(5)*radtodeg 2955 lat(6) = lat(6)*radtodeg 2956 grp_num = group_number(geom) 2957 2958 if (grp_num.lt.3) crystal = Triclinic 2959 if ((grp_num.ge.3 ).and.(grp_num.lt.16 ))crystal = Monoclinic 2960 if ((grp_num.ge.16 ).and.(grp_num.lt.75 ))crystal = Orthorhombic 2961 if ((grp_num.ge.75 ).and.(grp_num.lt.143))crystal = Tetragonal 2962 if ((grp_num.ge.143).and.(grp_num.lt.168))crystal = Trigonal 2963 if ((grp_num.ge.168).and.(grp_num.lt.195))crystal = Hexagonal 2964 if ((grp_num.ge.195).and.(grp_num.lt.231))crystal = Cubic 2965 is_convention = .true. 2966 if (crystal.eq.Triclinic) then 2967 is_convention=is_convention.and.(dabs(lat(4)-90.0d0).gt.1.0d-3) 2968 is_convention=is_convention.and.(dabs(lat(5)-90.0d0).gt.1.0d-3) 2969 is_convention=is_convention.and.(dabs(lat(6)-90.0d0).gt.1.0d-3) 2970 is_convention=is_convention.and.(dabs(lat(1)-lat(2)).gt.1.0d-3) 2971 is_convention=is_convention.and.(dabs(lat(1)-lat(3)).gt.1.0d-3) 2972 is_convention=is_convention.and.(dabs(lat(2)-lat(3)).gt.1.0d-3) 2973 else if (crystal.eq.Monoclinic) then 2974 is_convention=is_convention.and.(dabs(lat(4)-90.0d0).lt.1.0d-3) 2975 is_convention=is_convention.and.(dabs(lat(5)-90.0d0).gt.1.0d-3) 2976 is_convention=is_convention.and.(dabs(lat(6)-90.0d0).lt.1.0d-3) 2977 is_convention=is_convention.and.(dabs(lat(1)-lat(2)).gt.1.0d-3) 2978 is_convention=is_convention.and.(dabs(lat(1)-lat(3)).gt.1.0d-3) 2979 is_convention=is_convention.and.(dabs(lat(2)-lat(3)).gt.1.0d-3) 2980 else if (crystal.eq.Orthorhombic) then 2981 is_convention=is_convention.and.(dabs(lat(4)-90.0d0).lt.1.0d-3) 2982 is_convention=is_convention.and.(dabs(lat(5)-90.0d0).lt.1.0d-3) 2983 is_convention=is_convention.and.(dabs(lat(6)-90.0d0).lt.1.0d-3) 2984 is_convention=is_convention.and.(dabs(lat(1)-lat(2)).gt.1.0d-3) 2985 is_convention=is_convention.and.(dabs(lat(1)-lat(3)).gt.1.0d-3) 2986 is_convention=is_convention.and.(dabs(lat(2)-lat(3)).gt.1.0d-3) 2987 else if (crystal.eq.Tetragonal) then 2988 is_convention=is_convention.and.(dabs(lat(4)-90.0d0).lt.1.0d-3) 2989 is_convention=is_convention.and.(dabs(lat(5)-90.0d0).lt.1.0d-3) 2990 is_convention=is_convention.and.(dabs(lat(6)-90.0d0).lt.1.0d-3) 2991 is_convention=is_convention.and.(dabs(lat(1)-lat(2)).lt.1.0d-3) 2992 is_convention=is_convention.and.(dabs(lat(1)-lat(3)).gt.1.0d-3) 2993 else if (crystal.eq.Trigonal) then 2994 is_convention=is_convention.and.(dabs(lat(4)-90.0d0).lt.1.0d-3) 2995 is_convention=is_convention.and.(dabs(lat(5)-90.0d0).lt.1.0d-3) 2996 is_convention=is_convention.and.(dabs(lat(6)-120.0d0).lt.1.d-3) 2997 is_convention=is_convention.and.(dabs(lat(1)-lat(2)).lt.1.0d-3) 2998 else if (crystal.eq.Hexagonal) then 2999 is_convention=is_convention.and.(dabs(lat(4)-90.0d0).lt.1.0d-3) 3000 is_convention=is_convention.and.(dabs(lat(5)-90.0d0).lt.1.0d-3) 3001 is_convention=is_convention.and.(dabs(lat(6)-120.0d0).lt.1.d-3) 3002 is_convention=is_convention.and.(dabs(lat(1)-lat(2)).lt.1.0d-3) 3003 else if (crystal.eq.Cubic) then 3004 is_convention=is_convention.and.(dabs(lat(4)-90.0d0).lt.1.0d-3) 3005 is_convention=is_convention.and.(dabs(lat(5)-90.0d0).lt.1.0d-3) 3006 is_convention=is_convention.and.(dabs(lat(6)-90.0d0).lt.1.0d-3) 3007 is_convention=is_convention.and.(dabs(lat(1)-lat(2)).lt.1.0d-3) 3008 is_convention=is_convention.and.(dabs(lat(1)-lat(3)).lt.1.0d-3) 3009 is_convention=is_convention.and.(dabs(lat(2)-lat(3)).lt.1.0d-3) 3010 end if 3011 3012 geom_is_conventional = is_convention 3013 return 3014 end 3015 3016* ***************************************************** 3017* * * 3018* * geom_convert_to_primitive * 3019* * * 3020* ***************************************************** 3021* 3022* This routine converts conventional centered cells to primitive cells 3023* 3024* The conventions used to relate the centered cells (abc) to the 3025* primitive cells (a'b'c') are as follows: 3026* 3027* A-centered: The author's (DGC) 3028* a'=a, b'=(b+c)/2, c'=(-b+c)/2 3029* C-centered: Orthohexagonal cell convention (from Int. Tables, Fig. 5.8, p.70, cell #C2) 3030* a'=(a+b)/2, b'=(-a+b)/2, c'=c 3031* R-centered: Obverse Int. Tables, Table 5.1, p.78 - Cell #1 3032* See also Figs. 5.7a & c, p.79) 3033* a' = 2a/3 + b/3 + c/3 3034* b' = -a/3 + b/3 + c/3 3035* c' = -a/3 -2b/3 + c/3 3036* I-centered: Int. Tables, Table 5.1, p.76. See also Fig. 5.4, p.77. 3037* a' = -a/2 + b/2 + c/2 3038* b' = a/2 - b/2 + c/2 3039* c' = a/2 + b/2 - c/2 3040* F-centered: Int. Tables, Table 5.1, p.77. See also Fig. 5.5, p.77. 3041* a' = (b+c)/2, b' = (a+c)/2, c' = (a+b)/2 3042* 3043* 3044c---> The following is a list of the centered 3D groups: 3045c 3046c A-centered (4 total): 38, 39, 40, 41 - orthorhombic 3047c 3048c C-centered (16 total): 5, 8, 9, 12, 15, 20, 21, 35, 36, 37, 63, - mono and ortho 3049c 64, 65, 66, 67, 68 3050c 3051c R-centered (7 total):146,148,155,160,161,166,167 - trig 3052c 3053c I-centered (38 total): 3054c 23, 24, 44, 45, 46, 71, 72, 73, 74, 79, 80, 82, 87, 88, 97, 98, - ortho,tetra,cubic 3055c 107,108,109,110,119,120,121,122,139,140,141,142,197,199,204,206, 3056c 211,214,217,220,229,230 3057c 3058c F-centered (16 total) 3059c 22, 42, 43, 69, 70,196,202,203,209,210,216,219,225,226,227,228 - ortho,cubic 3060c 3061 logical function geom_convert_to_primitive(geom,ctr_type,tf) 3062 implicit none 3063 integer geom 3064 character*1 ctr_type 3065 real*8 tf(6,3) 3066 3067#include "errquit.fh" 3068#include "nwc_const.fh" 3069#include "geomP.fh" 3070#include "util.fh" 3071#include "inp.fh" 3072#include "stdio.fh" 3073 3074* **** local variables **** 3075 logical value,update_lattice,is_conventional 3076 integer i,ncent 3077 real*8 lat(6),degtorad,radtodeg 3078 real*8 amat(3,3),amat2(3,3),c(3) 3079 3080 integer grp_num,crystal 3081 integer Triclinic,Monoclinic,Orthorhombic 3082 integer Tetragonal,Trigonal,Hexagonal,Cubic 3083 parameter (Triclinic=1,Monoclinic=2,Orthorhombic=3) 3084 parameter (Tetragonal=4,Trigonal=5,Hexagonal=6,Cubic=7) 3085 3086* **** external functions **** 3087 logical geom_lattice_get,geom_lattice_set,geom_is_conventional 3088 external geom_lattice_get,geom_lattice_set,geom_is_conventional 3089 logical geom_amatrix_get,geom_amatrix_set 3090 external geom_amatrix_get,geom_amatrix_set 3091 3092 value = .true. 3093 if ((ctr_type.eq.'F').or. 3094 > (ctr_type.eq.'A').or. 3095 > (ctr_type.eq.'C').or. 3096 > (ctr_type.eq.'R').or. 3097 > (ctr_type.eq.'I')) then 3098 3099 update_lattice = .False. 3100 degtorad = 4.0d0*datan(1.0d0)/180.0d0 3101 radtodeg = 180.0d0/(4.0d0*datan(1.0d0)) 3102 value = geom_amatrix_get(geom,amat) 3103 value = value.and.geom_amatrix_get(geom,amat2) 3104 value = value.and.geom_lattice_get(geom,lat) 3105 lat(4) = lat(4)*radtodeg 3106 lat(5) = lat(5)*radtodeg 3107 lat(6) = lat(6)*radtodeg 3108 3109 is_conventional = geom_is_conventional(geom) 3110 3111c *** F-centered: Int. Tables, Table 5.1, p.77. See also Fig. 5.5, p.77. *** 3112c *** a' = (b+c)/2, b' = (a+c)/2, c' = (a+b)/2 *** 3113 if (ctr_type.eq.'F') then 3114 amat(1,1) = 0.50d0*(amat2(1,2)+amat2(1,3)) 3115 amat(2,1) = 0.50d0*(amat2(2,2)+amat2(2,3)) 3116 amat(3,1) = 0.50d0*(amat2(3,2)+amat2(3,3)) 3117 3118 amat(1,2) = 0.50d0*(amat2(1,1)+amat2(1,3)) 3119 amat(2,2) = 0.50d0*(amat2(2,1)+amat2(2,3)) 3120 amat(3,2) = 0.50d0*(amat2(3,1)+amat2(3,3)) 3121 3122 amat(1,3) = 0.50d0*(amat2(1,1)+amat2(1,2)) 3123 amat(2,3) = 0.50d0*(amat2(2,1)+amat2(2,2)) 3124 amat(3,3) = 0.50d0*(amat2(3,1)+amat2(3,2)) 3125 update_lattice = is_conventional 3126 primitive_center(geom) = ctr_type 3127 3128 end if 3129 3130c *** A-centered: The author's (DGC) *** 3131c *** a'=a, b'=(b+c)/2, c'=(-b+c)/2 *** 3132 if (ctr_type.eq.'A') then 3133 amat(1,2) = 0.50d0*(amat2(1,2)+amat2(1,3)) 3134 amat(2,2) = 0.50d0*(amat2(2,2)+amat2(2,3)) 3135 amat(3,2) = 0.50d0*(amat2(3,2)+amat2(3,3)) 3136 3137 amat(1,3) = 0.50d0*(-amat2(1,2)+amat2(1,3)) 3138 amat(2,3) = 0.50d0*(-amat2(2,2)+amat2(2,3)) 3139 amat(3,3) = 0.50d0*(-amat2(3,2)+amat2(3,3)) 3140 update_lattice = is_conventional 3141 primitive_center(geom) = ctr_type 3142 end if 3143 3144c *** C-centered: Orthohexagonal cell convention (from Int. Tables, Fig. 5.8, p.70, cell #C2) *** 3145c *** a'=(a+b)/2, b'=(-a+b)/2, c'=c *** 3146 if (ctr_type.eq.'C') then 3147 amat(1,1) = 0.50d0*(amat2(1,1)+amat2(1,2)) 3148 amat(2,1) = 0.50d0*(amat2(2,1)+amat2(2,2)) 3149 amat(3,1) = 0.50d0*(amat2(3,1)+amat2(3,2)) 3150 3151 amat(1,2) = 0.50d0*(-amat2(1,1)+amat2(1,2)) 3152 amat(2,2) = 0.50d0*(-amat2(2,1)+amat2(2,2)) 3153 amat(3,2) = 0.50d0*(-amat2(3,1)+amat2(3,2)) 3154 update_lattice = is_conventional 3155 primitive_center(geom) = ctr_type 3156 end if 3157 3158c *** R-centered: Obverse Int. Tables, Table 5.1, p.78 - Cell #1 *** 3159c *** See also Figs. 5.7a & c, p.79) *** 3160c *** a' = 2a/3 + b/3 + c/3 *** 3161c *** b' = -a/3 + b/3 + c/3 *** 3162c *** c' = -a/3 -2b/3 + c/3 *** 3163 if (ctr_type.eq.'R') then 3164 amat(1,1) = (2.0d0*amat2(1,1)+amat2(1,2)+amat2(1,3))/3.0d0 3165 amat(2,1) = (2.0d0*amat2(2,1)+amat2(2,2)+amat2(2,3))/3.0d0 3166 amat(3,1) = (2.0d0*amat2(3,1)+amat2(3,2)+amat2(3,3))/3.0d0 3167 3168 amat(1,2) = (-amat2(1,1)+amat2(1,2)+amat2(1,3))/3.0d0 3169 amat(2,2) = (-amat2(2,1)+amat2(2,2)+amat2(2,3))/3.0d0 3170 amat(3,2) = (-amat2(3,1)+amat2(3,2)+amat2(3,3))/3.0d0 3171 3172 amat(1,3) = (-amat2(1,1)-2.0d0*amat2(1,2)+amat2(1,3))/3.0d0 3173 amat(2,3) = (-amat2(2,1)-2.0d0*amat2(2,2)+amat2(2,3))/3.0d0 3174 amat(3,3) = (-amat2(3,1)-2.0d0*amat2(3,2)+amat2(3,3))/3.0d0 3175 update_lattice = is_conventional 3176 primitive_center(geom) = ctr_type 3177 end if 3178 3179c *** I-centered: Int. Tables, Table 5.1, p.76. See also Fig. 5.4, p.77. *** 3180c *** a' = -a/2 + b/2 + c/2 *** 3181c *** b' = a/2 - b/2 + c/2 *** 3182c *** c' = a/2 + b/2 - c/2 *** 3183 if (ctr_type.eq.'I') then 3184 amat(1,1) = 0.5d0*(-amat2(1,1)+amat2(1,2)+amat2(1,3)) 3185 amat(2,1) = 0.5d0*(-amat2(2,1)+amat2(2,2)+amat2(2,3)) 3186 amat(3,1) = 0.5d0*(-amat2(3,1)+amat2(3,2)+amat2(3,3)) 3187 3188 amat(1,2) = 0.5d0*(amat2(1,1)-amat2(1,2)+amat2(1,3)) 3189 amat(2,2) = 0.5d0*(amat2(2,1)-amat2(2,2)+amat2(2,3)) 3190 amat(3,2) = 0.5d0*(amat2(3,1)-amat2(3,2)+amat2(3,3)) 3191 3192 amat(1,3) = 0.5d0*(amat2(1,1)+amat2(1,2)-amat2(1,3)) 3193 amat(2,3) = 0.5d0*(amat2(2,1)+amat2(2,2)-amat2(2,3)) 3194 amat(3,3) = 0.5d0*(amat2(3,1)+amat2(3,2)-amat2(3,3)) 3195 update_lattice = is_conventional 3196 primitive_center(geom) = ctr_type 3197 end if 3198 3199 if (update_lattice) then 3200c *** convert the fractional coords *** 3201 ncent = ncenter(geom) 3202 do i = 1, ncent 3203 c(1) = coords(1,i,geom) 3204 c(2) = coords(2,i,geom) 3205 c(3) = coords(3,i,geom) 3206 coords(1,i,geom) = tf(1,1)*c(1)+tf(1,2)*c(2)+tf(1,3)*c(3) 3207 coords(2,i,geom) = tf(2,1)*c(1)+tf(2,2)*c(2)+tf(2,3)*c(3) 3208 coords(3,i,geom) = tf(3,1)*c(1)+tf(3,2)*c(2)+tf(3,3)*c(3) 3209 end do 3210 call xlattice_abc_abg(lat(1),lat(2),lat(3), 3211 > lat(4),lat(5),lat(6),amat) 3212 3213 lat(4) = lat(4)*degtorad 3214 lat(5) = lat(5)*degtorad 3215 lat(6) = lat(6)*degtorad 3216 !value = value.and.geom_amatrix_set(geom,amat) 3217 value = value.and.geom_lattice_set(geom,lat) 3218 end if 3219 3220 end if 3221 3222 geom_convert_to_primitive = value 3223 return 3224 end 3225 3226 3227 logical function geom_default_charge_with_ecp(atn, q) 3228 implicit none 3229c 3230 integer atn ! [input] atomic number 3231 double precision q ! [output] charge 3232c 3233c return a default for the effective nuclear charge 3234c if an ecp is placed on a atom with atomic number atn 3235c 3236c This is just a first guess at this routine 3237c 3238 geom_default_charge_with_ecp = .true. 3239 if (atn .le. 2) then 3240 q = atn 3241 else if (atn .le. 10) then 3242 q = atn - 2 3243 else if (atn .le. 18) then 3244 q = atn - 10 3245 else 3246 geom_default_charge_with_ecp = .false. 3247 endif 3248c 3249 end 3250c 3251C> \brief Convert an atom tag to a covalent radius 3252c 3253C> \return Returns .true. when successfull, and .false. otherwise. 3254c 3255 logical function geom_tag_to_covalent_radius(tag,radius) 3256 implicit none 3257#include "inp.fh" 3258c 3259c Try to decode a tag and return the covalent radius (a.u.) for 3260c the corresponding atom. 3261c 3262 character*16 tag !< [Input] the atom tag 3263 double precision radius !< [Output] the atom covalent radius 3264c 3265 character*2 symbol 3266 character*16 element, ttag 3267 integer atn 3268 logical geom_get_def_rcov, geom_tag_to_element 3269 external geom_get_def_rcov, geom_tag_to_element 3270c 3271 geom_tag_to_covalent_radius = .false. 3272c 3273 if (.not. geom_tag_to_element(tag, symbol, element, atn)) then 3274c 3275c Is not an atom. Try removing Bq or X. 3276c 3277 if (inp_compare(.false., tag(1:1), 'x')) then 3278 ttag = tag(2:) 3279 else if (inp_compare(.false., tag(1:2), 'bq')) then 3280 ttag = tag(3:) 3281 else 3282 return ! Nothing recognizable 3283 endif 3284 if (.not. geom_tag_to_element(ttag, symbol, element, atn)) then 3285c 3286c We found a "Bq" or "X" but it is not labeled with an element 3287c (e.g. "XH" or "BqN") so we cannot associate any atomic 3288c properties. 3289c 3290 geom_tag_to_covalent_radius = .false. 3291 return 3292 else 3293c 3294c We found a "Bq" or "X" with an atomic type indication and 3295c we now have the atomic number indicated, so we will go 3296c with that. 3297c 3298 endif 3299 else 3300c 3301c We found an atom and now know its atomic number 3302c 3303 endif 3304c 3305c atn should be set to something sensible 3306c 3307 geom_tag_to_covalent_radius = geom_get_def_rcov(atn, radius) 3308c 3309 end 3310c 3311C> \brief Converts an atom tag into a chemical element 3312c 3313C> Tags are names used to identify atoms in geometries. These tags allow 3314C> for considerable flexibility to specify centers, e.g. valid tags for 3315C> a Carbon atom are: Carbon, C, C14, C_alpha. However, in a chemistry 3316C> code at some point we just need to know that we are dealing with a 3317C> Carbon atom. This routine analyses a given tag and returns the 3318C> element it specifies. 3319c 3320C> \return Returns .true. if the chemical element could be established, 3321C> and .false. otherwise. 3322c 3323 logical function geom_tag_to_element(tag, symbol, element, atn) 3324 implicit none 3325#include "inp.fh" 3326#include "nwc_const.fh" 3327#include "geomP.fh" 3328 character*2 symbols(nelements) 3329 character*16 elements(nelements) 3330 character*16 tag !< [Input] the tag, e.g. He232 3331 character*(*) symbol !< [Output] the chemical symbol, e.g. He 3332 character*(*) element !< [Output] the element, e.g. Helium 3333 integer atn !< [Output] the nuclear charge, e.g. 2 3334c 3335c attempt to figure out which element a tag refers to 3336c and return the symbol, name and atomic no. 3337c 3338 integer lbuf, ind 3339 character*16 buf 3340 character*1 sym1(14) ! 1 character atomic symbols+atomic no.s 3341 integer atn1(14) 3342 data symbols/ 3343 $ 'H ', 'He', 'Li', 'Be', 'B ', 'C ', 'N ', 'O ', 'F ', 'Ne', 3344 $ 'Na', 'Mg', 'Al', 'Si', 'P ', 'S ', 'Cl', 'Ar', 'K ', 'Ca', 3345 $ 'Sc', 'Ti', 'V ', 'Cr', 'Mn', 'Fe', 'Co', 'Ni', 'Cu', 'Zn', 3346 $ 'Ga', 'Ge', 'As', 'Se', 'Br', 'Kr', 'Rb', 'Sr', 'Y ', 'Zr', 3347 $ 'Nb', 'Mo', 'Tc', 'Ru', 'Rh', 'Pd', 'Ag', 'Cd', 'In', 'Sn', 3348 $ 'Sb', 'Te', 'I ', 'Xe', 'Cs', 'Ba', 'La', 'Ce', 'Pr', 'Nd', 3349 $ 'Pm', 'Sm', 'Eu', 'Gd', 'Tb', 'Dy', 'Ho', 'Er', 'Tm', 'Yb', 3350 $ 'Lu', 'Hf', 'Ta', 'W ', 'Re', 'Os', 'Ir', 'Pt', 'Au', 'Hg', 3351 $ 'Tl', 'Pb', 'Bi', 'Po', 'At', 'Rn', 'Fr', 'Ra', 'Ac', 'Th', 3352 $ 'Pa', 'U ', 'Np', 'Pu', 'Am', 'Cm', 'Bk', 'Cf', 'Es', 'Fm', 3353 $ 'Md', 'No', 'Lr', 'Rf', 'Db', 'Sg', 'Bh', 'Hs', 'Mt', 'Ds', 3354 $ 'Rg', 'Cn'/ 3355 data elements/ 3356 $ 'Hydrogen', 'Helium', 'Lithium', 'Beryllium', 'Boron', 3357 $ 'Carbon', 'Nitrogen', 'Oxygen', 'Fluorine', 'Neon', 'Sodium', 3358 $ 'Magnesium', 'Aluminium', 'Silicon', 'Phosphorous', 3359 $ 'Sulphur', 'Chlorine', 'Argon', 'Potassium', 'Calcium', 3360 $ 'Scandium', 'Titanium', 'Vanadium', 'Chromium', 'Manganese', 3361 $ 'Iron', 'Cobalt', 'Nickel', 'Copper', 'Zinc', 'Gallium', 3362 $ 'Germanium', 'Arsenic', 'Selenium', 'Bromine', 'Krypton', 3363 $ 'Rubidium', 'Strontium', 'Yttrium', 'Zirconium', 'Niobium', 3364 $ 'Molybdenum', 'Technetium', 'Ruthenium', 'Rhodium', 3365 $ 'Palladium', 'Silver', 'Cadmium', 'Indium', 'Tin', 3366 $ 'Antinomy', 'Tellurium', 'Iodine', 'Xenon', 'Caesium', 3367 $ 'Barium', 'Lanthanum', 'Cerium', 'Praseodymium', 'Neodymium', 3368 $ 'Promethium', 'Samarium', 'Europium', 'Gadolinium', 3369 $ 'Terbium', 'Dysprosium', 'Holmium', 'Erbium', 'Thulium', 3370 $ 'Ytterbium', 'Lutetium', 'Hafnium', 'Tantalum', 'Tungsten', 3371 $ 'Rhenium', 'Osmium', 'Iridium', 'Platinum', 'Gold', 3372 $ 'Mercury', 'Thallium', 'Lead', 'Bismuth', 'Polonium', 3373 $ 'Astatine', 'Radon', 'Francium', 'Radium', 'Actinium', 3374 $ 'Thorium', 'Protoactinium', 'Uranium', 'Neptunium', 3375 $ 'Plutonium', 'Americium', 'Curium', 'Berkelium', 3376 $ 'Californium', 'Einsteinium', 'Fermium', 'Mendelevium', 3377 $ 'Nobelium', 'Lawrencium','Rutherfordium','Dubnium', 3378 $ 'Seaborgium','Bohrium','Hassium','Meitnerium', 3379 $ 'Darmstadtium', 'Roentgenium', 'Copernicium'/ 3380 data sym1/'H','B','C','N','O','F','P','S','K','V','Y','I','W','U'/ 3381 data atn1/ 1 , 5 , 6 , 7 , 8 , 9 , 15, 16, 19, 23, 39, 53, 74, 92/ 3382 3383 geom_tag_to_element = .false. 3384c 3385c eliminate conventions that refer to centers used for 3386c computation purposes .. just bq and x for now 3387c 3388 buf = tag 3389 lbuf = inp_strlen(buf) 3390 if (lbuf .eq. 0) return 3391c 3392 call inp_lcase(buf) 3393 if (buf(1:2) .eq. 'bq' .or. 3394 $ ((buf(1:1).eq.'x') .and. (buf(2:2).ne.'e'))) then ! X but not Xe 3395 element = 'point charge' ! Note that false is returned 3396 symbol = 'bq' 3397 atn = 0 3398 return 3399 end if 3400c 3401c Attempt to match the first 4 characters of the 3402c full names of the elements 3403c 3404 atn = 0 3405 if (lbuf .ge. 4) then 3406 do ind = 1,nelements 3407 if (inp_compare(.false.,buf(1:4),elements(ind)(1:4))) then 3408 symbol = symbols(ind) 3409 element = elements(ind) 3410 atn = ind 3411 geom_tag_to_element = .true. 3412 return 3413 endif 3414 enddo 3415 end if 3416c 3417c Failed ... attempt to match the first two characters 3418c against two character element names 3419c 3420 if (buf(2:2) .ne. ' ') then 3421 if (inp_match(nelements,.false.,buf(1:2),symbols,ind)) then 3422 symbol = symbols(ind) 3423 element = elements(ind) 3424 atn = ind 3425 geom_tag_to_element = .true. 3426 return 3427 end if 3428 end if 3429c 3430c Last ditch attempt ... match against 1 character symbols 3431c 3432 if (inp_match(14, .false., buf(1:1), sym1, ind)) then 3433 ind = atn1(ind) 3434 symbol = symbols(ind) 3435 element = elements(ind) 3436 atn = ind 3437 geom_tag_to_element = .true. 3438 return 3439 end if 3440c 3441 if (inp_match(14, .false., buf(2:2), sym1, ind)) then 3442 ind = atn1(ind) 3443 symbol = symbols(ind) 3444 element = elements(ind) 3445 atn = ind 3446 geom_tag_to_element = .true. 3447 return 3448 end if 3449cc 3450c Nothing matched 3451c 3452 symbol = ' ' 3453 element = ' ' 3454 atn = 0 3455 return 3456c 3457 end 3458 function geom_tag_to_charge_gen(nt,ns,tag,q) 3459 implicit none 3460#include "inp.fh" 3461#include "nwc_const.fh" 3462#include "geomP.fh" 3463 logical geom_tag_to_charge_gen 3464 integer nt 3465 integer ns 3466 integer i 3467 logical match 3468 character*2 symbols(nelements) 3469 character*16 elements(nelements) 3470 character*1 tag(nt*ns) ! [input] 3471 double precision q(nt) ! [output] 3472c 3473c attempt to figure out which element a tag refers to 3474c and return the symbol, name and atomic no. 3475c 3476 integer j,offset 3477 integer lbuf, ind 3478 character*16 buf 3479 character*1 sym1(14) ! 1 character atomic symbols+atomic no.s 3480 integer atn1(14) 3481 data symbols/ 3482 $ 'H ', 'He', 'Li', 'Be', 'B ', 'C ', 'N ', 'O ', 'F ', 'Ne', 3483 $ 'Na', 'Mg', 'Al', 'Si', 'P ', 'S ', 'Cl', 'Ar', 'K ', 'Ca', 3484 $ 'Sc', 'Ti', 'V ', 'Cr', 'Mn', 'Fe', 'Co', 'Ni', 'Cu', 'Zn', 3485 $ 'Ga', 'Ge', 'As', 'Se', 'Br', 'Kr', 'Rb', 'Sr', 'Y ', 'Zr', 3486 $ 'Nb', 'Mo', 'Tc', 'Ru', 'Rh', 'Pd', 'Ag', 'Cd', 'In', 'Sn', 3487 $ 'Sb', 'Te', 'I ', 'Xe', 'Cs', 'Ba', 'La', 'Ce', 'Pr', 'Nd', 3488 $ 'Pm', 'Sm', 'Eu', 'Gd', 'Tb', 'Dy', 'Ho', 'Er', 'Tm', 'Yb', 3489 $ 'Lu', 'Hf', 'Ta', 'W ', 'Re', 'Os', 'Ir', 'Pt', 'Au', 'Hg', 3490 $ 'Tl', 'Pb', 'Bi', 'Po', 'At', 'Rn', 'Fr', 'Ra', 'Ac', 'Th', 3491 $ 'Pa', 'U ', 'Np', 'Pu', 'Am', 'Cm', 'Bk', 'Cf', 'Es', 'Fm', 3492 $ 'Md', 'No', 'Lr', 'Rf', 'Db', 'Sg', 'Bh', 'Hs', 'Mt', 'Ds', 3493 $ 'Rg', 'Cn'/ 3494 data elements/ 3495 $ 'Hydrogen', 'Helium', 'Lithium', 'Beryllium', 'Boron', 3496 $ 'Carbon', 'Nitrogen', 'Oxygen', 'Fluorine', 'Neon', 'Sodium', 3497 $ 'Magnesium', 'Aluminium', 'Silicon', 'Phosphorous', 3498 $ 'Sulphur', 'Chlorine', 'Argon', 'Potassium', 'Calcium', 3499 $ 'Scandium', 'Titanium', 'Vanadium', 'Chromium', 'Manganese', 3500 $ 'Iron', 'Cobalt', 'Nickel', 'Copper', 'Zinc', 'Gallium', 3501 $ 'Germanium', 'Arsenic', 'Selenium', 'Bromine', 'Krypton', 3502 $ 'Rubidium', 'Strontium', 'Yttrium', 'Zirconium', 'Niobium', 3503 $ 'Molybdenum', 'Technetium', 'Ruthenium', 'Rhodium', 3504 $ 'Palladium', 'Silver', 'Cadmium', 'Indium', 'Tin', 3505 $ 'Antinomy', 'Tellurium', 'Iodine', 'Xenon', 'Caesium', 3506 $ 'Barium', 'Lanthanum', 'Cerium', 'Praseodymium', 'Neodymium', 3507 $ 'Promethium', 'Samarium', 'Europium', 'Gadolinium', 3508 $ 'Terbium', 'Dysprosium', 'Holmium', 'Erbium', 'Thulium', 3509 $ 'Ytterbium', 'Lutetium', 'Hafnium', 'Tantalum', 'Tungsten', 3510 $ 'Rhenium', 'Osmium', 'Iridium', 'Platinum', 'Gold', 3511 $ 'Mercury', 'Thallium', 'Lead', 'Bismuth', 'Polonium', 3512 $ 'Astatine', 'Radon', 'Francium', 'Radium', 'Actinium', 3513 $ 'Thorium', 'Protoactinium', 'Uranium', 'Neptunium', 3514 $ 'Plutonium', 'Americium', 'Curium', 'Berkelium', 3515 $ 'Californium', 'Einsteinium', 'Fermium', 'Mendelevium', 3516 $ 'Nobelium', 'Lawrencium','Rutherfordium','Dubnium', 3517 $ 'Seaborgium','Bohrium','Hassium','Meitnerium', 3518 $ 'Darmstadtium', 'Roentgenium', 'Copernicium'/ 3519 data sym1/'H','B','C','N','O','F','P','S','K','V','Y','I','W','U'/ 3520 data atn1/ 1 , 5 , 6 , 7 , 8 , 9 , 15, 16, 19, 23, 39, 53, 74, 92/ 3521 3522 geom_tag_to_charge_gen = .false. 3523c 3524c eliminate conventions that refer to centers used for 3525c computation purposes .. just bq and x for now 3526c 3527 match = .false. 3528 do i=1,nt 3529 match = .false. 3530 offset = (i-1)*ns 3531 buf = " " 3532 do j=1,16 3533 buf(j:j) = tag(j+offset) 3534 end do 3535 lbuf = inp_strlen(buf) 3536 if (lbuf .eq. 0) goto 100 3537c 3538 call inp_lcase(buf) 3539 if (buf(1:2) .eq. 'bq' .or. 3540 $ ((buf(1:1).eq.'x') .and. (buf(2:2).ne.'e'))) then ! X but not Xe 3541 q(i) = 0.0 3542 match = .true. 3543 goto 100 3544 end if 3545c 3546c Attempt to match the first 4 characters of the 3547c full names of the elements 3548c 3549 q(i) = 0.0 3550 if (lbuf .ge. 4) then 3551 do ind = 1,nelements 3552 if (inp_compare(.false.,buf(1:4),elements(ind)(1:4))) then 3553 q(i) = dble(ind) 3554 match = .true. 3555 goto 100 3556 endif 3557 enddo 3558 end if 3559c 3560c Failed ... attempt to match the first two characters 3561c against two character element names 3562c 3563 if (buf(2:2) .ne. ' ') then 3564 if (inp_match(nelements,.false.,buf(1:2),symbols,ind)) then 3565 q(i) = dble(ind) 3566 match = .true. 3567 goto 100 3568 end if 3569 end if 3570c 3571c not Last ditch attempt ... match against 1 character symbols 3572c 3573 if (inp_match(14, .false., buf(1:1), sym1, ind)) then 3574 ind = atn1(ind) 3575 q(i) = dble(ind) 3576 match = .true. 3577 goto 100 3578 end if 3579 if (inp_match(14, .false., buf(2:2), sym1, ind)) then 3580 ind = atn1(ind) 3581 q(i) = dble(ind) 3582 match = .true. 3583 goto 100 3584 end if 3585100 continue 3586 if(.not.match) then 3587 write(*,*) "buffer",buf 3588 goto 101 3589 end if 3590 end do 3591101 continue 3592 3593 geom_tag_to_charge_gen = match 3594 3595 return 3596c 3597 end 3598 function geom_tag_to_charge(nt,tag,q) 3599 implicit none 3600#include "inp.fh" 3601#include "nwc_const.fh" 3602#include "geomP.fh" 3603 logical geom_tag_to_charge 3604 integer nt 3605 integer i 3606 logical match 3607 character*2 symbols(nelements) 3608 character*16 elements(nelements) 3609 character*16 tag(nt) ! [input] 3610 double precision q(nt) ! [output] 3611c 3612c attempt to figure out which element a tag refers to 3613c and return the symbol, name and atomic no. 3614c 3615 integer lbuf, ind 3616 character*16 buf 3617 character*1 sym1(14) ! 1 character atomic symbols+atomic no.s 3618 integer atn1(14) 3619 data symbols/ 3620 $ 'H ', 'He', 'Li', 'Be', 'B ', 'C ', 'N ', 'O ', 'F ', 'Ne', 3621 $ 'Na', 'Mg', 'Al', 'Si', 'P ', 'S ', 'Cl', 'Ar', 'K ', 'Ca', 3622 $ 'Sc', 'Ti', 'V ', 'Cr', 'Mn', 'Fe', 'Co', 'Ni', 'Cu', 'Zn', 3623 $ 'Ga', 'Ge', 'As', 'Se', 'Br', 'Kr', 'Rb', 'Sr', 'Y ', 'Zr', 3624 $ 'Nb', 'Mo', 'Tc', 'Ru', 'Rh', 'Pd', 'Ag', 'Cd', 'In', 'Sn', 3625 $ 'Sb', 'Te', 'I ', 'Xe', 'Cs', 'Ba', 'La', 'Ce', 'Pr', 'Nd', 3626 $ 'Pm', 'Sm', 'Eu', 'Gd', 'Tb', 'Dy', 'Ho', 'Er', 'Tm', 'Yb', 3627 $ 'Lu', 'Hf', 'Ta', 'W ', 'Re', 'Os', 'Ir', 'Pt', 'Au', 'Hg', 3628 $ 'Tl', 'Pb', 'Bi', 'Po', 'At', 'Rn', 'Fr', 'Ra', 'Ac', 'Th', 3629 $ 'Pa', 'U ', 'Np', 'Pu', 'Am', 'Cm', 'Bk', 'Cf', 'Es', 'Fm', 3630 $ 'Md', 'No', 'Lr', 'Rf', 'Db', 'Sg', 'Bh', 'Hs', 'Mt', 'Ds', 3631 $ 'Rg', 'Cn'/ 3632 data elements/ 3633 $ 'Hydrogen', 'Helium', 'Lithium', 'Beryllium', 'Boron', 3634 $ 'Carbon', 'Nitrogen', 'Oxygen', 'Fluorine', 'Neon', 'Sodium', 3635 $ 'Magnesium', 'Aluminium', 'Silicon', 'Phosphorous', 3636 $ 'Sulphur', 'Chlorine', 'Argon', 'Potassium', 'Calcium', 3637 $ 'Scandium', 'Titanium', 'Vanadium', 'Chromium', 'Manganese', 3638 $ 'Iron', 'Cobalt', 'Nickel', 'Copper', 'Zinc', 'Gallium', 3639 $ 'Germanium', 'Arsenic', 'Selenium', 'Bromine', 'Krypton', 3640 $ 'Rubidium', 'Strontium', 'Yttrium', 'Zirconium', 'Niobium', 3641 $ 'Molybdenum', 'Technetium', 'Ruthenium', 'Rhodium', 3642 $ 'Palladium', 'Silver', 'Cadmium', 'Indium', 'Tin', 3643 $ 'Antinomy', 'Tellurium', 'Iodine', 'Xenon', 'Caesium', 3644 $ 'Barium', 'Lanthanum', 'Cerium', 'Praseodymium', 'Neodymium', 3645 $ 'Promethium', 'Samarium', 'Europium', 'Gadolinium', 3646 $ 'Terbium', 'Dysprosium', 'Holmium', 'Erbium', 'Thulium', 3647 $ 'Ytterbium', 'Lutetium', 'Hafnium', 'Tantalum', 'Tungsten', 3648 $ 'Rhenium', 'Osmium', 'Iridium', 'Platinum', 'Gold', 3649 $ 'Mercury', 'Thallium', 'Lead', 'Bismuth', 'Polonium', 3650 $ 'Astatine', 'Radon', 'Francium', 'Radium', 'Actinium', 3651 $ 'Thorium', 'Protoactinium', 'Uranium', 'Neptunium', 3652 $ 'Plutonium', 'Americium', 'Curium', 'Berkelium', 3653 $ 'Californium', 'Einsteinium', 'Fermium', 'Mendelevium', 3654 $ 'Nobelium', 'Lawrencium','Rutherfordium','Dubnium', 3655 $ 'Seaborgium','Bohrium','Hassium','Meitnerium', 3656 $ 'Darmstadtium', 'Roentgenium', 'Copernicium'/ 3657 data sym1/'H','B','C','N','O','F','P','S','K','V','Y','I','W','U'/ 3658 data atn1/ 1 , 5 , 6 , 7 , 8 , 9 , 15, 16, 19, 23, 39, 53, 74, 92/ 3659 3660 geom_tag_to_charge = .false. 3661c 3662c eliminate conventions that refer to centers used for 3663c computation purposes .. just bq and x for now 3664c 3665 match = .false. 3666 do i=1,nt 3667 match = .false. 3668 buf = tag(i) 3669 lbuf = inp_strlen(buf) 3670 if (lbuf .eq. 0) goto 100 3671c 3672 call inp_lcase(buf) 3673 if (buf(1:2) .eq. 'bq' .or. 3674 $ ((buf(1:1).eq.'x') .and. (buf(2:2).ne.'e'))) then ! X but not Xe 3675 q(i) = 0.0 3676 match = .true. 3677 goto 100 3678 end if 3679c 3680c Attempt to match the first 4 characters of the 3681c full names of the elements 3682c 3683 q(i) = 0.0 3684 if (lbuf .ge. 4) then 3685 do ind = 1,nelements 3686 if (inp_compare(.false.,buf(1:4),elements(ind)(1:4))) then 3687 q(i) = dble(ind) 3688 match = .true. 3689 goto 100 3690 endif 3691 enddo 3692 end if 3693c 3694c Failed ... attempt to match the first two characters 3695c against two character element names 3696c 3697 if (buf(2:2) .ne. ' ') then 3698 if (inp_match(nelements,.false.,buf(1:2),symbols,ind)) then 3699 q(i) = dble(ind) 3700 match = .true. 3701 goto 100 3702 end if 3703 end if 3704c 3705c Last ditch attempt ... match against 1 character symbols 3706c 3707 if (inp_match(14, .false., buf(1:1), sym1, ind)) then 3708 ind = atn1(ind) 3709 q(i) = dble(ind) 3710 match = .true. 3711 goto 100 3712 end if 3713100 continue 3714 if(.not.match) goto 101 3715 end do 3716101 continue 3717 3718 geom_tag_to_charge = match 3719 3720 return 3721c 3722 end 3723 function geom_tag_to_atn(nt,tag,atn) 3724 implicit none 3725#include "inp.fh" 3726#include "nwc_const.fh" 3727#include "geomP.fh" 3728 logical geom_tag_to_atn 3729 integer nt 3730 integer i 3731 logical match 3732 character*2 symbols(nelements) 3733 character*16 elements(nelements) 3734c TP: changed from character*(*) tag(nt) to character*(16) tag(nt) 3735 character*(16) tag(nt) ! [input] 3736 integer atn(nt) ! [output] 3737c 3738c attempt to figure out which element a tag refers to 3739c and return the symbol, name and atomic no. 3740c 3741 integer lbuf, ind 3742 character*16 buf 3743 character*1 sym1(14) ! 1 character atomic symbols+atomic no.s 3744 integer atn1(14) 3745 data symbols/ 3746 $ 'H ', 'He', 'Li', 'Be', 'B ', 'C ', 'N ', 'O ', 'F ', 'Ne', 3747 $ 'Na', 'Mg', 'Al', 'Si', 'P ', 'S ', 'Cl', 'Ar', 'K ', 'Ca', 3748 $ 'Sc', 'Ti', 'V ', 'Cr', 'Mn', 'Fe', 'Co', 'Ni', 'Cu', 'Zn', 3749 $ 'Ga', 'Ge', 'As', 'Se', 'Br', 'Kr', 'Rb', 'Sr', 'Y ', 'Zr', 3750 $ 'Nb', 'Mo', 'Tc', 'Ru', 'Rh', 'Pd', 'Ag', 'Cd', 'In', 'Sn', 3751 $ 'Sb', 'Te', 'I ', 'Xe', 'Cs', 'Ba', 'La', 'Ce', 'Pr', 'Nd', 3752 $ 'Pm', 'Sm', 'Eu', 'Gd', 'Tb', 'Dy', 'Ho', 'Er', 'Tm', 'Yb', 3753 $ 'Lu', 'Hf', 'Ta', 'W ', 'Re', 'Os', 'Ir', 'Pt', 'Au', 'Hg', 3754 $ 'Tl', 'Pb', 'Bi', 'Po', 'At', 'Rn', 'Fr', 'Ra', 'Ac', 'Th', 3755 $ 'Pa', 'U ', 'Np', 'Pu', 'Am', 'Cm', 'Bk', 'Cf', 'Es', 'Fm', 3756 $ 'Md', 'No', 'Lr', 'Rf', 'Db', 'Sg', 'Bh', 'Hs', 'Mt', 'Ds', 3757 $ 'Rg', 'Cn'/ 3758 data elements/ 3759 $ 'Hydrogen', 'Helium', 'Lithium', 'Beryllium', 'Boron', 3760 $ 'Carbon', 'Nitrogen', 'Oxygen', 'Fluorine', 'Neon', 'Sodium', 3761 $ 'Magnesium', 'Aluminium', 'Silicon', 'Phosphorous', 3762 $ 'Sulphur', 'Chlorine', 'Argon', 'Potassium', 'Calcium', 3763 $ 'Scandium', 'Titanium', 'Vanadium', 'Chromium', 'Manganese', 3764 $ 'Iron', 'Cobalt', 'Nickel', 'Copper', 'Zinc', 'Gallium', 3765 $ 'Germanium', 'Arsenic', 'Selenium', 'Bromine', 'Krypton', 3766 $ 'Rubidium', 'Strontium', 'Yttrium', 'Zirconium', 'Niobium', 3767 $ 'Molybdenum', 'Technetium', 'Ruthenium', 'Rhodium', 3768 $ 'Palladium', 'Silver', 'Cadmium', 'Indium', 'Tin', 3769 $ 'Antinomy', 'Tellurium', 'Iodine', 'Xenon', 'Caesium', 3770 $ 'Barium', 'Lanthanum', 'Cerium', 'Praseodymium', 'Neodymium', 3771 $ 'Promethium', 'Samarium', 'Europium', 'Gadolinium', 3772 $ 'Terbium', 'Dysprosium', 'Holmium', 'Erbium', 'Thulium', 3773 $ 'Ytterbium', 'Lutetium', 'Hafnium', 'Tantalum', 'Tungsten', 3774 $ 'Rhenium', 'Osmium', 'Iridium', 'Platinum', 'Gold', 3775 $ 'Mercury', 'Thallium', 'Lead', 'Bismuth', 'Polonium', 3776 $ 'Astatine', 'Radon', 'Francium', 'Radium', 'Actinium', 3777 $ 'Thorium', 'Protoactinium', 'Uranium', 'Neptunium', 3778 $ 'Plutonium', 'Americium', 'Curium', 'Berkelium', 3779 $ 'Californium', 'Einsteinium', 'Fermium', 'Mendelevium', 3780 $ 'Nobelium', 'Lawrencium','Rutherfordium','Dubnium', 3781 $ 'Seaborgium','Bohrium','Hassium','Meitnerium', 3782 $ 'Darmstadtium', 'Roentgenium', 'Copernicium'/ 3783 data sym1/'H','B','C','N','O','F','P','S','K','V','Y','I','W','U'/ 3784 data atn1/ 1 , 5 , 6 , 7 , 8 , 9 , 15, 16, 19, 23, 39, 53, 74, 92/ 3785 3786 geom_tag_to_atn = .false. 3787c 3788c eliminate conventions that refer to centers used for 3789c computation purposes .. just bq and x for now 3790c 3791 match = .false. 3792 do i=1,nt 3793 match = .false. 3794c TP: changed from buf = tag(nt) to buf = tag(i) 3795 buf = tag(i) 3796 lbuf = inp_strlen(buf) 3797 if (lbuf .eq. 0) goto 100 3798c 3799 call inp_lcase(buf) 3800 if (buf(1:2) .eq. 'bq' .or. 3801 $ ((buf(1:1).eq.'x') .and. (buf(2:2).ne.'e'))) then ! X but not Xe 3802 atn(i) = 0 3803 match = .true. 3804 goto 100 3805 end if 3806c 3807c Attempt to match the first 4 characters of the 3808c full names of the elements 3809c 3810 atn(i) = 0 3811 if (lbuf .ge. 4) then 3812 do ind = 1,nelements 3813 if (inp_compare(.false.,buf(1:4),elements(ind)(1:4))) then 3814 atn(i) = ind 3815 match = .true. 3816 goto 100 3817 endif 3818 enddo 3819 end if 3820c 3821c Failed ... attempt to match the first two characters 3822c against two character element names 3823c 3824 if (buf(2:2) .ne. ' ') then 3825 if (inp_match(nelements,.false.,buf(1:2),symbols,ind)) then 3826 atn(i) = ind 3827 match = .true. 3828 goto 100 3829 end if 3830 end if 3831c 3832c Last ditch attempt ... match against 1 character symbols 3833c 3834 if (inp_match(14, .false., buf(1:1), sym1, ind)) then 3835 ind = atn1(ind) 3836 atn(i) = ind 3837 match = .true. 3838 goto 100 3839 end if 3840100 continue 3841 if(.not.match) goto 101 3842 end do 3843101 continue 3844 3845 geom_tag_to_atn = match 3846 3847 return 3848c 3849 end 3850c 3851 logical function geom_charge_center(geom) 3852 implicit none 3853#include "nwc_const.fh" 3854#include "geomP.fh" 3855 integer geom ! [input] 3856 integer i, k 3857 double precision qsum, shift(3) 3858 logical geom_check_handle 3859 external geom_check_handle 3860c 3861c Adjust the cartesian coordinates so that the nuclear 3862c dipole moment is zero ... i.e., the origin of the 3863c coordinate system is at the center of charge 3864c 3865 geom_charge_center = geom_check_handle(geom,'geom_charge_center') 3866 if (.not. geom_charge_center) return 3867 call geom_compute_values(geom) 3868 qsum = 0.0d0 3869 do i = 1, ncenter(geom) 3870 qsum = qsum + charge(i,geom) 3871 end do 3872c 3873 if (qsum .eq. 0.0d0) return ! System is charge neutral 3874c 3875 do k = 1, 3 3876 shift(k) = ndipole(k,geom)/qsum 3877 end do 3878 do i = 1, ncenter(geom) 3879 do k = 1, 3 3880 coords(k,i,geom) = coords(k,i,geom) - shift(k) 3881 end do 3882 end do 3883c 3884 call geom_compute_values(geom) 3885c 3886 end 3887c 3888C> \brief Extracts the center of charge from a geometry instance 3889c 3890C> \return Returns .true. if the center of charge was successfully 3891C> established, and .false. otherwise. 3892c 3893 logical function geom_center_of_charge(geom, center) 3894 implicit none 3895#include "nwc_const.fh" 3896#include "geomP.fh" 3897 integer geom !< [Input] the geometry handle 3898 double precision center(3) !< [Output] the center of charge 3899 integer i, k 3900 double precision qsum 3901 logical geom_check_handle 3902 external geom_check_handle 3903c 3904c Get the center of charge of the geometry 3905c DOES not shift the center of charge to the origin 3906c 3907 geom_center_of_charge=geom_check_handle(geom,'geom_charge_center') 3908 if (.not. geom_center_of_charge) return 3909 call geom_compute_values(geom) 3910 qsum = 0.0d0 3911 do i = 1, ncenter(geom) 3912 qsum = qsum + charge(i,geom) 3913 end do 3914c 3915 if (qsum .eq. 0.0d0) then ! System is charge neutral 3916 do k = 1, 3 3917 center(k) = 0.0d0 3918 enddo 3919 else 3920 do k = 1, 3 3921 center(k) = ndipole(k,geom)/qsum 3922 end do 3923 endif 3924c 3925 geom_center_of_charge=.true. 3926 end 3927c 3928C> \brief Extracts the center of mass from a geometry instance 3929c 3930C> \return Returns .true. if the center of mass was successfully 3931C> established, and .false. otherwise. 3932c 3933 logical function geom_center_of_mass(geom, center) 3934 implicit none 3935#include "errquit.fh" 3936#include "nwc_const.fh" 3937#include "geomP.fh" 3938 integer geom !< [Input] the geometry handle 3939 double precision center(3) !< [Output] the center of mass 3940 logical geom_ncent, geom_mass_get 3941 external geom_ncent, geom_mass_get 3942c 3943 integer i, iat, ncent 3944 double precision mass, amass 3945c 3946c Get the center of mass of the geometry 3947c DOES not shift the center of mass to the origin 3948c 3949 if (.not. geom_ncent(geom, ncent)) 3950 & call errquit('geom_mass_center: unable to get ncent',555, 3951 & GEOM_ERR) 3952 do i = 1,3 3953 center(i) = 0.0d0 3954 enddo 3955 amass = 0.0d0 3956 do iat = 1, ncent 3957 if(.not.geom_mass_get(geom, iat, mass)) call 3958 & errquit(' mass_get failed ',iat, GEOM_ERR) 3959 amass = amass + mass 3960 do i=1,3 3961 center(i) = center(i) + mass*coords(i,iat,geom) 3962 enddo 3963 enddo 3964 do i = 1, 3 3965 center(i) = center(i)/amass 3966 enddo 3967c 3968 geom_center_of_mass=.true. 3969 return 3970 end 3971 3972C> \brief Extracts the centroid from a geometry instance 3973c 3974C> \return Returns .true. if the centroid was successfully 3975C> established, and .false. otherwise. 3976c 3977 logical function geom_centroid(geom, centroid) 3978 implicit none 3979#include "errquit.fh" 3980#include "nwc_const.fh" 3981#include "geomP.fh" 3982 integer geom !< [Input] the geometry handle 3983 double precision centroid(3) !< [Output] the centroid 3984 logical geom_ncent 3985 external geom_ncent 3986c 3987 integer i, iat, ncent 3988c 3989 if (.not. geom_ncent(geom, ncent)) 3990 & call errquit('geom_centroid: unable to get ncent',555, 3991 & GEOM_ERR) 3992c 3993 call dfill(3, 0.0d0, centroid, 1) 3994 do iat = 1, ncent 3995 do i=1,3 3996 centroid(i) = centroid(i) + coords(i,iat,geom)/ncent 3997 enddo 3998 enddo 3999c 4000 geom_centroid=.true. 4001 return 4002 end 4003c 4004C> \brief Extracts the nuclear repulsion energy from a geometry instance 4005c 4006C> \return Return .true. if successfull, and .false. otherwise. 4007c 4008 logical function geom_nuc_rep_energy(geom, energy) 4009#include "nwc_const.fh" 4010#include "geomP.fh" 4011#include "errquit.fh" 4012 integer geom !< [Input] the geometry handle 4013 double precision energy !< [Output] the nuclear repulsion energy 4014 logical bq_add_nuc_rep_energy 4015 external bq_add_nuc_rep_energy 4016 logical geom_check_handle 4017 external geom_check_handle 4018 logical geom_extbq_on 4019 external geom_extbq_on 4020c 4021c return the effective nuclear repulsion energy etc. 4022c 4023 geom_nuc_rep_energy = geom_check_handle(geom, 'geom_nuc_rep_e') 4024 if (.not. geom_nuc_rep_energy) return 4025 energy = erep(geom) 4026c 4027 if(geom_extbq_on()) then 4028 if(.not. bq_add_nuc_rep_energy(geom,energy)) 4029 > call errquit("failed bq_add_nuc_rep_energy",0,GEOM_ERR) 4030 end if 4031c 4032 end 4033c 4034C> \brief Extracts the total nuclear charge of a geometry instance 4035c 4036C> \return Return .true. if successfull, and .false. otherwise. 4037c 4038 logical function geom_nuc_charge(geom, total_charge) 4039 implicit none 4040#include "nwc_const.fh" 4041#include "geomP.fh" 4042 integer geom !< [Input] the geometry handle 4043 double precision total_charge !< [Output] the accumulated nuclear charge 4044 logical geom_check_handle 4045 external geom_check_handle 4046 integer i 4047c 4048c return the sum of the nuclear charges 4049c 4050 geom_nuc_charge = geom_check_handle(geom, 'geom_nuc_charge') 4051 if (.not. geom_nuc_charge) return 4052c 4053 total_charge = 0.0d0 4054 do i = 1, ncenter(geom) 4055 total_charge = total_charge + charge(i,geom) 4056 end do 4057c 4058 end 4059c 4060C> \brief Tests for super imposed atoms 4061c 4062C> A common error in geometries is to have two atoms essentially on 4063C> top of eachother. Usually this leads to problems in calculations. 4064C> This routine checks for such occurances. 4065c 4066C> \return Return .true. if no atoms are on top of eachother, 4067C> and .false. otherwise. 4068c 4069 logical function geom_verify_coords(geom) 4070 implicit none 4071#include "errquit.fh" 4072#include "stdio.fh" 4073#include "util_params.fh" 4074c 4075c::functions 4076 logical geom_ncent 4077 logical geom_cent_get 4078 external geom_ncent 4079 external geom_cent_get 4080c::passed 4081 integer geom !< [input] the geometry handle 4082c::local 4083 integer nat, iat, jat, num2compare, atomi, atomj 4084 integer i,j 4085 parameter (num2compare = 2) 4086 character*16 name(num2compare) 4087 double precision xyz(3,num2compare) 4088 double precision chg(num2compare) 4089 double precision dist_min 4090 double precision dist_thresh 4091 double precision dist_my 4092 parameter (dist_thresh = 0.5d0) 4093 double precision dist2 4094c 4095 dist2(i,j) = 4096 & (xyz(1,i)-xyz(1,j))*(xyz(1,i)-xyz(1,j)) + 4097 & (xyz(2,i)-xyz(2,j))*(xyz(2,i)-xyz(2,j)) + 4098 & (xyz(3,i)-xyz(3,j))*(xyz(3,i)-xyz(3,j)) 4099c 4100 if(.not.geom_ncent(geom, nat)) 4101 & call errquit('geom_verify_coords: geom_ncent failed',911, 4102 & GEOM_ERR) 4103c 4104 4105 atomi = 1 4106 atomj = 2 4107 dist_min = 56565.89d00 4108 do 00100 iat = 1,nat 4109 do 00200 jat = 1,iat 4110 if (jat.lt.iat) then 4111 if(.not.geom_cent_get 4112 & (geom,iat,name(atomi),xyz(1,atomi),chg(atomi))) 4113 & call errquit 4114 & ('geom_verify_coords: geom_cent_get<1> failed',911, 4115 & GEOM_ERR) 4116 if(.not. geom_cent_get 4117 & (geom,jat,name(atomj),xyz(1,atomj),chg(atomj))) 4118 & call errquit 4119 & ('geom_verify_coords: geom_cent_get<2> failed',911, 4120 & GEOM_ERR) 4121 dist_my = dist2(atomi,atomj) 4122 if (dist_my.lt.dist_thresh) then 4123 write(luout,*)' atoms ',iat,' and ',jat,' are similar' 4124 write(luout,*)' atom ',iat,' coordinates', 4125 & xyz(1,atomi),xyz(2,atomi),xyz(3,atomi) 4126 write(luout,*)' atom ',jat,' coordinates', 4127 & xyz(1,atomj),xyz(2,atomj),xyz(3,atomj) 4128 endif 4129 dist_min = min(dist_min, dist_my) 4130 end if 413100200 continue 413200100 continue 4133 dist_min = sqrt(dist_min) 4134 geom_verify_coords = dist_min.gt.dist_thresh 4135* write(LuOut,*)' distance minimum =', 4136* & dist_min, geom_verify_coords 4137c 4138 if (geom_verify_coords) return 4139 write(luout,*)'minimum distance ',dist_min 4140 write(luout,*) 4141 & ' ************ WARNING ******************' 4142 write(luout,'(A,F8.3,A)') 4143 & ' at least two atoms are only ',dist_min/cang2au, 4144 A ' angstrom apart ' 4145 write(luout,*) 4146 & 'Please check your geometry input' 4147 write(luout,*) 4148 & ' ************ WARNING ******************' 4149 write(luout,*) 4150 & 'If you like danger & want to skip this check' 4151 write(luout,*) 4152 & 'add the following input line' 4153 write(luout,*) 4154 & 'set geom:dont_verify .true.' 4155 4156 end 4157c 4158c 4159c---> new functions added on incorporation on symmetry and solid state codes 4160c 4161c 4162C> \brief Retrieve the system type for a given geometry 4163c 4164C> The system type indicates the number of dimensions in which the 4165C> system is periodic. 4166c 4167C> \return Return .true. if the system type was found successfully, and 4168C> .false. otherwise. 4169c 4170 logical function geom_systype_get(geom, itype) 4171 implicit none 4172#include "nwc_const.fh" 4173#include "geomP.fh" 4174 integer geom !< [Input] the geometry handle 4175 integer itype !< [Output] the system type 4176 logical geom_check_handle 4177 external geom_check_handle 4178 4179 geom_systype_get = geom_check_handle(geom, 'geom_systype_get') 4180 if (.not. geom_systype_get) return 4181c 4182c--> make the assignment 4183c 4184 itype=isystype(geom) 4185c 4186 geom_systype_get = .true. 4187 end 4188c 4189C> \brief Extracts the lattice vectors of a geometry instance 4190c 4191C> \return Return .true. if successfull, and .false. otherwise. 4192c 4193 logical function geom_latvec_get(geom,vectors) 4194 implicit none 4195#include "nwc_const.fh" 4196#include "geomP.fh" 4197c 4198 integer geom !< [Input] the geometry handle 4199 double precision vectors(3) !< [Output] the lattice vectors 4200 integer i 4201 logical geom_check_handle 4202 external geom_check_handle 4203c 4204 geom_latvec_get = geom_check_handle(geom, 'geom_latvec_get') 4205 if (.not. geom_latvec_get) return 4206 4207 do i=1,3 4208 vectors(i)=lattice_vectors(i,geom) 4209 end do 4210 geom_latvec_get = .true. 4211 end 4212c 4213C> \brief Extracts the lattice angles of a geometry instance 4214c 4215C> \return Return .true. if successfull, and .false. otherwise. 4216c 4217 logical function geom_latang_get(geom,angles) 4218 implicit none 4219#include "nwc_const.fh" 4220#include "geomP.fh" 4221c 4222 integer geom !< [Input] the geometry handle 4223 double precision angles(3) !< [Output] the lattice angles 4224 integer i 4225 logical geom_check_handle 4226 external geom_check_handle 4227 4228 geom_latang_get = geom_check_handle(geom, 'geom_latang_get') 4229 if (.not. geom_latang_get) return 4230c 4231 do i=1,3 4232 angles(i)=lattice_angles(i,geom) 4233 end do 4234 geom_latang_get = .true. 4235 end 4236c 4237C> \brief Extracts the reciprocal lattice vectors of a geometry instance 4238c 4239C> \return Return .true. if successfull, and .false. otherwise. 4240c 4241 logical function geom_recipvec_get(geom,rvectors) 4242 implicit none 4243#include "nwc_const.fh" 4244#include "geomP.fh" 4245c 4246 integer geom !< [Input] the geometry handle 4247 double precision rvectors(3) !< [Output] the reciprocal lattice vectors 4248 integer i 4249 logical geom_check_handle 4250 external geom_check_handle 4251c 4252 geom_recipvec_get = geom_check_handle(geom, 'geom_recipvec_get') 4253 if (.not. geom_recipvec_get) return 4254 4255 do i=1,3 4256 rvectors(i)=recip_lat_vectors(i,geom) 4257 end do 4258 geom_recipvec_get = .true. 4259 end 4260c 4261C> \brief Extracts the reciprocal lattice angles of a geometry instance 4262c 4263C> \return Return .true. if successfull, and .false. otherwise. 4264c 4265 logical function geom_recipang_get(geom,rangles) 4266 implicit none 4267#include "nwc_const.fh" 4268#include "geomP.fh" 4269c 4270 integer geom !< [Input] the geometry handle 4271 double precision rangles(3) !< [Output] the reciprocal lattice angles 4272 integer i 4273 logical geom_check_handle 4274 external geom_check_handle 4275c 4276 geom_recipang_get = geom_check_handle(geom, 'geom_recipang_get') 4277 if (.not. geom_recipang_get) return 4278 do i=1,3 4279 rangles(i)=recip_lat_angles(i,geom) 4280 end do 4281 geom_recipang_get = .true. 4282 end 4283 logical function geom_volume_get(geom,volume) 4284 implicit none 4285#include "nwc_const.fh" 4286#include "geomP.fh" 4287c 4288 integer geom ! [input] 4289 double precision volume ! [output] 4290 logical geom_check_handle 4291 external geom_check_handle 4292c 4293 geom_volume_get = geom_check_handle(geom, 'geom_volume_get') 4294 if (.not. geom_volume_get) return 4295 4296 volume=volume_direct(geom) 4297 4298 end 4299 4300 logical function geom_lattice_get(geom,lattice) 4301 implicit none 4302#include "nwc_const.fh" 4303#include "geomP.fh" 4304#include "errquit.fh" 4305c 4306 integer geom,i,j ! [input] 4307 double precision lattice(6) ! [output] 4308 double precision rad,scale 4309 logical geom_check_handle,geom_get_user_scale 4310 external geom_check_handle,geom_get_user_scale 4311 4312 geom_lattice_get = geom_check_handle(geom, 'geom_lattice_get') 4313 if (.not. geom_lattice_get) return 4314 if (.not. geom_get_user_scale(geom,scale)) 4315 $ call errquit('geom_lattice_get: call eric!',0, GEOM_ERR) 4316c 4317 4318 rad = 4.0d0*datan(1.0d0)/180.0d0 4319 lattice(1) = lattice_vectors(1,geom)*scale 4320 lattice(2) = lattice_vectors(2,geom)*scale 4321 lattice(3) = lattice_vectors(3,geom)*scale 4322 lattice(4) = lattice_angles(1,geom)*rad 4323 lattice(5) = lattice_angles(2,geom)*rad 4324 lattice(6) = lattice_angles(3,geom)*rad 4325 end 4326 4327 logical function geom_lattice_set(geom,lattice) 4328 implicit none 4329#include "errquit.fh" 4330#include "nwc_const.fh" 4331#include "geomP.fh" 4332c 4333 integer geom,i,j ! [input] 4334 double precision lattice(6) ! [output] 4335c 4336 integer iang 4337 double precision rad,dperm 4338 double precision c(3,3),vol,scale,amat(3,3),gmat(3,3) 4339 double precision c1,c2,c3,s3,cdist(3),cang(3) 4340 4341* *** external functions *** 4342 logical geom_check_handle, geom_get_user_scale 4343 external geom_check_handle,geom_get_user_scale 4344 double precision deter3 4345 external deter3 4346 4347c 4348 geom_lattice_set = geom_check_handle(geom, 'geom_lattice_set') 4349 if (.not. geom_lattice_set) return 4350 if (.not. geom_get_user_scale(geom,scale)) 4351 $ call errquit('geom_lattice_set: call eric!',0, GEOM_ERR) 4352 4353 rad = 180.0d0/(4.0d0*datan(1.0d0)) 4354 lattice_vectors(1,geom) = lattice(1)/scale 4355 lattice_vectors(2,geom) = lattice(2)/scale 4356 lattice_vectors(3,geom) = lattice(3)/scale 4357 lattice_angles(1,geom) = lattice(4)*rad 4358 lattice_angles(2,geom) = lattice(5)*rad 4359 lattice_angles(3,geom) = lattice(6)*rad 4360 cdist(1) = lattice(1) 4361 cdist(2) = lattice(2) 4362 cdist(3) = lattice(3) 4363 cang(1) = lattice(4) 4364 cang(2) = lattice(5) 4365 cang(3) = lattice(6) 4366c 4367c--------> build the metrical matrix (atomic units) 4368c 4369 do 200 i=1,3 4370 gmat(i,i)=cdist(i)**2 4371 200 continue 4372 iang=3 4373 do 210 i=1,3 4374 do 220 j=i+1,3 4375 gmat(i,j)=cdist(i)*cdist(j)*dcos(cang(iang)) 4376 gmat(j,i)=gmat(i,j) 4377 iang=iang-1 4378 220 continue 4379 210 continue 4380c 4381 do 230 i=1,3 4382 do 240 j=1,3 4383 metric_matrix(i,j,geom)=gmat(i,j) 4384 240 continue 4385 230 continue 4386 4387 dperm = deter3(gmat) 4388* 4389 vol=dsqrt(dperm) 4390 volume_direct(geom)=vol 4391c 4392 4393 c1=dcos(cang(1)) 4394 c2=dcos(cang(2)) 4395 c3=dcos(cang(3)) 4396 s3=dsin(cang(3)) 4397 amat(1,1) = cdist(1)*s3 4398 amat(1,2) = 0.0d+00 4399 amat(1,3) = (cdist(3)*(c2-c1*c3)/s3) 4400 amat(2,1) = cdist(1)*c3 4401 amat(2,2) = cdist(2) 4402 amat(2,3) = cdist(3)*c1 4403 amat(3,1) = 0.0d+00 4404 amat(3,2) = 0.0d+00 4405 amat(3,3) = (vol/(cdist(1)*cdist(2)*s3)) 4406c 4407 do i=1,3 4408 do j=1,3 4409 amatrix(i,j,geom) = amat(i,j) 4410 end do 4411 end do 4412c 4413c Mmmm ... the original code only set this stuff from the input 4414c using the a,b,c,alpha,beta,gamma, but now we have changed 4415c the amatrix ... need to update ainv and also recompute the 4416c other crap ... for now just set the other crap to crap so that 4417c we'll know if it is used 4418c 4419 do i = 1,3 4420 do j = 1,3 4421 metric_matrix(i,j,geom) = 1d300 4422 bmatrix(i,j,geom) = 1d300 4423 end do 4424 recip_lat_vectors(i,geom) = 1d300 4425 recip_lat_angles(i,geom) = 1d300 4426 end do 4427c 4428c HERE SHOULD RECOMPUTE AMATRIX WITH STANDARD ORIENTATION 4429c SINCE IF THE GEOMETRY IS STORED AND RELOADED THE 4430c STANDARD ORIENTATION IS IMPOSED. 4431c 4432c Update the amatrix inverse 4433c - Since amat=[a1,a2,a3] 4434c ainv=[b1,b2,b3]^t 4435c 4436 call dfill(9,0.0d0,c,1) 4437 c(1,1) = amat(2,2)*amat(3,3) - amat(3,2)*amat(2,3) ! = b(1,1) 4438 c(1,2) = amat(3,2)*amat(1,3) - amat(1,2)*amat(3,3) ! = b(2,1) 4439 c(1,3) = amat(1,2)*amat(2,3) - amat(2,2)*amat(1,3) ! = b(3,1) 4440 c(2,1) = amat(2,3)*amat(3,1) - amat(3,3)*amat(2,1) ! = b(1,2) 4441 c(2,2) = amat(3,3)*amat(1,1) - amat(1,3)*amat(3,1) ! = b(2,2) 4442 c(2,3) = amat(1,3)*amat(2,1) - amat(2,3)*amat(1,1) ! = b(3,2) 4443 c(3,1) = amat(2,1)*amat(3,2) - amat(3,1)*amat(2,2) ! = b(1,3) 4444 c(3,2) = amat(3,1)*amat(1,2) - amat(1,1)*amat(3,2) ! = b(2,3) 4445 c(3,3) = amat(1,1)*amat(2,2) - amat(2,1)*amat(1,2) ! = b(3,3) 4446 vol = amat(1,1)*c(1,1) 4447 > + amat(2,1)*c(1,2) 4448 4449c 4450 call dscal(9,1.0d0/vol,c,1) 4451c 4452 call dcopy(9,c,1,amatrix_inv(1,1,geom),1) 4453 4454 return 4455 end 4456 4457c 4458C> \brief Retrieve the fractional to Cartesian transformation matrix 4459c 4460C> Look up the transformation matrix that transforms fractional to 4461C> Cartesian coordinates for a geometry instance. The matrix is a simple 4462C> 3x3 matrix. 4463c 4464C> \return Return .true. if the matrix was successfully found, and 4465C> .false. otherwise. 4466c 4467 logical function geom_amatrix_get(geom,amat) 4468 implicit none 4469#include "nwc_const.fh" 4470#include "geomP.fh" 4471c 4472 integer geom !< [Input] the geometry handle 4473 double precision amat(3,3) !< [Output] the transformation matrix 4474 integer i,j 4475 logical geom_check_handle 4476 external geom_check_handle 4477 4478 geom_amatrix_get = geom_check_handle(geom, 'geom_amatrix_get') 4479 if (.not. geom_amatrix_get) return 4480c 4481 do i=1,3 4482 do j=1,3 4483 amat(i,j)=amatrix(i,j,geom) 4484 end do 4485 end do 4486 end 4487c 4488C> \brief Set the fractional to Cartesian transformation matrix 4489c 4490C> Stores the transformation matrix that transforms fractional to 4491C> Cartesian coordinates in a geometry instance. This matrix is a 4492C> simple 3x3 matrix. In addition the inverse transformation is 4493C> calculated and stored as well, and the lattice parameters are 4494C> updated. 4495c 4496C> \return Return .true. when the transformation was stored 4497C> successfully, and .false. otherwise 4498c 4499 logical function geom_amatrix_set(geom,amat) 4500 implicit none 4501#include "errquit.fh" 4502#include "nwc_const.fh" 4503#include "geomP.fh" 4504c 4505 integer geom !< [Input] the geometry handle 4506 double precision amat(3,3) !< [Input] the transformation matrix 4507 integer i,j 4508 logical geom_check_handle, geom_get_user_scale 4509 external geom_check_handle 4510c 4511 double precision c(3,3), vol, scale 4512c 4513 geom_amatrix_set = geom_check_handle(geom, 'geom_amatrix_set') 4514 if (.not. geom_amatrix_set) return 4515 if (.not. geom_get_user_scale(geom,scale)) 4516 $ call errquit('geom_amtrix_set: call eric!',0, GEOM_ERR) 4517c 4518 do i=1,3 4519 do j=1,3 4520 amatrix(i,j,geom) = amat(i,j) 4521 end do 4522 end do 4523c 4524c Mmmm ... the original code only set this stuff from the input 4525c using the a,b,c,alpha,beta,gamma, but now we have changed 4526c the amatrix ... need to update ainv and also recompute the 4527c other crap ... for now just set the other crap to crap so that 4528c we'll know if it is used 4529c 4530 do i = 1,3 4531 do j = 1,3 4532 metric_matrix(i,j,geom) = 1d300 4533 bmatrix(i,j,geom) = 1d300 4534 end do 4535 recip_lat_vectors(i,geom) = 1d300 4536 recip_lat_angles(i,geom) = 1d300 4537 end do 4538c 4539c HERE SHOULD RECOMPUTE AMATRIX WITH STANDARD ORIENTATION 4540c SINCE IF THE GEOMETRY IS STORED AND RELOADED THE 4541c STANDARD ORIENTATION IS IMPOSED. 4542c 4543c Update the amatrix inverse 4544c - Since amat=[a1,a2,a3] 4545c ainv=[b1,b2,b3]^t 4546c 4547 call dfill(9,0.0d0,c,1) 4548 c(1,1) = amat(2,2)*amat(3,3) - amat(3,2)*amat(2,3) ! = b(1,1) 4549 c(1,2) = amat(3,2)*amat(1,3) - amat(1,2)*amat(3,3) ! = b(2,1) 4550 c(1,3) = amat(1,2)*amat(2,3) - amat(2,2)*amat(1,3) ! = b(3,1) 4551 c(2,1) = amat(2,3)*amat(3,1) - amat(3,3)*amat(2,1) ! = b(1,2) 4552 c(2,2) = amat(3,3)*amat(1,1) - amat(1,3)*amat(3,1) ! = b(2,2) 4553 c(2,3) = amat(1,3)*amat(2,1) - amat(2,3)*amat(1,1) ! = b(3,2) 4554 c(3,1) = amat(2,1)*amat(3,2) - amat(3,1)*amat(2,2) ! = b(1,3) 4555 c(3,2) = amat(3,1)*amat(1,2) - amat(1,1)*amat(3,2) ! = b(2,3) 4556 c(3,3) = amat(1,1)*amat(2,2) - amat(2,1)*amat(1,2) ! = b(3,3) 4557 vol = amat(1,1)*c(1,1) 4558 > + amat(2,1)*c(1,2) 4559 > + amat(3,1)*c(1,3) 4560 volume_direct(geom) = vol 4561c 4562 call dscal(9,1.0d0/vol,c,1) 4563c 4564 call dcopy(9,c,1,amatrix_inv(1,1,geom),1) 4565c 4566c Ooops ... must also update the pesky lattice parameters 4567c 4568 call xlattice_abc_abg( 4569 $ lattice_vectors(1,geom), 4570 $ lattice_vectors(2,geom), 4571 $ lattice_vectors(3,geom), 4572 $ lattice_angles(1,geom), 4573 $ lattice_angles(2,geom), 4574 $ lattice_angles(3,geom),amat) 4575 4576 lattice_vectors(1,geom) = lattice_vectors(1,geom)/scale 4577 lattice_vectors(2,geom) = lattice_vectors(2,geom)/scale 4578 lattice_vectors(3,geom) = lattice_vectors(3,geom)/scale 4579c 4580 end 4581 subroutine xlattice_abc_abg(a,b,c,alpha,beta,gamma,lattice_unita) 4582 implicit none 4583 double precision a,b,c 4584 double precision alpha,beta,gamma,lattice_unita(3,3) 4585 4586* *** local variables **** 4587 double precision d2,pi 4588 4589* **** determine a,b,c,alpha,beta,gmma *** 4590 pi = 4.0d0*datan(1.0d0) 4591 a = dsqrt(lattice_unita(1,1)**2 4592 > + lattice_unita(2,1)**2 4593 > + lattice_unita(3,1)**2) 4594 b = dsqrt(lattice_unita(1,2)**2 4595 > + lattice_unita(2,2)**2 4596 > + lattice_unita(3,2)**2) 4597 c = dsqrt(lattice_unita(1,3)**2 4598 > + lattice_unita(2,3)**2 4599 > + lattice_unita(3,3)**2) 4600 4601 d2 = (lattice_unita(1,2)-lattice_unita(1,3))**2 4602 > + (lattice_unita(2,2)-lattice_unita(2,3))**2 4603 > + (lattice_unita(3,2)-lattice_unita(3,3))**2 4604 alpha = (b*b + c*c - d2)/(2.0d0*b*c) 4605 alpha = dacos(alpha)*180.0d0/pi 4606 4607 d2 = (lattice_unita(1,3)-lattice_unita(1,1))**2 4608 > + (lattice_unita(2,3)-lattice_unita(2,1))**2 4609 > + (lattice_unita(3,3)-lattice_unita(3,1))**2 4610 beta = (c*c + a*a - d2)/(2.0d0*c*a) 4611 beta = dacos(beta)*180.0d0/pi 4612 4613 d2 = (lattice_unita(1,1)-lattice_unita(1,2))**2 4614 > + (lattice_unita(2,1)-lattice_unita(2,2))**2 4615 > + (lattice_unita(3,1)-lattice_unita(3,2))**2 4616 gamma = (a*a + b*b - d2)/(2.0d0*a*b) 4617 gamma = dacos(gamma)*180.0d0/pi 4618 4619 return 4620 end 4621 4622 4623 4624 4625 logical function geom_bmatrix_get(geom,bmat) 4626 implicit none 4627#include "nwc_const.fh" 4628#include "geomP.fh" 4629c 4630 integer geom,i,j ! [input] 4631 double precision bmat(3,3) ! [output] 4632 logical geom_check_handle 4633 external geom_check_handle 4634 4635 geom_bmatrix_get = geom_check_handle(geom, 'geom_bmatrix_get') 4636 if (.not. geom_bmatrix_get) return 4637c 4638 do i=1,3 4639 do j=1,3 4640 bmat(i,j)=bmatrix(i,j,geom) 4641 end do 4642 end do 4643 end 4644 logical function geom_amatinv_get(geom,amatinv) 4645 implicit none 4646#include "nwc_const.fh" 4647#include "geomP.fh" 4648c 4649 integer geom,i,j ! [input] 4650 double precision amatinv(3,3) ! [output] 4651 logical geom_check_handle 4652 external geom_check_handle 4653c 4654 geom_amatinv_get = geom_check_handle(geom, 'geom_amatinv_get') 4655 if (.not. geom_amatinv_get) return 4656c 4657 do i=1,3 4658 do j=1,3 4659 amatinv(i,j)=amatrix_inv(i,j,geom) 4660 end do 4661 end do 4662 end 4663c 4664C> \brief Extract the symmetry unique centers from a geometry instance 4665c 4666C> \return Return .true. if successfull, and .false. otherwise. 4667c 4668 logical function geom_uniquecent_get(geom,ncent,uniquecent) 4669 implicit none 4670#include "nwc_const.fh" 4671#include "geomP.fh" 4672c 4673 integer geom !< [Input] the geometry handle 4674 integer ncent !< [Input] the number of unique centers 4675 integer uniquecent(ncent) !< [Output] the indicies of unique centers 4676 integer i 4677 logical geom_check_handle 4678 external geom_check_handle 4679c 4680 geom_uniquecent_get=geom_check_handle(geom,'geom_uniquecent_get') 4681 if (.not. geom_uniquecent_get) return 4682c 4683 do i=1,ncent 4684 uniquecent(i)=unique_cent(i,geom) 4685 enddo 4686 end 4687c 4688C> \brief Define the symmetry unique centers of a geometry instance 4689c 4690C> \return Return .true. if successfull, and .false. otherwise. 4691c 4692 logical function geom_uniquecent_set(geom,ncent,uniquecent) 4693 implicit none 4694#include "nwc_const.fh" 4695#include "geomP.fh" 4696c 4697 integer geom !< [Input] the geometry handle 4698 integer ncent !< [Input] the number of unique centers 4699 integer uniquecent(ncent) !< [Input] the indicies of unique centers 4700 integer i 4701 logical geom_check_handle 4702 external geom_check_handle 4703c 4704 geom_uniquecent_set=geom_check_handle(geom,'geom_uniquecent_set') 4705 if (.not. geom_uniquecent_set) return 4706c 4707 do i=1,ncent 4708 unique_cent(i,geom)=uniquecent(i) 4709 enddo 4710 end 4711c 4712C> \brief Retrieve the conversion factor from user units to atomic units 4713C> \return Return .true. if successfull, and .false. otherwise 4714 logical function geom_get_user_scale(geom, scale) 4715 implicit none 4716#include "errquit.fh" 4717#include "nwc_const.fh" 4718#include "geomP.fh" 4719 integer geom !< [Input] the geometry handle 4720 double precision scale !< [Output] the unit conversion factor 4721 logical geom_check_handle 4722 external geom_check_handle 4723c 4724 geom_get_user_scale = 4725 $ geom_check_handle(geom, 'geom_get_user_scale') 4726c 4727 if (user_units(geom) .eq. 'a.u.') then 4728 scale = 1.0d0 4729 else if (user_units(geom) .eq. 'angstroms') then 4730 scale = angstrom_to_au 4731 else if (user_units(geom) .eq. 'nanometer') then 4732 scale = angstrom_to_au * 10.0d0 4733 else if (user_units(geom) .eq. 'picometer') then 4734 scale = angstrom_to_au * 0.01d0 4735 else 4736 call errquit('geom_get_user_scale: unknown units',0, GEOM_ERR) 4737 endif 4738c 4739 end 4740c 4741C> \brief Defines the unit of the coordinates specified by the user 4742c 4743C> Internally the code always uses atomic units to store the 4744C> coordinates. However, in the input file the user may choose different 4745C> units, such as Angstrom, or nm. This function stores which units 4746C> the user used to specify the geometry. This allows, e.g. the 4747C> geometry to be printed in the same units it was specified in. 4748c 4749C> \return Return .true. if the function was successfull, and .false. 4750C> otherwise. 4751c 4752 logical function geom_set_user_units(geom, units) 4753 implicit none 4754#include "nwc_const.fh" 4755#include "geomP.fh" 4756 integer geom !< [Input] the geometry handle 4757 character*(*) units !< [Input] the user units 4758 logical geom_check_handle 4759 external geom_check_handle 4760c 4761 geom_set_user_units = 4762 $ geom_check_handle(geom, 'geom_set_user_units') 4763 user_units(geom) = units 4764c 4765 end 4766c 4767C> \brief Retrieves the unit of the coordinates specified by the user 4768c 4769C> Internally the code always uses atomic units to store the 4770C> coordinates. However, in the input file the user may choose different 4771C> units, such as Angstrom, or nm. This function retrieves which units 4772C> the user used to specify the geometry. This allows, e.g. the 4773C> geometry to be printed in the same units it was specified in. 4774c 4775C> \return Return .true. if the function was successfull, and .false. 4776C> otherwise. 4777c 4778 logical function geom_get_user_units(geom, units) 4779 implicit none 4780#include "nwc_const.fh" 4781#include "geomP.fh" 4782 integer geom !< [Input] the geometry handle 4783 character*(*) units !< [Output] the user units 4784 logical geom_check_handle 4785 external geom_check_handle 4786c 4787 geom_get_user_units = 4788 $ geom_check_handle(geom, 'geom_get_user_units') 4789 units = user_units(geom) 4790c 4791 end 4792 logical function geom_tag_to_default_mass(tag,mass) 4793 implicit none 4794#include "errquit.fh" 4795c 4796c this routine takes a tag matches it to the atomic number 4797c and returns the default atomic mass. 4798c 4799 character*16 tag ! [input] geometry tag 4800 double precision mass ! [output] corresponding elemental default mass 4801c 4802 logical geom_tag_to_element 4803 external geom_tag_to_element 4804 logical geom_atn_to_default_mass 4805 external geom_atn_to_default_mass 4806c 4807 character*2 tag_symbol 4808 character*16 tag_element 4809 integer tag_atomic_number 4810c 4811 geom_tag_to_default_mass = .false. 4812c 4813 if (.not. geom_tag_to_element(tag,tag_symbol, tag_element, 4814 & tag_atomic_number)) call errquit 4815 & ('geom_tag_to_default_mass: geom_tag_to_element failed ?', 4816 & 911, GEOM_ERR) 4817 geom_tag_to_default_mass = 4818 & geom_atn_to_default_mass(tag_atomic_number,mass) 4819 end 4820c 4821C> \brief Converts an atomic number to atomic mass 4822c 4823C> This routine returns the default atomic mass from based on the atomic 4824C> number. The mass for each element comes from the book "The Elements" 4825C> by John Emsley, Oxford University Press, (C) 1989, ISBN 0-19-855237-8 4826C> The specific mass chosen was the most abundant isotope with a known mass. 4827C> When the abundance was equal the isotope with the longest half life was 4828C> used. 4829c 4830C> \return Return .true. if the conversion was successfull, and .false. 4831C> otherwise. 4832c 4833 logical function geom_atn_to_default_mass(atn,mass) 4834c 4835c This routine returns the default atomic mass from based on the atomic 4836c number. The mass for each element comes from the book "The Elements" 4837c by John Emsley, Oxford University Press, (C) 1989, ISBN 0-19-855237-8 4838c The specific mass chosen was the most abundant isotope with a known mass. 4839c When the abundance was equal the isotope with the longest half life was 4840c used. 4841c 4842c RAK 11/95 PNNL/EMSL/HPCCG 4843c 4844c Updated 09/99 KG Dyall, correcting some transuranics and adding new 4845c values from the WebElements website www.webelements.com 4846c 4847c 4848 implicit none 4849#include "errquit.fh" 4850#include "nwc_const.fh" 4851#include "geomP.fh" 4852c 4853 integer atn !< [Input] the atomic number of element 4854 double precision mass !< [Output] the default elemental atomic mass. 4855c 4856 double precision def_masses(nelements) 4857c 4858 integer i 4859c 4860 data (def_masses(i),i=1,50) / 4861 & 1.007825d0, 4.0026d0, 7.016d0, 9.01218d0, 11.00931d0, 4862 & 12.0d0, 14.00307d0, 15.99491d0, 18.9984d0, 19.99244d0, 4863 & 22.9898d0, 23.98504d0, 26.98154d0, 27.97693d0, 30.97376d0, 4864 & 31.97207d0, 34.96885d0, 39.9624d0, 38.96371d0, 39.96259d0, 4865 & 44.95592d0, 45.948d0, 50.9440d0, 51.9405d0, 54.9381d0, 4866 & 55.9349d0, 58.9332d0, 57.9353d0, 62.9298d0, 63.9291d0, 4867 & 68.9257d0, 73.9219d0, 74.9216d0, 78.9183d0, 79.9165d0, 4868 & 83.912d0, 84.9117d0, 87.9056d0, 88.9054d0, 89.9043d0, 4869 & 92.9060d0, 97.9055d0, 97.9072d0, 101.9037d0, 102.9048d0, 4870 &105.9032d0, 106.90509d0, 113.9036d0, 114.9041d0, 117.9018d0/ 4871 data (def_masses(i),i=51,109) / 4872 & 120.9038d0, 129.9067d0, 126.9004d0, 131.9042d0, 132.9051d0, 4873 & 137.9050d0, 138.9061d0, 139.9053d0, 140.9074d0, 143.9099d0, 4874 & 144.9128d0, 151.9195d0, 152.9209d0, 157.9241d0, 159.9250d0, 4875 & 163.9288d0, 164.9303d0, 165.9304d0, 168.9344d0, 173.9390d0, 4876 & 174.9409d0, 179.9468d0, 180.948d0, 183.9510d0, 186.9560d0, 4877 & 189.9586d0, 192.9633d0, 194.9648d0, 196.9666d0, 201.9706d0, 4878 & 204.9745d0, 207.9766d0, 208.9804d0, 209.9829d0, 210.9875d0, 4879 & 222.0175d0, 223.0198d0, 226.0254d0, 227.0278d0, 232.0382d0, 4880 & 231.0359d0, 238.0508d0, 237.0482d0, 244.0642d0, 243.0614d0, 4881 & 247.0704d0, 247.0703d0, 251.0796d0, 252.0829d0, 257.0950d0, 4882 & 258.0986d0, 259.1009d0, 262.1100d0, 261.1087d0, 262.1138d0, 4883 & 266.1219d0, 262.1229d0, 267.1318d0, 268.1388d0 / 4884c 4885 geom_atn_to_default_mass = .false. 4886c 4887 if (atn.lt.0) call errquit 4888 & ('geom_atn_to_default_mass: negative atomic number',atn, 4889 & GEOM_ERR) 4890 if (atn.gt.nelements) call errquit 4891 & ('geom_atn_to_default_mass: atomic number too large',atn, 4892 & GEOM_ERR) 4893c 4894 if (atn.eq.0) then 4895 mass = 0.0d00 ! Bq centers have no mass 4896 else 4897 mass = def_masses(atn) 4898 endif 4899 geom_atn_to_default_mass = .true. 4900c 4901 end 4902C> 4903C> \brief Define the atomic masses of the centers in a geometry instance 4904C> 4905C> \return Return .true. if successfull, and .false. otherwise 4906C> 4907 logical function geom_masses_set(geom, ncent, masses) 4908 implicit none 4909#include "nwc_const.fh" 4910#include "geomP.fh" 4911#include "stdio.fh" 4912c 4913 integer geom !< [Input] the geometry handle 4914 integer ncent !< [Input] the number of centers 4915 double precision masses(ncent) !< [Input] the mass on each center 4916c 4917 integer i 4918c 4919 logical geom_check_handle 4920 external geom_check_handle 4921c 4922 geom_masses_set = geom_check_handle(geom, 'geom_masses_set') 4923 if (.not. geom_masses_set) return 4924c 4925 if (ncent.le.0) then 4926 write(LuOut,*) ' geom_masses_set: too few centers ',ncent, 4927 $ names(geom)(1:lenn(geom)) 4928 geom_masses_set = .false. 4929 return 4930 else if (ncent.gt.max_cent) then 4931 write(LuOut,*) ' geom_masses_set: too many centers ',ncent, 4932 $ names(geom)(1:lenn(geom)) 4933 geom_masses_set = .false. 4934 return 4935 end if 4936c 4937 do i = 1, ncent 4938 geom_mass(i,geom) = masses(i) 4939 enddo 4940c 4941 end 4942c 4943C> \brief Retrieve the masses of the centers 4944c 4945C> Retrieves the masses associated with the centers in a geometry 4946C> instance. 4947c 4948C> \return Return .true. if the function was successfull, and .false. 4949C> otherwise. 4950c 4951 logical function geom_masses_get(geom, ncent, masses) 4952 implicit none 4953#include "nwc_const.fh" 4954#include "geomP.fh" 4955c 4956 integer geom ! [Input] the geometry handle 4957 integer ncent ! [Output] the number of centers 4958 double precision masses(ncent) ! [Output] the mass on each center 4959c 4960 integer i 4961c 4962 logical geom_check_handle 4963 external geom_check_handle 4964c 4965 geom_masses_get = geom_check_handle(geom, 'geom_masses_get') 4966 if (.not. geom_masses_get) return 4967c 4968 ncent = ncenter(geom) 4969 do i = 1, ncent 4970 masses(i) = geom_mass(i,geom) 4971 enddo 4972c 4973 end 4974c 4975C> \brief Define the atomic mass of the specified center in a geometry instance 4976c 4977C> \return Return .true. if successfull, and .false. otherwise 4978c 4979 logical function geom_mass_set(geom, icent, mass) 4980 implicit none 4981#include "nwc_const.fh" 4982#include "geomP.fh" 4983#include "stdio.fh" 4984c 4985 integer geom !< [Input] the geometry handle 4986 integer icent !< [Input] the center rank 4987 double precision mass !< [Input] the mass on center icent 4988c 4989 logical geom_check_handle 4990 external geom_check_handle 4991c 4992 geom_mass_set = geom_check_handle(geom, 'geom_mass_set') 4993 if (.not. geom_mass_set) return 4994c 4995 if (icent.le.0 .or. icent.gt.ncenter(geom)) then 4996 write(LuOut,*) ' geom_mass_set: icent out of range',icent, 4997 & ncenter(geom), 4998 $ names(geom)(1:lenn(geom)) 4999 return 5000 end if 5001c 5002 geom_mass(icent,geom) = mass 5003c 5004 end 5005c 5006C> \brief Retrieve the atomic mass of the specified center in a geometry instance 5007c 5008C> \return Return .true. if successfull, and .false. otherwise 5009c 5010 logical function geom_mass_get(geom, icent, mass) 5011 implicit none 5012#include "nwc_const.fh" 5013#include "geomP.fh" 5014#include "stdio.fh" 5015c 5016 integer geom !< [Input] the geometry handle 5017 integer icent !< [Input] the center rank 5018 double precision mass !< [Output] the mass on center icent 5019c 5020 logical geom_check_handle 5021 external geom_check_handle 5022c 5023 geom_mass_get = geom_check_handle(geom, 'geom_mass_get') 5024 if (.not. geom_mass_get) return 5025c 5026 if (icent.le.0 .or. icent.gt.ncenter(geom)) then 5027 write(LuOut,*) ' geom_mass_get: icent out of range',icent, 5028 & ncenter(geom), 5029 $ names(geom)(1:lenn(geom)) 5030 return 5031 end if 5032c 5033 mass = geom_mass(icent,geom) 5034c 5035 end 5036C> 5037C> \brief Define the atom constraint type of the centers in a geometry 5038C> instance 5039C> 5040C> \return Return .true. if successfull, and .false. otherwise 5041C> 5042 logical function geom_atomct_set(geom, ncent, atomct) 5043 implicit none 5044#include "nwc_const.fh" 5045#include "geomP.fh" 5046#include "stdio.fh" 5047c 5048 integer geom !< [Input] the geometry handle 5049 integer ncent !< [Input] the number of centers 5050 double precision atomct(ncent) !< [Input] the atom constraint type 5051 !< on each center 5052c 5053 integer i 5054c 5055 logical geom_check_handle 5056 external geom_check_handle 5057c 5058 geom_atomct_set = geom_check_handle(geom, 'geom_atomct_set') 5059 if (.not. geom_atomct_set) return 5060c 5061 if (ncent.le.0) then 5062 write(LuOut,*) ' geom_atomct_set: too few centers ',ncent, 5063 $ names(geom)(1:lenn(geom)) 5064 geom_atomct_set = .false. 5065 return 5066 else if (ncent.gt.max_cent) then 5067 write(LuOut,*) ' geom_atomct_set: too many centers ',ncent, 5068 $ names(geom)(1:lenn(geom)) 5069 geom_atomct_set = .false. 5070 return 5071 end if 5072c 5073 do i = 1, ncent 5074 geom_atomct(i,geom) = atomct(i) 5075 enddo 5076c 5077 end 5078C> 5079C> \brief Retrieve the atom constraint type of the centers in a geometry 5080C> instance 5081C> 5082C> \return Return .true. if successfull, and .false. otherwise 5083C> 5084 logical function geom_atomct_get(geom, ncent, atomct) 5085 implicit none 5086#include "nwc_const.fh" 5087#include "geomP.fh" 5088#include "stdio.fh" 5089c 5090 integer geom !< [Input] the geometry handle 5091 integer ncent !< [Output] the number of centers 5092 double precision atomct(ncent) !< [Output] the atom constraint 5093 !< type on each center 5094c 5095 integer i 5096c 5097 logical geom_check_handle 5098 external geom_check_handle 5099c 5100 geom_atomct_get = geom_check_handle(geom, 'geom_atomct_set') 5101 if (.not. geom_atomct_get) return 5102c 5103 ncent = ncenter(geom) 5104c 5105 do i = 1, ncent 5106 atomct(i) = geom_atomct(i,geom) 5107 enddo 5108c 5109 end 5110c 5111C> \brief Set the Angstrom to Bohr conversion factor for a geometry 5112C> instance 5113c 5114C> \return Return .true. if successfull, and .false. otherwise 5115c 5116 logical function geom_set_ang2au(geom,value) 5117 implicit none 5118#include "nwc_const.fh" 5119#include "geomP.fh" 5120c::functions 5121 logical geom_check_handle 5122 external geom_check_handle 5123c::passed 5124 integer geom !< [Input] the geometry handle 5125 double precision value !< [Input] the conversion factor from 5126c !< angstroms to au value ~1.8... 5127c 5128 geom_set_ang2au = geom_check_handle(geom,'geom_set_ang2au') 5129 if (.not. geom_set_ang2au) return 5130c 5131 angstrom_to_au = value 5132c 5133 end 5134c 5135C> \brief Retrieve the Angstrom to Bohr conversion factor for a geometry 5136C> instance 5137c 5138C> \return Return .true. if successfull, and .false. otherwise 5139c 5140 logical function geom_get_ang2au(geom,value) 5141 implicit none 5142#include "nwc_const.fh" 5143#include "geomP.fh" 5144c::functions 5145 logical geom_check_handle 5146 external geom_check_handle 5147c::passed 5148 integer geom !< [Input] the geometry handle 5149 double precision value !< [Output] the conversion factor from 5150c !< angstroms to au value ~1.8...... 5151c 5152 geom_get_ang2au = geom_check_handle(geom,'geom_get_ang2au') 5153 if (.not. geom_get_ang2au) return 5154c 5155 value = angstrom_to_au 5156c 5157 end 5158 logical function geom_set_au2ang(geom,value) 5159 implicit none 5160#include "nwc_const.fh" 5161#include "geomP.fh" 5162c::functions 5163 logical geom_check_handle 5164 external geom_check_handle 5165c::passed 5166 integer geom ! [input] geometry handle 5167 double precision value ! [input] converts au to angstroms value ~0.52917 5168c 5169 geom_set_au2ang = geom_check_handle(geom,'geom_set_au2ang') 5170 if (.not. geom_set_au2ang) return 5171c 5172 angstrom_to_au = 1.0d00/value 5173c 5174 end 5175 logical function geom_get_au2ang(geom,value) 5176 implicit none 5177#include "nwc_const.fh" 5178#include "geomP.fh" 5179c::functions 5180 logical geom_check_handle 5181 external geom_check_handle 5182c::passed 5183 integer geom ! [input] geometry handle 5184 double precision value ! [output] converts au to angstroms value ~0.52917 5185c 5186 geom_get_au2ang = geom_check_handle(geom,'geom_get_au2ang') 5187 if (.not. geom_get_au2ang) return 5188c 5189 value = 1.0d00/angstrom_to_au 5190c 5191 end 5192c 5193C> \brief Define the centers in a geometry instance that have an ECP 5194c 5195C> \return Return .true. if successfull, and .false. otherwise 5196c 5197 logical function geom_ecp_allset(geom,ncenter_in,oecp) 5198 implicit none 5199#include "errquit.fh" 5200c 5201#include "nwc_const.fh" 5202#include "geomP.fh" 5203c 5204 integer geom ! [Input] the geometry handle 5205 integer ncenter_in ! [Input] the number of centers 5206 logical oecp(ncenter_in) ! [Input] array of T/F for having ECPs 5207c 5208 logical geom_check_handle 5209 external geom_check_handle 5210c 5211 integer icenter 5212c 5213 geom_ecp_allset = geom_check_handle(geom, 'geom_ecp_allset') 5214c 5215 if (ncenter_in.ne.ncenter(geom)) call errquit 5216 & (' too many or to few centers specified delta=', 5217 & (ncenter(geom)-ncenter_in), GEOM_ERR) 5218c 5219 do icenter = 1,ncenter_in 5220 oecpcent(icenter,geom) = oecp(icenter) 5221 enddo 5222c 5223 end 5224c 5225C> \brief Retrieve the centers in a geometry instance that have an ECP 5226c 5227C> \return Return .true. if successfull, and .false. otherwise 5228c 5229 logical function geom_ecp_allget(geom,ncenter_in,oecp) 5230 implicit none 5231#include "errquit.fh" 5232c 5233#include "nwc_const.fh" 5234#include "geomP.fh" 5235c 5236 integer geom !< [Input] the geometry handle 5237 integer ncenter_in !< [Input] the number of centers 5238 logical oecp(ncenter_in) !< [Output] array of T/F for having ECPs 5239c 5240 logical geom_check_handle 5241 external geom_check_handle 5242c 5243 integer icenter 5244c 5245 geom_ecp_allget = geom_check_handle(geom, 'geom_ecp_allget') 5246c 5247 if (ncenter_in.ne.ncenter(geom)) call errquit 5248 & (' too many or to few centers specified delta=', 5249 & (ncenter(geom)-ncenter_in), GEOM_ERR) 5250c 5251 do icenter = 1,ncenter_in 5252 oecp(icenter)= oecpcent(icenter,geom) 5253 enddo 5254c 5255 end 5256 5257 logical function geom_ecp_set(geom,icent,oecp) 5258 implicit none 5259#include "errquit.fh" 5260c 5261#include "stdio.fh" 5262#include "nwc_const.fh" 5263#include "geomP.fh" 5264c 5265 integer geom ! [input] geometry handle 5266 integer icent ! [input] number of center to use 5267 logical oecp ! [input] T/F for having ECPs 5268c 5269 logical geom_check_handle 5270 external geom_check_handle 5271c 5272 geom_ecp_set = geom_check_handle(geom, 'geom_ecp_set') 5273c 5274 if (.not.(icent.gt.0.and.icent.le.ncenter(geom))) then 5275 write(luout,*)' icent = ',icent 5276 write(luout,*)' ncenter = ',ncenter(geom) 5277 call errquit('geom_ecp_set: icent out of range ncenter = ',911, 5278 & GEOM_ERR) 5279 endif 5280c 5281 oecpcent(icent,geom) = oecp 5282c 5283 end 5284 logical function geom_ecp_get(geom,icent) 5285 implicit none 5286#include "errquit.fh" 5287c 5288#include "stdio.fh" 5289#include "nwc_const.fh" 5290#include "geomP.fh" 5291c 5292 integer geom ! [input] geometry handle 5293 integer icent ! [input] number of center to use 5294* return call is [output] T/F for having ECPs 5295c 5296 logical geom_check_handle 5297 external geom_check_handle 5298c 5299 geom_ecp_get = geom_check_handle(geom, 'geom_ecp_get') 5300c 5301 if (.not.(icent.gt.0.and.icent.le.ncenter(geom))) then 5302 write(luout,*)' icent = ',icent 5303 write(luout,*)' ncenter = ',ncenter(geom) 5304 call errquit('geom_ecp_get: icent out of range ncenter = ',911, 5305 & GEOM_ERR) 5306 endif 5307c 5308 geom_ecp_get = oecpcent(icent,geom) 5309c 5310 end 5311 logical function geom_ncent_ecp(geom, ncent_ecp) 5312 implicit none 5313#include "nwc_const.fh" 5314#include "geomP.fh" 5315c 5316 integer geom ! [input] 5317 integer ncent_ecp ! [output] 5318 logical geom_check_handle 5319 external geom_check_handle 5320c 5321 integer icent 5322c 5323 geom_ncent_ecp = geom_check_handle(geom, 'geom_ncent_ecp') 5324 if (.not. geom_ncent_ecp) return 5325 ncent_ecp = 0 5326 do icent = 1,ncenter(geom) 5327 if (oecpcent(icent,geom)) ncent_ecp = ncent_ecp + 1 5328 enddo 5329c 5330 end 5331 logical function geom_coords_ecp(geom, coords_ecp, ncent_in) 5332 implicit none 5333#include "errquit.fh" 5334#include "nwc_const.fh" 5335#include "geomP.fh" 5336#include "stdio.fh" 5337c 5338 integer geom ! [input] 5339 integer ncent_in ! [input] 5340 double precision coords_ecp(3,ncent_in) ! [output] 5341c 5342 logical geom_check_handle 5343 external geom_check_handle 5344c 5345 integer icent, ncent_ecp 5346c 5347 geom_coords_ecp = geom_check_handle(geom, 'geom_coords_ecp') 5348 if (.not. geom_coords_ecp) return 5349 ncent_ecp = 0 5350 do icent = 1,ncenter(geom) 5351 if (oecpcent(icent,geom)) then 5352 ncent_ecp = ncent_ecp + 1 5353 if (ncent_ecp.gt.ncent_in) call errquit 5354 & ('geom_coords_ecp: number of ecp centers is greater'// 5355 & ' than the coord array dimension which is:',ncent_in, 5356 & GEOM_ERR) 5357* write(LuOut,*)' geom = ',geom 5358* write(LuOut,*)' ncent_ecp = ',ncent_ecp 5359* write(LuOut,*)' icent = ',icent 5360* write(LuOut,*)' coords geom 1',coords(1,icent,geom) 5361* write(LuOut,*)' coords geom 2',coords(2,icent,geom) 5362* write(LuOut,*)' coords geom 3',coords(3,icent,geom) 5363 5364 coords_ecp(1,ncent_ecp) = coords(1,icent,geom) 5365 coords_ecp(2,ncent_ecp) = coords(2,icent,geom) 5366 coords_ecp(3,ncent_ecp) = coords(3,icent,geom) 5367 5368* write(LuOut,*)' coords ecp 1',coords_ecp(1,ncent_ecp) 5369* write(LuOut,*)' coords ecp 2',coords_ecp(2,ncent_ecp) 5370* write(LuOut,*)' coords ecp 3',coords_ecp(3,ncent_ecp) 5371 endif 5372 enddo 5373* write(LuOut,*)' coordinates inside geom_coords_ecp' 5374* call output(coords_ecp,1,3,1,ncent_ecp,3,ncent_ecp,1) 5375c 5376 end 5377 logical function geom_any_ecp(geom) 5378 implicit none 5379#include "nwc_const.fh" 5380#include "geomP.fh" 5381c 5382 integer geom ! [input] 5383 logical geom_check_handle 5384 external geom_check_handle 5385c 5386 integer icent 5387c 5388 geom_any_ecp = geom_check_handle(geom, 'geom_any_ecp') 5389 if (.not. geom_any_ecp) return 5390 geom_any_ecp = .false. 5391 do icent = 1,ncenter(geom) 5392 if (oecpcent(icent,geom)) then 5393 geom_any_ecp = .true. 5394 return 5395 endif 5396 enddo 5397c 5398 end 5399 logical function geom_ecp_center_list(geom, num_ecp_cent, 5400 & ecp_cent) 5401 implicit none 5402#include "errquit.fh" 5403#include "nwc_const.fh" 5404#include "geomP.fh" 5405 logical geom_check_handle 5406 external geom_check_handle 5407c 5408 integer geom ! [input] geometry handle 5409 integer num_ecp_cent ! [input] dimension of ecp_cent 5410*. . . . . . . . . . . . . array from calling routine 5411 integer ecp_cent(num_ecp_cent) ! [output] list of centers that 5412*. . . . . . . . . . . . . . . . . . . have ECPs 5413* 5414 integer icent, num_ecp 5415* 5416 geom_ecp_center_list = 5417 & geom_check_handle(geom,'geom_ecp_center_list') 5418 if (.not. geom_ecp_center_list) return 5419c 5420 num_ecp = 0 5421 do icent = 1, ncenter(geom) 5422 if (oecpcent(icent,geom)) then 5423 num_ecp = num_ecp + 1 5424 if (num_ecp.gt.num_ecp_cent) call errquit 5425 & ('geom_ecp_center_list: number of ecp centers greater'// 5426 & ' than array size passed in which is:',num_ecp_cent, 5427 & GEOM_ERR) 5428 ecp_cent(num_ecp) = icent 5429 endif 5430 enddo 5431 end 5432 logical function geom_nuc_dipole(geom,dip) 5433 implicit none 5434#include "nwc_const.fh" 5435#include "geomP.fh" 5436 integer geom ! [input] 5437 double precision dip(3) ! [output] Returns the nuclear dipole in AU 5438c 5439 logical geom_check_handle 5440 external geom_check_handle 5441c 5442 geom_nuc_dipole = geom_check_handle(geom,'geom_nuc_dipole') 5443 if (.not. geom_nuc_dipole) return 5444c 5445 dip(1) = ndipole(1,geom) 5446 dip(2) = ndipole(2,geom) 5447 dip(3) = ndipole(3,geom) 5448c 5449 end 5450 logical function geom_calc_distance(a,b,ab) 5451 implicit none 5452c 5453* computes distance between two atoms 5454c 5455 double precision a(3) ! [input] coords of center a 5456 double precision b(3) ! [input] coords of center b 5457 double precision ab ! [output] distance between centers a,b 5458c 5459 ab = (a(1)-b(1))*(a(1)-b(1)) 5460 ab = (a(2)-b(2))*(a(2)-b(2)) + ab 5461 ab = (a(3)-b(3))*(a(3)-b(3)) + ab 5462 ab = sqrt(ab) 5463 geom_calc_distance = ab.ge.0.0d00 5464 end 5465c 5466 logical function geom_calc_angle(a,b,c,angle) 5467 implicit none 5468#include "errquit.fh" 5469c 5470c computes the angle (in degrees) between 3 atoms in order given 5471c 5472#include "stdio.fh" 5473c::-functions 5474 logical geom_calc_distance 5475 external geom_calc_distance 5476c::-passed 5477 double precision a(3) ! [input] coordinates of center a 5478 double precision b(3) ! [input] coordinates of center b 5479 double precision c(3) ! [input] coordinates of center c 5480 double precision angle ! [output] the angle (in degrees) 5481c::-local 5482 double precision ab, bc, ac, xcosine 5483 double precision pi 5484 double precision thresh 5485 parameter (thresh=1.0d-6) 5486c::-statement function 5487 logical is_it_close_to 5488 double precision value,test 5489*--- is value close to test? 5490 is_it_close_to(value,test) = (abs(value-test).lt.thresh) 5491c 5492 pi = 2.0d00*acos(0.0d00) 5493 geom_calc_angle = geom_calc_distance(a,b,ab) 5494 geom_calc_angle = geom_calc_angle.and.geom_calc_distance(b,c,bc) 5495 geom_calc_angle = geom_calc_angle.and.geom_calc_distance(a,c,ac) 5496 if (.not.geom_calc_angle) call errquit 5497 & ('geom_calc_angle:error computing a distance',911, GEOM_ERR) 5498 5499 xcosine = ab*ab + bc*bc - ac*ac 5500 if (is_it_close_to(ab,0.0d00).or. 5501 & is_it_close_to(bc,0.0d00)) then 5502 write(luout,*)' fatal error in geom_calc_angle ' 5503 write(luout,*)' distance ab ',ab 5504 write(luout,*)' distance ac ',ac 5505 write(luout,*)' distance bc ',bc 5506 write(luout,*)' please report this data to:' 5507 write(luout,*)' nwchem-users@emsl.pnl.gov' 5508 geom_calc_angle = .false. 5509 angle = -565.6589d00 5510 return 5511 endif 5512 xcosine = xcosine/(2.0d00*ab*bc) 5513 5514 if( abs(xcosine) .gt. 1.00d00 ) xcosine = sign(1.0d00,xcosine) 5515 5516 angle = (180.0d00/pi)*acos(xcosine) 5517 5518 end 5519 logical function geom_calc_dihedral(ain,bin,cin,din,dihedral) 5520 implicit none 5521#include "errquit.fh" 5522c 5523c computes the dihedral angle for the given 4 atom coordinates 5524c 5525c::-includes 5526#include "stdio.fh" 5527c::-functions 5528 logical geom_calc_angle 5529 external geom_calc_angle 5530c::-passed 5531 double precision ain(3) ! [input] coordinates of center a 5532 double precision bin(3) ! [input] coordinates of center b 5533 double precision cin(3) ! [input] coordinates of center c 5534 double precision din(3) ! [input] coordinates of center d 5535 double precision dihedral ! [output] the dihedral angle (in degrees) 5536c::-local 5537 double precision abc, bcd, abd, acd 5538 double precision a(3),b(3),c(3),d(3) 5539 double precision pi 5540 double precision BA(3), BC(3), CB(3), CD(3) 5541 double precision BAxBC(3), CBxCD(3) 5542 double precision mbaxbc, mcbxcd 5543 double precision cosangle 5544 double precision threshcos 5545 parameter (threshcos=1.0d-6) 5546 double precision thresh 5547 parameter (thresh = 1.0d-3) 5548 logical linear1 5549 logical linear2 5550c 5551c::-statement function 5552 logical is_it_close_to 5553 double precision value,test 5554*--- is value close to test? 5555 is_it_close_to(value,test) = (abs(value-test).lt.thresh) 5556c 5557 pi = 2.0d00*acos(0.0d00) 5558 geom_calc_dihedral = .true. 5559 dihedral = -565.6589d00 5560* compute appropriate angles 5561 geom_calc_dihedral = geom_calc_angle(ain,bin,cin,abc) 5562 geom_calc_dihedral = geom_calc_dihedral.and. 5563 & geom_calc_angle(bin,cin,din,bcd) 5564 geom_calc_dihedral = geom_calc_dihedral.and. 5565 & geom_calc_angle(ain,bin,din,abd) 5566 geom_calc_dihedral = geom_calc_dihedral.and. 5567 & geom_calc_angle(ain,cin,din,acd) 5568 if (.not.geom_calc_dihedral) then 5569 write(luout,*)' angle abc ',abc 5570 write(luout,*)' angle bcd ',bcd 5571 write(luout,*)' angle abd ',abd 5572 write(luout,*)' angle acd ',acd 5573 write(luout,*)' please report this data to:' 5574 write(luout,*)' nwchem-users@emsl.pnl.gov' 5575 call util_flush(luout) 5576 call errquit 5577 & ('geom_calc_dihedral: fatal angle error',1, GEOM_ERR) 5578 endif 5579* 5580* check special cases a,b,c or b,c,d are linear 5581 linear1 = is_it_close_to(abc,0.0d00) 5582 linear1 = linear1.or.is_it_close_to(abc,180.0d00) 5583 linear1 = linear1.or.is_it_close_to(bcd,0.0d00) 5584 linear1 = linear1.or.is_it_close_to(bcd,180.0d00) 5585 if (linear1) then 5586 dihedral = 0.0d00 5587 return 5588 endif 5589* a,b,d or a,c,d are linear 5590 linear2 = is_it_close_to(abd,0.0d00) 5591 linear2 = linear2.or.is_it_close_to(acd,0.0d00) 5592 if (linear2) then 5593 dihedral = 180.0d00 5594 return 5595 endif 5596c 5597*... abc (b center) 5598 call dcopy(3,ain,1,a,1) 5599 call dcopy(3,bin,1,b,1) 5600 call dcopy(3,cin,1,c,1) 5601* form vectors BA and BC (make B the origin) 5602 BA(1) = a(1)-b(1) 5603 BA(2) = a(2)-b(2) 5604 BA(3) = a(3)-b(3) 5605 BC(1) = c(1)-b(1) 5606 BC(2) = c(2)-b(2) 5607 BC(3) = c(3)-b(3) 5608* form cross product of BA and BC 5609 BAxBC(1) = BA(2)*BC(3)-BA(3)*BC(2) 5610 BAxBC(2) = BA(3)*BC(1)-BA(1)*BC(3) 5611 BAxBC(3) = BA(1)*BC(2)-BA(2)*BC(1) 5612* find magnitude of BAxBC 5613 mbaxbc = BAxBC(1)*BAxBC(1) + BAxBC(2)*BAxBC(2) + BAxBC(3)*BAxBC(3) 5614 mbaxbc = sqrt(mbaxbc) 5615c 5616*... bcd (c center) ! right hand screw!! 5617 call dcopy(3,bin,1,b,1) 5618 call dcopy(3,cin,1,c,1) 5619 call dcopy(3,din,1,d,1) 5620* form vectors CB and CD (make C the origin) 5621 CB(1) = b(1) - c(1) 5622 CB(2) = b(2) - c(2) 5623 CB(3) = b(3) - c(3) 5624 CD(1) = d(1) - c(1) 5625 CD(2) = d(2) - c(2) 5626 CD(3) = d(3) - c(3) 5627* form cross product of CB and CD 5628 CBxCD(1) = CB(2)*CD(3)-CB(3)*CD(2) 5629 CBxCD(2) = CB(3)*CD(1)-CB(1)*CD(3) 5630 CBxCD(3) = CB(1)*CD(2)-CB(2)*CD(1) 5631* now find the angle between two vectors BAxBC and CBxCD 5632* find magnitude of CBxCD 5633 mcbxcd = CBxCD(1)*CBxCD(1) + CBxCD(2)*CBxCD(2) + CBxCD(3)*CBxCD(3) 5634 mcbxcd = sqrt(mcbxcd) 5635* 5636 cosangle = BAxBC(1)*CBxCD(1) + BAxBC(2)*CBxCD(2) + 5637 & BAxBC(3)*CBxCD(3) 5638 if (is_it_close_to(mbaxbc,0.0d00).or. 5639 & is_it_close_to(mcbxcd,0.0d00)) then 5640 write(luout,*)' fatal error in geom_calc_dihedral ' 5641 write(luout,*)' mbaxbc ',mbaxbc 5642 write(luout,*)' mcbxcd ',mcbxcd 5643 write(luout,*)'a coordinates',ain 5644 write(luout,*)'b coordinates',bin 5645 write(luout,*)'c coordinates',cin 5646 write(luout,*)'d coordinates',din 5647 write(luout,*)' angle abc ',abc 5648 write(luout,*)' angle bcd ',bcd 5649 write(luout,*)' angle abd ',abd 5650 write(luout,*)' angle acd ',acd 5651 write(luout,*)' please report this data to:' 5652 write(luout,*)' nwchem-users@emsl.pnl.gov' 5653 call util_flush(luout) 5654 geom_calc_dihedral = .false. 5655 return 5656 endif 5657 cosangle = cosangle/mbaxbc/mcbxcd 5658 if (cosangle.gt.1.0d00) then 5659 abc = cosangle - 1.0d00 5660 if (abs(abc).lt.threshcos) cosangle = cosangle - abc 5661 endif 5662 if (cosangle.lt.-1.0d00) then 5663 abc = -1.0d00 - cosangle 5664 if (abs(abc).lt.threshcos) cosangle = cosangle + abc 5665 endif 5666 dihedral = acos(cosangle) 5667 dihedral = dihedral*180.0d00/pi 5668 end 5669 logical function geom_print_distances(geom) 5670 implicit none 5671#include "errquit.fh" 5672c 5673c prints arbitrary i>j atom distances 5674c 5675#include "stdio.fh" 5676#include "inp.fh" 5677c::-functions 5678 logical geom_get_user_units 5679 logical geom_get_user_scale 5680 logical geom_ncent 5681 logical geom_cent_get 5682 logical geom_tag_to_element 5683 logical geom_calc_distance 5684 logical geom_get_def_rcov 5685 external geom_get_user_units 5686 external geom_get_user_scale 5687 external geom_ncent 5688 external geom_cent_get 5689 external geom_tag_to_element 5690 external geom_calc_distance 5691 external geom_get_def_rcov 5692c::-passed 5693 integer geom ! [input] geometry handle 5694c::-local 5695 integer nat ! number of atoms 5696 integer iat ! ith atom 5697 integer jat ! jth atom 5698 double precision chg ! charge (ignored) 5699 double precision ci(3) ! coords of atom i 5700 character*16 tagi ! tag of atom i 5701 double precision cj(3) ! coords of atom j 5702 character*16 tagj ! tag of atom j 5703 logical status_tagi, status_tagj ! return status of call to geom-2-element 5704 integer iatn, jatn ! atomic numbers for atom i and j 5705 character*2 symi, symj ! atomic symbols for atom i and j 5706 character*16 elei, elej ! atomic names for atom i and j 5707 double precision i_rcov, j_rcov ! covalent radii for atom i and j 5708 double precision rcov ! combined covalent radii 5709 double precision rscale ! scale factor 5710 integer lmtag 5711 double precision dij ! distance between atoms i and j 5712 character*10 usr_units ! units user used as input 5713 double precision usr_scale ! unit scale factor 5714 character*128 emsg 5715 integer num_prt 5716 logical header 5717 logical debug 5718 integer ludbg 5719c 5720c 5721 geom_print_distances = .false. 5722 ludbg = 69 5723 debug = .false. 5724 header = .false. 5725 num_prt = 0 5726 rscale = 1.1d00 5727 if (.not.geom_get_user_units(geom,usr_units)) call errquit 5728 & ('geom_print_distances: geom_get_user_units failed',911, 5729 & GEOM_ERR) 5730 if (.not.geom_get_user_scale(geom,usr_scale)) call errquit 5731 & ('geom_print_distances: geom_get_user_scale failed',911, 5732 & GEOM_ERR) 5733 if (.not.geom_ncent(geom,nat)) call errquit 5734 & ('geom_print_distances: geom_ncent failed',911, 5735 & GEOM_ERR) 5736 if (nat.eq.1) then 5737 geom_print_distances = .true. 5738 return 5739 endif 5740 do iat = 1,nat 5741 if (.not.geom_cent_get(geom,iat,tagi,ci,chg)) call errquit 5742 & ('geom_print_distances: geom_cent_get failed:i',911, 5743 & GEOM_ERR) 5744 status_tagi = geom_tag_to_element(tagi,symi,elei,iatn) 5745 if ((symi.eq.'bq').and. 5746 & (.not.status_tagi))status_tagi = .true. 5747 if (.not.status_tagi)call errquit 5748 & ('geom_print_distances:geom_tag_to_element failed:i',911, 5749 & GEOM_ERR) 5750 if (.not.geom_get_def_rcov(iatn,i_rcov)) call errquit 5751 & ('geom_print_distances: geom_get_def_rcov failed atom i', 5752 & 911, GEOM_ERR) 5753 lmtag = inp_strlen(tagi) 5754 do jat = 1,iat 5755 if (iat.ne.jat) then 5756 5757 if (.not.geom_cent_get(geom,jat,tagj,cj,chg)) call errquit 5758 & ('geom_print_distances: geom_cent_get failed:j',911, 5759 & GEOM_ERR) 5760 status_tagj = geom_tag_to_element(tagj,symj,elej,jatn) 5761 if ((symj.eq.'bq').and. 5762 & (.not.status_tagj))status_tagj = .true. 5763 if (.not.status_tagj) call errquit 5764 & ('geom_print_distances:geom_tag_to_element failed:j',911, 5765 & GEOM_ERR) 5766 if (.not.geom_get_def_rcov(jatn,j_rcov)) then 5767 emsg = 'geom_print_distances: '// 5768 & 'geom_get_def_rcov failed atom j' 5769 call errquit(emsg,911, GEOM_ERR) 5770 endif 5771 if (.not.geom_calc_distance(ci,cj,dij)) call errquit 5772 & ('geom_print_distances: ',911, GEOM_ERR) 5773 5774 rcov = rscale*(j_rcov+i_rcov) 5775 if (debug) then 5776 write(ludbg,*)'**************** iat,jat',iat,jat 5777 write(ludbg,*)' rcov ',rcov 5778 write(ludbg,*)' rscale ',rscale 5779 write(ludbg,*)' i_rcov ',i_rcov 5780 write(ludbg,*)' j_rcov ',j_rcov 5781 write(ludbg,10002) 5782 & tagi(1:lmtag),symi,iat, 5783 & tagj(1:lmtag),symj,jat,dij 5784 endif 5785 if ((dij.lt.rcov).or.debug) then 5786 lmtag = max(lmtag,inp_strlen(tagj)) 5787 if (.not.header) then 5788 write(luout,10000)usr_units(1:inp_strlen(usr_units)) 5789 header = .true. 5790 endif 5791 num_prt = num_prt + 1 5792 write(luout,10001) 5793 & iat,tagi, 5794 & jat,tagj, 5795 & dij,(dij/usr_scale) 5796 endif 5797 endif 5798 enddo 5799 enddo 5800 if (header) then 5801 write(luout,10003) 5802 write(luout,10004) num_prt 5803 write(luout,10005) 5804 write(luout,10006) 5805 endif 580610000 format(1x,78('='),/, 5807 & 32x,'internuclear distances',/,1x,78('-'),/, 5808 & 7x,'center one',6x,'|', 5809 & 6x,'center two',6x,'|', 5810 & ' atomic units |',1x,a10, 5811 & /,1x,78('-')) 581210001 format(1x, 5813 & i4,1x,a16,1x,'|', 5814 & i4,1x,a16,1x,'|', 5815 & 1x,f11.5,2x,'|',1x,f11.5) 581610002 format(1x,'debug:distance(', 5817 & a,'|',a2,'|',i4,',', 5818 & a,'|',a2,'|',i4,') =',f12.6) 581910003 format(1x,78('-')) 582010004 format(25x,'number of included internuclear distances: ',i10) 582110005 format(1x,78('=')) 582210006 format(/,/) 5823 geom_print_distances = .true. 5824 end 5825 logical function geom_print_angles(geom) 5826 implicit none 5827#include "errquit.fh" 5828#include "mafdecls.fh" 5829 logical geom_prt_angles 5830 logical geom_ncent 5831 external geom_prt_angles 5832 external geom_ncent 5833 integer geom 5834 integer nat 5835* integer max_netp 5836* parameter (max_netp=24) 5837 integer max_net 5838 integer h_xnet, k_xnet, h_xlist, k_xlist 5839* 5840 if (.not.geom_ncent(geom,nat)) call errquit 5841 & ('geom_print_angles: geom_ncent',911, GEOM_ERR) 5842 5843*24 seems to break max_net = min(max_netp,nat) 5844 max_net = nat 5845 if (.not.ma_push_get(mt_int,(max_net*nat),'p_xnet', 5846 & h_xnet,k_xnet)) call errquit( 5847 & 'geom_print_angles: ma get xnet failed',911, MA_ERR) 5848 5849 if (.not.ma_push_get(mt_int,(nat),'p_xlist', 5850 & h_xlist,k_xlist)) call errquit( 5851 & 'geom_print_angles: ma get xlist failed',911, MA_ERR) 5852 5853 geom_print_angles = 5854 & geom_prt_angles(geom,nat,max_net, 5855 & int_mb(k_xnet),int_mb(k_xlist)) 5856 geom_print_angles = geom_print_angles .and. 5857 & ma_pop_stack(h_xlist) 5858 geom_print_angles = geom_print_angles .and. 5859 & ma_pop_stack(h_xnet) 5860 end 5861 logical function geom_prt_angles(geom,nat,max_net,xnet,xlist) 5862 implicit none 5863#include "errquit.fh" 5864#include "inp.fh" 5865#include "stdio.fh" 5866#include "mafdecls.fh" 5867c::-functions 5868 logical geom_cent_get 5869 logical geom_tag_to_element 5870 logical geom_calc_distance 5871 logical geom_calc_angle 5872 logical geom_get_def_rcov 5873 external geom_cent_get 5874 external geom_tag_to_element 5875 external geom_calc_distance 5876 external geom_calc_angle 5877 external geom_get_def_rcov 5878c::-passed 5879 integer geom ! [input] geometry handle 5880 integer nat ! number of atoms 5881 integer max_net ! maximum number of "connected" atoms for a given atom 5882 integer xlist(nat) 5883 integer xnet(max_net,nat) 5884c::-local 5885 double precision rscale 5886 integer iat ! ith atom 5887 integer jat ! jth atom 5888 integer kat ! kth atom 5889 double precision chg ! charge (ignored) 5890 double precision ci(3) ! coords of atom i 5891 character*16 tagi ! tag of atom i 5892 double precision cj(3) ! coords of atom j 5893 character*16 tagj ! tag of atom j 5894 double precision ck(3) ! coords of atom k 5895 character*16 tagk ! tag of atom k 5896 integer lmtag 5897 double precision dij ! distance between atoms i and j 5898 double precision djk ! distance between atoms j and k 5899 double precision dik ! distance between atoms i and k 5900 double precision angle ! angle to be printed 5901 logical FF, FT ! fortran true and false 5902 integer ngood ! number of sides under threshold 5903 logical dij_okay ! dij under threshold 5904 logical djk_okay ! djk under threshold 5905 logical dik_okay ! dik under threshold 5906 logical print_ijk ! print angle i, j, k 5907 logical print_ikj ! print angle i, k, j 5908 logical print_jik ! print angle j, i, k 5909 logical should_print ! should something be printed? 5910*. . . . . . . . . . . . . . ! return status of call to geom-2-element 5911 logical status_tagi, status_tagj, status_tagk 5912 integer iatn, jatn, katn ! atomic numbers for atom i, j and k 5913 character*2 symi, symj, symk ! atomic symbols for atom i, j and k 5914 character*16 elei, elej, elek ! atomic names for atom i, j and k 5915*. . . . . . . . . . . . . . . . . ! covalent radii for atom i, j and k 5916 character*128 emsg 5917 double precision i_rcov, j_rcov, k_rcov 5918 integer num_prt 5919 integer itmp, jtmp, ktmp 5920 logical header 5921 integer ludbg 5922 logical debug 5923c 5924c initialize variables 5925 ludbg = 69 5926 debug = .false. 5927 header = .false. 5928 rscale = 1.1d00 5929 FF = .false. 5930 FT = .true. 5931 dij_okay = FF 5932 djk_okay = FF 5933 dik_okay = FF 5934 num_prt = 0 5935 5936 geom_prt_angles = FF 5937 if (nat.lt.3) then 5938 geom_prt_angles = FT 5939 return 5940 endif 5941 call ifill((max_net*nat),0,xnet,1) 5942 call ifill(nat,0,xlist,1) 5943 do iat = 1,nat 5944 if (.not.geom_cent_get(geom,iat,tagi,ci,chg)) call errquit 5945 & ('geom_prt_angles: geom_cent_get:i',911, GEOM_ERR) 5946 status_tagi = geom_tag_to_element(tagi,symi,elei,iatn) 5947 if ((symi.eq.'bq').and. 5948 & (.not.status_tagi))status_tagi = .true. 5949 if (.not.status_tagi) call errquit 5950 & ('geom_prt_angles:geom_tag_to_element failed:i',911, 5951 & GEOM_ERR) 5952 if (.not.geom_get_def_rcov(iatn,i_rcov)) call errquit 5953 & ('geom_prt_angles: geom_get_def_rcov failed atom i',911, 5954 & GEOM_ERR) 5955 do jat = 1,nat 5956 5957 if (iat.ne.jat) then 5958 5959 if (.not.geom_cent_get(geom,jat,tagj,cj,chg)) call errquit 5960 & ('geom_prt_angles:geom_cent_get:j ',911, GEOM_ERR) 5961 5962 status_tagj = geom_tag_to_element(tagj,symj,elej,jatn) 5963 if ((symj.eq.'bq').and. 5964 & (.not.status_tagj))status_tagj = .true. 5965 if (.not.status_tagj) call errquit 5966 & ('geom_prt_angles:geom_tag_to_element failed:j',911, 5967 & GEOM_ERR) 5968 if (.not.geom_get_def_rcov(jatn,j_rcov)) call errquit 5969 & ('geom_prt_angles: geom_get_def_rcov failed atom j', 5970 & 911, GEOM_ERR) 5971 if (.not.geom_calc_distance(ci,cj,dij)) call errquit 5972 & ('geom_prt_angles:geom_calc_distance:ij ',911, GEOM_ERR) 5973 5974 if (dij.lt.(rscale*(i_rcov+j_rcov))) then 5975 itmp = xlist(iat) + 1 5976 if(itmp.gt.max_net) call errquit( 5977 & 'geom_prt_angles:max_net is too small ',max_net, 5978 & GEOM_ERR) 5979 xlist(iat) = itmp 5980 xnet(itmp,iat) = jat 5981 endif 5982 endif 5983 enddo 5984 enddo 5985*rak: write(LuOut,*)' xlist: ', xlist 5986*rak: do iat = 1,nat 5987*rak: write(LuOut,*)' xnet: ',iat,':',(xnet(jat,iat),jat=1,max_net) 5988*rak: enddo 5989* 5990 lmtag = 0 5991* 5992 do iat = 1,nat 5993 if (.not.geom_cent_get(geom,iat,tagi,ci,chg)) call errquit 5994 & ('geom_prt_angles: geom_cent_get:i',911, GEOM_ERR) 5995 status_tagi = geom_tag_to_element(tagi,symi,elei,iatn) 5996 if ((symi.eq.'bq').and. 5997 & (.not.status_tagi))status_tagi = .true. 5998 if (.not.status_tagi) call errquit 5999 & ('geom_prt_angles:geom_tag_to_element failed:i',911, 6000 & GEOM_ERR) 6001 if (.not.geom_get_def_rcov(iatn,i_rcov)) call errquit 6002 & ('geom_prt_angles: geom_get_def_rcov failed atom i',911, 6003 & GEOM_ERR) 6004 if (xlist(iat).gt.1) then 6005 do jtmp = 1,xlist(iat) 6006 jat = xnet(jtmp,iat) 6007 if (iat.ne.jat) then 6008 6009 if (.not.geom_cent_get(geom,jat,tagj,cj,chg)) 6010 & call errquit 6011 & ('geom_prt_angles:geom_cent_get:j ',911, GEOM_ERR) 6012 6013 status_tagj = geom_tag_to_element(tagj,symj,elej,jatn) 6014 if ((symj.eq.'bq').and. 6015 & (.not.status_tagj))status_tagj = .true. 6016 if (.not.status_tagj) call errquit 6017 & ('geom_prt_angles:geom_tag_to_element failed:j', 6018 & 911, GEOM_ERR) 6019 if (.not.geom_get_def_rcov(jatn,j_rcov)) call errquit 6020 & ('geom_prt_angles:geom_get_def_rcov fail atom j', 6021 & 911, GEOM_ERR) 6022 if (.not.geom_calc_distance(ci,cj,dij)) call errquit 6023 & ('geom_prt_angles:geom_calc_distance:ij ',911, 6024 & GEOM_ERR) 6025 6026 dij_okay = dij.lt.(rscale*(i_rcov+j_rcov)) 6027 if (dij_okay.or.debug) then 6028 do ktmp = jtmp+1,xlist(iat) 6029 kat = xnet(ktmp,iat) 6030 if (kat.ne.jat.and.kat.ne.iat) then 6031 if (.not.geom_cent_get(geom,kat,tagk,ck,chg)) 6032 & call errquit 6033 & ('geom_prt_angles:geom_cent_get:k ',911, 6034 & GEOM_ERR) 6035 status_tagk = 6036 & geom_tag_to_element(tagk,symk,elek,katn) 6037 if ((symk.eq.'bq').and. 6038 & (.not.status_tagk))status_tagk = .true. 6039 if (.not.status_tagk) then 6040 emsg = 'geom_prt_angles: '// 6041 & 'geom_tag_to_element failed:k' 6042 call errquit(emsg,911, GEOM_ERR) 6043 endif 6044 if (.not.geom_get_def_rcov(katn,k_rcov)) then 6045 emsg = 'geom_prt_angles: '// 6046 & 'geom_egt_def_rcov failed atom k' 6047 call errquit(emsg,911, GEOM_ERR) 6048 endif 6049 lmtag = max(lmtag,inp_strlen(tagk)) 6050 6051 if (.not.geom_calc_distance(ci,ck,dik)) 6052 & call errquit 6053 & ('geom_prt_angles:geom_calc_distance:ik ', 6054 & 911, GEOM_ERR) 6055 if (.not.geom_calc_distance(cj,ck,djk)) 6056 & call errquit 6057 & ('geom_prt_angles:geom_calc_distance:jk ', 6058 & 911, GEOM_ERR) 6059 dik_okay = dik.lt.(rscale*(i_rcov+k_rcov)) 6060 djk_okay = djk.lt.(rscale*(j_rcov+k_rcov)) 6061 ngood = 0 6062 if (dij_okay) ngood = ngood + 1 6063 if (dik_okay) ngood = ngood + 1 6064 if (djk_okay) ngood = ngood + 1 6065 if (debug) then 6066 write(ludbg,*)'**************** iat,jat,kat', 6067 & iat,jat,kat 6068 write(ludbg,*)' ngood : ',ngood 6069 write(ludbg,*)' dij_okay: ',dij_okay 6070 write(ludbg,*)' dik_okay: ',dik_okay 6071 write(ludbg,*)' djk_okay: ',djk_okay 6072 write(ludbg,*)' dij : ',dij 6073 write(ludbg,*)' dik : ',dik 6074 write(ludbg,*)' djk : ',djk 6075 write(ludbg,*)' rij : ', 6076 & rscale*(i_rcov+j_rcov) 6077 write(ludbg,*)' rik : ', 6078 & rscale*(i_rcov+k_rcov) 6079 write(ludbg,*)' rjk : ', 6080 & rscale*(j_rcov+k_rcov) 6081 endif 6082* 6083* ngood is 0 or 1 then atoms too far apart to be interesting 6084* 6085 print_ijk = FF ! a(ijk) = a(kji) 6086 print_ikj = FF ! a(ikj) = a(jki) 6087 print_jik = FF ! a(jik) = a(kji) 6088 if (ngood.eq.2) then 6089* ngood = 2 then only one interesting angle 6090 if (dij_okay.and.dik_okay) then 6091 print_jik = FT ! then angle should be j, i, k 6092 elseif (dij_okay.and.djk_okay) then 6093 print_ijk = FT ! then angle should be i, j, k 6094 elseif (dik_okay.and.djk_okay) then 6095 print_ikj = FT ! then angle should be i, k, j 6096 else 6097 emsg = 'geom_prt_angles: '// 6098 & 'should not get here 1' 6099 call errquit(emsg,911, GEOM_ERR) 6100 endif 6101 elseif (ngood.eq.3) then 6102 6103* if isocoles print angle between equal sides 6104 if (dij.eq.djk) then 6105 print_ijk = FT 6106 else if (dij.eq.dik) then 6107 print_jik = FT 6108 else if (djk.eq.dik) then 6109 print_ikj = FT 6110 6111* print angle with largest value. 6112 else if (dij.gt.djk.and.dij.gt.dik) then 6113 print_ikj = FT 6114 else if (djk.gt.dij.and.djk.gt.dik) then 6115 print_jik = FT 6116 else if (dik.gt.dij.and.dik.gt.djk) then 6117 print_ijk = FT 6118 else 6119 emsg = 'geom_prt_angles: '// 6120 & 'should not get here 2' 6121 call errquit(emsg,911, GEOM_ERR) 6122 endif 6123 endif 6124 should_print = (ngood.eq.2.or.ngood.eq.3) .and. 6125 & (print_ijk.or.print_ikj.or.print_jik) 6126 if (should_print.and.(.not.header)) then 6127 write(luout,10000) 6128 header = .true. 6129 endif 6130 if (print_ijk) then 6131 if (.not.should_print) call errquit( 6132 & 'geom_prt_angles "should_print" error', 6133 & 911, GEOM_ERR) 6134 if (.not.geom_calc_angle(ci,cj,ck,angle)) 6135 & call errquit 6136 & ('geom_prt_angles:geom_calc_angle failed', 6137 & 911, GEOM_ERR) 6138 num_prt =num_prt + 1 6139 write(luout,10001) 6140 & iat, tagi, 6141 & jat, tagj, 6142 & kat, tagk,angle 6143 else if (print_ikj) then 6144 if (.not.should_print) call errquit( 6145 & 'geom_prt_angles "should_print" error', 6146 & 911, GEOM_ERR) 6147 if (.not.geom_calc_angle(ci,ck,cj,angle)) 6148 & call errquit 6149 & ('geom_prt_angles:geom_calc_angle failed', 6150 & 911, GEOM_ERR) 6151 num_prt =num_prt + 1 6152 write(luout,10001) 6153 & iat, tagi, 6154 & kat, tagk, 6155 & jat, tagj,angle 6156 else if (print_jik) then 6157 if (.not.should_print) call errquit( 6158 & 'geom_prt_angles "should_print" error', 6159 & 911, GEOM_ERR) 6160 if (.not.geom_calc_angle(cj,ci,ck,angle)) 6161 & call errquit 6162 & ('geom_prt_angles:geom_calc_angle failed', 6163 & 911, GEOM_ERR) 6164 num_prt =num_prt + 1 6165 write(luout,10001) 6166 & jat, tagj, 6167 & iat, tagi, 6168 & kat, tagk,angle 6169 endif 6170 endif 6171 enddo 6172 endif 6173 endif 6174 enddo 6175 endif 6176 enddo 6177 if (header) then 6178 write(luout,10002) 6179 write(luout,10003) num_prt 6180 write(luout,10004) 6181 write(luout,10005) 6182 endif 618310000 format(1x,78('='),/, 6184 & 33x,'internuclear angles',/,1x,78('-'),/, 6185 & 8x,'center 1',7x,'|', 6186 & 7x,'center 2',7x,'|', 6187 & 7x,'center 3',7x,'|', 6188 & ' degrees', 6189 & /,1x,78('-')) 619010001 format(1x, 6191 & i4,1x,a16,1x,'|', 6192 & i4,1x,a16,1x,'|', 6193 & i4,1x,a16,1x,'|', 6194 & 1x,f8.2) 619510002 format(1x,78('-')) 619610003 format(28x,'number of included internuclear angles: ',i10) 619710004 format(1x,78('=')) 619810005 format(/,/) 6199 geom_prt_angles = FT 6200 end 6201*B4-xnet: logical function geom_print_angles(geom) 6202*B4-xnet: implicit none 6203*B4-xnet:#include "errquit.fh" 6204*B4-xnet:#include "inp.fh" 6205*B4-xnet:#include "stdio.fh" 6206*B4-xnet:c::-functions 6207*B4-xnet: logical geom_calc_distance 6208*B4-xnet: external geom_calc_distance 6209*B4-xnet: logical geom_calc_angle 6210*B4-xnet: external geom_calc_angle 6211*B4-xnet: logical geom_get_def_rcov 6212*B4-xnet: external geom_get_def_rcov 6213*B4-xnet:c::-passed 6214*B4-xnet: integer geom ! [input] geometry handle 6215*B4-xnet:c::-local 6216*B4-xnet: double precision rscale 6217*B4-xnet: integer nat ! number of atoms 6218*B4-xnet: integer iat ! ith atom 6219*B4-xnet: integer jat ! jth atom 6220*B4-xnet: integer kat ! kth atom 6221*B4-xnet: double precision chg ! charge (ignored) 6222*B4-xnet: double precision ci(3) ! coords of atom i 6223*B4-xnet: character*16 tagi ! tag of atom i 6224*B4-xnet: double precision cj(3) ! coords of atom j 6225*B4-xnet: character*16 tagj ! tag of atom j 6226*B4-xnet: double precision ck(3) ! coords of atom k 6227*B4-xnet: character*16 tagk ! tag of atom k 6228*B4-xnet: integer lmtag 6229*B4-xnet: double precision dij ! distance between atoms i and j 6230*B4-xnet: double precision djk ! distance between atoms j and k 6231*B4-xnet: double precision dik ! distance between atoms i and k 6232*B4-xnet: double precision angle ! angle to be printed 6233*B4-xnet: logical FF, FT ! fortran true and false 6234*B4-xnet: integer ngood ! number of sides under threshold 6235*B4-xnet: logical dij_okay ! dij under threshold 6236*B4-xnet: logical djk_okay ! djk under threshold 6237*B4-xnet: logical dik_okay ! dik under threshold 6238*B4-xnet: logical print_ijk ! print angle i, j, k 6239*B4-xnet: logical print_ikj ! print angle i, k, j 6240*B4-xnet: logical print_jik ! print angle j, i, k 6241*B4-xnet: logical should_print ! should something be printed? 6242*B4-xnet:*. . . . . . . . . . . . . . ! return status of call to geom-2-element 6243*B4-xnet: logical status_tagi, status_tagj, status_tagk 6244*B4-xnet: integer iatn, jatn, katn ! atomic numbers for atom i, j and k 6245*B4-xnet: character*2 symi, symj, symk ! atomic symbols for atom i, j and k 6246*B4-xnet: character*16 elei, elej, elek ! atomic names for atom i, j and k 6247*B4-xnet:*. . . . . . . . . . . . . . . . . ! covalent radii for atom i, j and k 6248*B4-xnet: character*128 emsg 6249*B4-xnet: double precision i_rcov, j_rcov, k_rcov 6250*B4-xnet: integer num_prt 6251*B4-xnet: logical header 6252*B4-xnet: integer ludbg 6253*B4-xnet: logical debug 6254*B4-xnet:c 6255*B4-xnet:c initialize variables 6256*B4-xnet: ludbg = 69 6257*B4-xnet: debug = .false. 6258*B4-xnet: header = .false. 6259*B4-xnet: rscale = 1.1d00 6260*B4-xnet: FF = .false. 6261*B4-xnet: FT = .true. 6262*B4-xnet: dij_okay = FF 6263*B4-xnet: djk_okay = FF 6264*B4-xnet: dik_okay = FF 6265*B4-xnet: num_prt = 0 6266*B4-xnet: 6267*B4-xnet: if (.not.geom_ncent(geom,nat)) call errquit 6268*B4-xnet: & ('geom_print_angles: geom_ncent',911, GEOM_ERR) 6269*B4-xnet: 6270*B4-xnet: if (nat.lt.3) then 6271*B4-xnet: geom_print_angles = FT 6272*B4-xnet: return 6273*B4-xnet: endif 6274*B4-xnet: do iat = 1,nat 6275*B4-xnet: if (.not.geom_cent_get(geom,iat,tagi,ci,chg)) call errquit 6276*B4-xnet: & ('geom_print_angles: geom_cent_get:i',911, GEOM_ERR) 6277*B4-xnet: status_tagi = geom_tag_to_element(tagi,symi,elei,iatn) 6278*B4-xnet: if ((symi.eq.'bq').and. 6279*B4-xnet: & (.not.status_tagi))status_tagi = .true. 6280*B4-xnet: if (.not.status_tagi) call errquit 6281*B4-xnet: & ('geom_print_angles:geom_tag_to_element failed:i',911, 6282* & GEOM_ERR) 6283*B4-xnet: if (.not.geom_get_def_rcov(iatn,i_rcov)) call errquit 6284*B4-xnet: & ('geom_print_angles: geom_get_def_rcov failed atom i',911, 6285* & GEOM_ERR) 6286*B4-xnet: 6287*B4-xnet: lmtag = inp_strlen(tagi) 6288*B4-xnet: do jat = 1,nat 6289*B4-xnet: if (iat.ne.jat) then 6290*B4-xnet: 6291*B4-xnet: if (.not.geom_cent_get(geom,jat,tagj,cj,chg)) call errquit 6292*B4-xnet: & ('geom_print_angles:geom_cent_get:j ',911) 6293*B4-xnet: 6294*B4-xnet: status_tagj = geom_tag_to_element(tagj,symj,elej,jatn) 6295*B4-xnet: if ((symj.eq.'bq').and. 6296*B4-xnet: & (.not.status_tagj))status_tagj = .true. 6297*B4-xnet: if (.not.status_tagj) call errquit 6298*B4-xnet: & ('geom_print_angles:geom_tag_to_element failed:j',911) 6299*B4-xnet: if (.not.geom_get_def_rcov(jatn,j_rcov)) call errquit 6300*B4-xnet: & ('geom_print_angles: geom_get_def_rcov failed atom j', 6301*B4-xnet: & 911) 6302*B4-xnet: lmtag = max(lmtag,inp_strlen(tagj)) 6303*B4-xnet: if (.not.geom_calc_distance(ci,cj,dij)) call errquit 6304*B4-xnet: & ('geom_print_angles:geom_calc_distance:ij ',911) 6305*B4-xnet: 6306*B4-xnet: dij_okay = dij.lt.(rscale*(i_rcov+j_rcov)) 6307*B4-xnet: if (dij_okay.or.debug) then 6308*B4-xnet: do kat = 1,min(iat,jat) 6309*B4-xnet: if (kat.ne.jat.and.kat.ne.iat) then 6310*B4-xnet: if (.not.geom_cent_get(geom,kat,tagk,ck,chg)) 6311*B4-xnet: & call errquit 6312*B4-xnet: & ('geom_print_angles:geom_cent_get:k ',911) 6313*B4-xnet: status_tagk = 6314*B4-xnet: & geom_tag_to_element(tagk,symk,elek,katn) 6315*B4-xnet: if ((symk.eq.'bq').and. 6316*B4-xnet: & (.not.status_tagk))status_tagk = .true. 6317*B4-xnet: if (.not.status_tagk) then 6318*B4-xnet: emsg = 'geom_print_angles: '// 6319*B4-xnet: & 'geom_tag_to_element failed:k' 6320*B4-xnet: call errquit(emsg,911) 6321*B4-xnet: endif 6322*B4-xnet: if (.not.geom_get_def_rcov(katn,k_rcov)) then 6323*B4-xnet: emsg = 'geom_print_angles: '// 6324*B4-xnet: & 'geom_egt_def_rcov failed atom k' 6325*B4-xnet: call errquit(emsg,911) 6326*B4-xnet: endif 6327*B4-xnet: lmtag = max(lmtag,inp_strlen(tagk)) 6328*B4-xnet: 6329*B4-xnet: if (.not.geom_calc_distance(ci,ck,dik)) call errquit 6330*B4-xnet: & ('geom_print_angles:geom_calc_distance:ik ',911) 6331*B4-xnet: if (.not.geom_calc_distance(cj,ck,djk)) call errquit 6332*B4-xnet: & ('geom_print_angles:geom_calc_distance:jk ',911) 6333*B4-xnet: dik_okay = dik.lt.(rscale*(i_rcov+k_rcov)) 6334*B4-xnet: djk_okay = djk.lt.(rscale*(j_rcov+k_rcov)) 6335*B4-xnet: ngood = 0 6336*B4-xnet: if (dij_okay) ngood = ngood + 1 6337*B4-xnet: if (dik_okay) ngood = ngood + 1 6338*B4-xnet: if (djk_okay) ngood = ngood + 1 6339*B4-xnet: if (debug) then 6340*B4-xnet: write(ludbg,*)'**************** iat,jat,kat', 6341*B4-xnet: & iat,jat,kat 6342*B4-xnet: write(ludbg,*)' ngood : ',ngood 6343*B4-xnet: write(ludbg,*)' dij_okay: ',dij_okay 6344*B4-xnet: write(ludbg,*)' dik_okay: ',dik_okay 6345*B4-xnet: write(ludbg,*)' djk_okay: ',djk_okay 6346*B4-xnet: write(ludbg,*)' dij : ',dij 6347*B4-xnet: write(ludbg,*)' dik : ',dik 6348*B4-xnet: write(ludbg,*)' djk : ',djk 6349*B4-xnet: write(ludbg,*)' rij : ',rscale*(i_rcov+j_rcov) 6350*B4-xnet: write(ludbg,*)' rik : ',rscale*(i_rcov+k_rcov) 6351*B4-xnet: write(ludbg,*)' rjk : ',rscale*(j_rcov+k_rcov) 6352*B4-xnet: endif 6353*B4-xnet:* 6354*B4-xnet:* ngood is 0 or 1 then atoms too far apart to be interesting 6355*B4-xnet:* 6356*B4-xnet: print_ijk = FF ! a(ijk) = a(kji) 6357*B4-xnet: print_ikj = FF ! a(ikj) = a(jki) 6358*B4-xnet: print_jik = FF ! a(jik) = a(kji) 6359*B4-xnet: if (ngood.eq.2) then 6360*B4-xnet:* ngood = 2 then only one interesting angle 6361*B4-xnet: if (dij_okay.and.dik_okay) then 6362*B4-xnet: print_jik = FT ! then angle should be j, i, k 6363*B4-xnet: elseif (dij_okay.and.djk_okay) then 6364*B4-xnet: print_ijk = FT ! then angle should be i, j, k 6365*B4-xnet: elseif (dik_okay.and.djk_okay) then 6366*B4-xnet: print_ikj = FT ! then angle should be i, k, j 6367*B4-xnet: else 6368*B4-xnet: emsg = 'geom_print_angles: '// 6369*B4-xnet: & 'should not get here 1' 6370*B4-xnet: call errquit(emsg,911) 6371*B4-xnet: endif 6372*B4-xnet: elseif (ngood.eq.3) then 6373*B4-xnet: 6374*B4-xnet:* if isocoles print angle between equal sides 6375*B4-xnet: if (dij.eq.djk) then 6376*B4-xnet: print_ijk = FT 6377*B4-xnet: else if (dij.eq.dik) then 6378*B4-xnet: print_jik = FT 6379*B4-xnet: else if (djk.eq.dik) then 6380*B4-xnet: print_ikj = FT 6381*B4-xnet: 6382*B4-xnet:* print angle with largest value. 6383*B4-xnet: else if (dij.gt.djk.and.dij.gt.dik) then 6384*B4-xnet: print_ikj = FT 6385*B4-xnet: else if (djk.gt.dij.and.djk.gt.dik) then 6386*B4-xnet: print_jik = FT 6387*B4-xnet: else if (dik.gt.dij.and.dik.gt.djk) then 6388*B4-xnet: print_ijk = FT 6389*B4-xnet: else 6390*B4-xnet: emsg = 'geom_print_angles: '// 6391*B4-xnet: & 'should not get here 2' 6392*B4-xnet: call errquit(emsg,911) 6393*B4-xnet: endif 6394*B4-xnet: endif 6395*B4-xnet: should_print = (ngood.eq.2.or.ngood.eq.3) .and. 6396*B4-xnet: & (print_ijk.or.print_ikj.or.print_jik) 6397*B4-xnet: if (should_print.and.(.not.header)) then 6398*B4-xnet: write(luout,10000) 6399*B4-xnet: header = .true. 6400*B4-xnet: endif 6401*B4-xnet: if (print_ijk) then 6402*B4-xnet: if (.not.should_print) call errquit( 6403*B4-xnet: & 'geom_print_angles "should_print" error',911) 6404*B4-xnet: if (.not.geom_calc_angle(ci,cj,ck,angle)) 6405*B4-xnet: & call errquit 6406*B4-xnet: & ('geom_print_angles:geom_calc_angle failed', 6407*B4-xnet: & 911) 6408*B4-xnet: num_prt =num_prt + 1 6409*B4-xnet: write(luout,10001)num_prt, 6410*B4-xnet: & iat, tagi, 6411*B4-xnet: & jat, tagj, 6412*B4-xnet: & kat, tagk,angle 6413*B4-xnet: else if (print_ikj) then 6414*B4-xnet: if (.not.should_print) call errquit( 6415*B4-xnet: & 'geom_print_angles "should_print" error',911) 6416*B4-xnet: if (.not.geom_calc_angle(ci,ck,cj,angle)) 6417*B4-xnet: & call errquit 6418*B4-xnet: & ('geom_print_angles:geom_calc_angle failed', 6419*B4-xnet: & 911) 6420*B4-xnet: num_prt =num_prt + 1 6421*B4-xnet: write(luout,10001)num_prt, 6422*B4-xnet: & iat, tagi, 6423*B4-xnet: & kat, tagk, 6424*B4-xnet: & jat, tagj,angle 6425*B4-xnet: else if (print_jik) then 6426*B4-xnet: if (.not.should_print) call errquit( 6427*B4-xnet: & 'geom_print_angles "should_print" error',911) 6428*B4-xnet: if (.not.geom_calc_angle(cj,ci,ck,angle)) 6429*B4-xnet: & call errquit 6430*B4-xnet: & ('geom_print_angles:geom_calc_angle failed', 6431*B4-xnet: & 911) 6432*B4-xnet: num_prt =num_prt + 1 6433*B4-xnet: write(luout,10001)num_prt, 6434*B4-xnet: & jat, tagj, 6435*B4-xnet: & iat, tagi, 6436*B4-xnet: & kat, tagk,angle 6437*B4-xnet: endif 6438*B4-xnet: endif 6439*B4-xnet: enddo 6440*B4-xnet: endif 6441*B4-xnet: endif 6442*B4-xnet: enddo 6443*B4-xnet: enddo 6444*B4-xnet: if (header) write(luout,10002) 6445*B4-xnet:10000 format(1x,86('='),/, 6446*B4-xnet: & 33x,'internuclear angles',/,1x,86('-'),/, 6447*B4-xnet: & 1x,'count |', 6448*B4-xnet: & 7x,'center 1',7x,'|', 6449*B4-xnet: & 7x,'center 2',7x,'|', 6450*B4-xnet: & 7x,'center 3',7x,'|', 6451*B4-xnet: & ' degrees', 6452*B4-xnet: & /,1x,86('-')) 6453*B4-xnet:10001 format(1x,i5,1x,'|', 6454*B4-xnet: & i4,1x,a16,1x,'|', 6455*B4-xnet: & i4,1x,a16,1x,'|', 6456*B4-xnet: & i4,1x,a16,1x,'|', 6457*B4-xnet: & 1x,f8.2) 6458*B4-xnet:10002 format(1x,86('='),/,/) 6459*B4-xnet: geom_print_angles = FT 6460*B4-xnet: end 6461 logical function geom_print_dihedrals(geom) 6462 implicit none 6463#include "errquit.fh" 6464#include "mafdecls.fh" 6465 logical geom_ncent 6466 logical geom_prt_dihedrals 6467 external geom_ncent 6468 external geom_prt_dihedrals 6469 integer geom 6470 integer nat 6471** integer max_netp 6472** parameter (max_netp=24) 6473 integer max_net 6474 integer h_xnet, k_xnet, h_xlist, k_xlist 6475* 6476 if (.not.geom_ncent(geom,nat)) call errquit 6477 & ('geom_print_dihedrals: geom_ncent',911, GEOM_ERR) 6478 6479* 24 seems to break max_net = min(max_netp,nat) 6480 max_net = nat 6481 if (.not.ma_push_get(mt_int,(max_net*nat),'p_xnet', 6482 & h_xnet,k_xnet)) call errquit( 6483 & 'geom_print_dihedrals: ma get xnet failed',911, MA_ERR) 6484 6485 if (.not.ma_push_get(mt_int,(nat),'p_xlist', 6486 & h_xlist,k_xlist)) call errquit( 6487 & 'geom_print_dihedrals: ma get xlist failed',911, MA_ERR) 6488 6489 geom_print_dihedrals = 6490 & geom_prt_dihedrals(geom,nat,max_net, 6491 & int_mb(k_xnet),int_mb(k_xlist)) 6492 geom_print_dihedrals = geom_print_dihedrals .and. 6493 & ma_pop_stack(h_xlist) 6494 geom_print_dihedrals = geom_print_dihedrals .and. 6495 & ma_pop_stack(h_xnet) 6496 end 6497 logical function geom_prt_dihedrals(geom,nat,max_net,xnet,xlist) 6498 implicit none 6499#include "errquit.fh" 6500#include "mafdecls.fh" 6501#include "stdio.fh" 6502#include "inp.fh" 6503c::-functions 6504 logical geom_calc_distance 6505 logical geom_calc_dihedral 6506 logical geom_get_def_rcov 6507 logical geom_cent_get 6508 logical geom_tag_to_element 6509 external geom_calc_distance 6510 external geom_calc_dihedral 6511 external geom_get_def_rcov 6512 external geom_cent_get 6513 external geom_tag_to_element 6514c::-passed 6515 integer geom ! [input] geometry handle 6516 integer nat ! number of atoms 6517 integer max_net 6518 integer xlist(nat), xnet(max_net,nat) 6519c::-local 6520 double precision rscale, tscale 6521 integer iat ! ith atom 6522 integer jat ! jth atom 6523 integer kat ! kth atom 6524 integer lat ! lth atom 6525 integer ipat,jpat,kpat,lpat 6526 double precision chg ! charge (ignored) 6527 double precision ci(3),pci(3) ! coords of atom i 6528 character*16 tagi ! tag of atom i 6529 character*8 ptagi ! tag of atom i 6530 double precision cj(3),pcj(3) ! coords of atom j 6531 character*16 tagj ! tag of atom j 6532 character*8 ptagj ! tag of atom j 6533 double precision ck(3),pck(3) ! coords of atom k 6534 character*16 tagk ! tag of atom k 6535 character*8 ptagk ! tag of atom k 6536 double precision cl(3),pcl(3) ! coords of atom k 6537 character*16 tagl ! tag of atom k 6538 character*8 ptagl ! tag of atom k 6539* double precision c_all(3,4) ! all coords 6540* double precision dall(6) ! all distances 6541 double precision dij ! distance between atoms i and j 6542 double precision dik ! distance between atoms i and k 6543 double precision dil ! distance between atoms i and l 6544 double precision djk ! distance between atoms j and k 6545 double precision djl ! distance between atoms j and l 6546 double precision dkl ! distance between atoms k and l 6547 double precision diangle ! dihedral angle to be printed 6548 logical FF, FT ! fortran true and false 6549 logical dij_okay ! dij under threshold 6550 logical dik_okay ! dik under threshold 6551 logical dil_okay ! dil under threshold 6552 logical djk_okay ! djk under threshold 6553 logical djl_okay ! djl under threshold 6554 logical dkl_okay ! dkl under threshold 6555*rak: logical all_okay 6556 logical switch_jk 6557c 6558 logical status_tagi, status_tagj, status_tagk, status_tagl 6559 character*2 symi, symj, symk, syml 6560 character*16 elei, elej, elek, elel 6561 integer iatn, jatn, katn, latn 6562 integer itmp, jtmp, ktmp, ltmp 6563 double precision i_rcov, j_rcov, k_rcov, l_rcov 6564c 6565* integer ngood 6566 integer num_pos 6567 integer num_prt 6568 logical header 6569* 6570 FF = .false. 6571 FT = .true. 6572 num_pos = nat*(nat-1)*(nat-2)*(nat-3)/24 6573 geom_prt_dihedrals = FF 6574 if (nat.lt.4) then 6575 geom_prt_dihedrals = FT 6576 return 6577 endif 6578c initialize variables 6579 rscale = 1.1d00 6580 tscale = 1.1d00 6581 dij_okay = FF ! dij under threshold 6582 dik_okay = FF ! dik under threshold 6583 dil_okay = FF ! dil under threshold 6584 djk_okay = FF ! djk under threshold 6585 djl_okay = FF ! djl under threshold 6586 dkl_okay = FF ! dkl under threshold 6587 header = FF 6588 num_prt = 0 6589c 6590 call ifill((max_net*nat),0,xnet,1) 6591 call ifill(nat,0,xlist,1) 6592 do iat = 1,nat 6593 if (.not.geom_cent_get(geom,iat,tagi,ci,chg)) call errquit 6594 & ('geom_prt_angles: geom_cent_get:i',911, GEOM_ERR) 6595 status_tagi = geom_tag_to_element(tagi,symi,elei,iatn) 6596 if ((symi.eq.'bq').and. 6597 & (.not.status_tagi))status_tagi = .true. 6598 if (.not.status_tagi) call errquit 6599 & ('geom_prt_angles:geom_tag_to_element failed:i',911, 6600 & GEOM_ERR) 6601 if (.not.geom_get_def_rcov(iatn,i_rcov)) call errquit 6602 & ('geom_prt_angles: geom_get_def_rcov failed atom i',911, 6603 & GEOM_ERR) 6604 do jat = 1,nat 6605 6606 if (iat.ne.jat) then 6607 6608 if (.not.geom_cent_get(geom,jat,tagj,cj,chg)) call errquit 6609 & ('geom_prt_angles:geom_cent_get:j ',911, GEOM_ERR) 6610 6611 status_tagj = geom_tag_to_element(tagj,symj,elej,jatn) 6612 if ((symj.eq.'bq').and. 6613 & (.not.status_tagj))status_tagj = .true. 6614 if (.not.status_tagj) call errquit 6615 & ('geom_prt_angles:geom_tag_to_element failed:j',911, 6616 & GEOM_ERR) 6617 if (.not.geom_get_def_rcov(jatn,j_rcov)) call errquit 6618 & ('geom_prt_angles: geom_get_def_rcov failed atom j', 6619 & 911, GEOM_ERR) 6620 if (.not.geom_calc_distance(ci,cj,dij)) call errquit 6621 & ('geom_prt_angles:geom_calc_distance:ij ',911, GEOM_ERR) 6622 6623 if (dij.lt.(rscale*(i_rcov+j_rcov))) then 6624 itmp = xlist(iat) + 1 6625 if(itmp.gt.max_net) call errquit( 6626 & 'geom_prt_angles:max_net is too small ',max_net, 6627 & GEOM_ERR) 6628 xlist(iat) = itmp 6629 xnet(itmp,iat) = jat 6630 endif 6631 endif 6632 enddo 6633 enddo 6634*rak: write(LuOut,*)' xlist: ', xlist 6635*rak: do iat = 1,nat 6636*rak: write(LuOut,*)' xnet: ',iat,':',(xnet(jat,iat),jat=1,max_net) 6637*rak: enddo 6638*rak: write(LuOut,*)'b4 dih loop' 6639*rak: itmp = 0 6640*rak: do iat = 1,nat 6641*rak: do jtmp = 1,xlist(iat) 6642*rak: jat = xnet(jtmp,iat) 6643*rak: if (iat.ne.jat) then 6644*rak: do ktmp = jtmp+1,xlist(iat) 6645*rak: kat = xnet(ktmp,iat) 6646*rak: if (kat.ne.jat.and.kat.ne.iat) then 6647*rak: do ltmp = ktmp + 1,xlist(iat) 6648*rak: lat = xnet(ltmp,iat) 6649*rak: if (lat.ne.kat.and.lat.ne.jat.and.lat.ne.iat) then 6650*rak: itmp = itmp + 1 6651*rak: write(LuOut,*)'dihang:i: ',itmp,':',iat,jat,kat,lat 6652*rak: endif 6653*rak: enddo 6654*rak:*rak: do ltmp = 1,xlist(jat) 6655*rak:*rak: lat = xnet(ltmp,jat) 6656*rak:*rak: if (lat.ne.kat.and.lat.ne.jat.and.lat.ne.iat) then 6657*rak:*rak: itmp = itmp + 1 6658*rak:*rak: write(LuOut,*)'dihang:j: ',itmp,':',iat,jat,kat,lat 6659*rak:*rak: endif 6660*rak:*rak: enddo 6661*rak: do ltmp = 1,xlist(kat) 6662*rak: lat = xnet(ltmp,kat) 6663*rak: if (lat.ne.kat.and.lat.ne.jat.and.lat.ne.iat) then 6664*rak: itmp = itmp + 1 6665*rak: write(LuOut,*)'dihang:k: ',itmp,':',iat,jat,kat,lat 6666*rak: endif 6667*rak: enddo 6668*rak: endif 6669*rak: enddo 6670*rak: endif 6671*rak: enddo 6672*rak: enddo 6673*rak: write(LuOut,*)'after dih loop' 6674 do iat = 1,nat 6675 if (.not.geom_cent_get(geom,iat,tagi,ci,chg)) call errquit 6676 & ('geom_prt_dihedrals:geom_cent_get:i ',911, GEOM_ERR) 6677 status_tagi = geom_tag_to_element(tagi,symi,elei,iatn) 6678 if ((symi.eq.'bq').and.(.not.status_tagi)) 6679 & status_tagi = FT 6680 if (.not.status_tagi) call errquit 6681 & ('geom_prt_dihedrals:tag2element failed:i',911, GEOM_ERR) 6682 if (.not.geom_get_def_rcov(iatn,i_rcov)) call errquit 6683 & ('geom_prt_dihedrals:defrcov failed:i',911, GEOM_ERR) 6684 do jtmp = 1,xlist(iat) 6685 jat = xnet(jtmp,iat) 6686 if (iat.ne.jat) then 6687 if (.not.geom_cent_get(geom,jat,tagj,cj,chg)) call errquit 6688 & ('geom_prt_dihedrals:geom_cent_get:j ',911, GEOM_ERR) 6689 status_tagj = geom_tag_to_element(tagj,symj,elej,jatn) 6690 if ((symj.eq.'bq').and.(.not.status_tagj)) 6691 & status_tagj = FT 6692 if (.not.status_tagj) call errquit 6693 & ('geom_prt_dihedrals:tag2element failed:j',911, 6694 & GEOM_ERR) 6695 if (.not.geom_get_def_rcov(jatn,j_rcov)) call errquit 6696 & ('geom_prt_dihedrals:defrcov failed:j',911, GEOM_ERR) 6697 6698 if (.not.geom_calc_distance(ci,cj,dij)) call errquit 6699 & ('geom_prt_dihedrals:geom_calc_distance:ij ',911, 6700 & GEOM_ERR) 6701 6702 dij_okay = dij.lt.(rscale*(i_rcov+j_rcov)) 6703 if (dij_okay) then 6704 do ktmp = jtmp+1,xlist(iat) 6705 kat = xnet(ktmp,iat) 6706 if (kat.ne.jat.and.kat.ne.iat) then 6707 if (.not.geom_cent_get(geom,kat,tagk,ck,chg)) 6708 & call errquit 6709 & ('geom_prt_dihedrals:geom_cent_get:k ',911, 6710 & GEOM_ERR) 6711 status_tagk = 6712 & geom_tag_to_element(tagk,symk,elek,katn) 6713 if ((symk.eq.'bq').and.(.not.status_tagk)) 6714 & status_tagk = FT 6715 if (.not.status_tagk) call errquit 6716 & ('geom_prt_dihedrals:tag2element failed:k', 6717 & 911, GEOM_ERR) 6718 if (.not.geom_get_def_rcov(katn,k_rcov)) 6719 & call errquit 6720 & ('geom_prt_dihedrals:defrcov failed:k',911, 6721 & GEOM_ERR) 6722 6723 if (.not.geom_calc_distance(ci,ck,dik)) call errquit 6724 & ('geom_prt_dihedrals:geom_calc_distance:ik ', 6725 & 911, GEOM_ERR) 6726 if (.not.geom_calc_distance(cj,ck,djk)) call errquit 6727 & ('geom_prt_dihedrals:geom_calc_distance:jk ', 6728 & 911, GEOM_ERR) 6729 6730 dik_okay = dik.lt.(rscale*(i_rcov+k_rcov)) 6731 djk_okay = djk.lt.(rscale*(j_rcov+k_rcov)) 6732 switch_jk = dik.lt.dij.and.dik_okay 6733 do ltmp = ktmp + 1,xlist(iat) 6734 lat = xnet(ltmp,iat) 6735 if (lat.ne.kat.and. 6736 & lat.ne.jat.and.lat.ne.iat) then 6737 if (.not.geom_cent_get(geom,lat,tagl,cl,chg)) 6738 & call errquit 6739 & ('geom_prt_dihedrals:geom_cent_get:l ', 6740 & 911, GEOM_ERR) 6741 status_tagl = 6742 & geom_tag_to_element(tagl,syml,elel,latn) 6743 if ((syml.eq.'bq').and.(.not.status_tagl)) 6744 & status_tagl = FT 6745 if (.not.status_tagl) call errquit 6746 & ('geom_prt_dihedrals:tag2elmnt fail:l', 6747 & 911, GEOM_ERR) 6748 if (.not.geom_get_def_rcov(latn,l_rcov)) 6749 & call errquit 6750 & ('geom_prt_dihedrals:defrcov fail:l', 6751 & 911, GEOM_ERR) 6752 6753 if (.not.geom_calc_distance(ci,cl,dil)) 6754 & call errquit 6755 & ('geom_prt_dihedrals:calc_distance:il', 6756 & 911, GEOM_ERR) 6757 if (.not.geom_calc_distance(cj,cl,djl)) 6758 & call errquit 6759 & ('geom_prt_dihedrals:calc_distance:jl', 6760 & 911, GEOM_ERR) 6761 if (.not.geom_calc_distance(ck,cl,dkl)) 6762 & call errquit 6763 & ('geom_prt_dihedrals:calc_distance:kl', 6764 & 911, GEOM_ERR) 6765 dil_okay = dil.lt.(rscale*(i_rcov+l_rcov)) 6766 djl_okay = djl.lt. 6767 & (tscale*rscale*(j_rcov+l_rcov)) 6768 dkl_okay = dkl.lt. 6769 & (tscale*rscale*(k_rcov+l_rcov)) 6770 num_prt = num_prt + 1 6771 ipat = lat 6772 jpat = iat 6773 call dcopy(3,cl,1,pci,1) 6774 call dcopy(3,ci,1,pcj,1) 6775 ptagi = tagl 6776 ptagj = tagi 6777 if (switch_jk) then 6778 kpat = kat 6779 lpat = jat 6780 call dcopy(3,ck,1,pck,1) 6781 call dcopy(3,cj,1,pcl,1) 6782 ptagk = tagk 6783 ptagl = tagj 6784 else 6785 kpat = jat 6786 lpat = kat 6787 call dcopy(3,cj,1,pck,1) 6788 call dcopy(3,ck,1,pcl,1) 6789 ptagk = tagj 6790 ptagl = tagk 6791 endif 6792 if (.not.geom_calc_dihedral 6793 & (pci,pcj,pck,pcl,diangle)) call errquit 6794 & ('geom_print_dih:geom_calc_dih death', 6795 & 911, GEOM_ERR) 6796 if (.not.header) then 6797 write(luout,10000) 6798 header = FT 6799 endif ! .not.header 6800 write(luout,10001) 6801 & ipat,ptagi,jpat,ptagj, 6802 & kpat,ptagk,lpat,ptagl, 6803 & diangle 6804*rak: write(LuOut,*)'i',pci 6805*rak: write(LuOut,*)'j',pcj 6806*rak: write(LuOut,*)'k',pck 6807*rak: write(LuOut,*)'l',pcl 6808*rak: write(LuOut,*)'dihang::i::',num_prt,':', 6809*rak: & ipat,jpat,kpat,lpat,diangle 6810 endif 6811 enddo 6812*rak: do ltmp = 1,xlist(jat) 6813*rak: lat = xnet(ltmp,jat) 6814*rak: if (lat.ne.kat.and. 6815*rak: & lat.ne.jat.and.lat.ne.iat) then 6816*rak: if (.not.geom_cent_get(geom,lat,tagl,cl,chg)) 6817*rak: & call errquit 6818*rak: & ('geom_prt_dihedrals:geom_cent_get:l ', 6819*rak: & 911) 6820*rak: status_tagl = 6821*rak: & geom_tag_to_element(tagl,syml,elel,latn) 6822*rak: if ((syml.eq.'bq').and.(.not.status_tagl)) 6823*rak: & status_tagl = FT 6824*rak: if (.not.status_tagl) call errquit 6825*rak: & ('geom_prt_dihedrals:tag2elmnt fail:l', 6826*rak: & 911) 6827*rak: if (.not.geom_get_def_rcov(latn,l_rcov)) 6828*rak: & call errquit 6829*rak: & ('geom_prt_dihedrals:defrcov fail:l', 6830*rak: & 911) 6831*rak: 6832*rak: if (.not.geom_calc_distance(ci,cl,dil)) 6833*rak: & call errquit 6834*rak: & ('geom_prt_dihedrals:calc_distance:il', 6835*rak: & 911) 6836*rak: if (.not.geom_calc_distance(cj,cl,djl)) 6837*rak: & call errquit 6838*rak: & ('geom_prt_dihedrals:calc_distance:jl', 6839*rak: & 911) 6840*rak: if (.not.geom_calc_distance(ck,cl,dkl)) 6841*rak: & call errquit 6842*rak: & ('geom_prt_dihedrals:calc_distance:kl', 6843*rak: & 911) 6844*rak: dil_okay = dil.lt.(rscale*(i_rcov+l_rcov)) 6845*rak: djl_okay = djl.lt. 6846*rak: & (tscale*rscale*(j_rcov+l_rcov)) 6847*rak: dkl_okay = dkl.lt. 6848*rak: & (tscale*rscale*(k_rcov+l_rcov)) 6849*rak: num_prt = num_prt + 1 6850*rak: ipat = iat 6851*rak: call dcopy(3,ci,1,pci,1) 6852*rak: ptagi = tagi 6853*rak: if (switch_jk) then 6854*rak: jpat = kat 6855*rak: kpat = jat 6856*rak: lpat = lat 6857*rak: call dcopy(3,ck,1,pcj,1) 6858*rak: call dcopy(3,cj,1,pck,1) 6859*rak: call dcopy(3,cl,1,pcl,1) 6860*rak: ptagj = tagk 6861*rak: ptagk = tagj 6862*rak: ptagl = tagl 6863*rak: else 6864*rak: jpat = jat 6865*rak: call dcopy(3,cj,1,pcj,1) 6866*rak: ptagj = tagj 6867*rak: if (djk.gt.djl) then 6868*rak: kpat = kat 6869*rak: lpat = lat 6870*rak: call dcopy(3,ck,1,pck,1) 6871*rak: call dcopy(3,cl,1,pcl,1) 6872*rak: ptagk = tagk 6873*rak: ptagl = tagl 6874*rak: else 6875*rak: kpat = lat 6876*rak: lpat = kat 6877*rak: call dcopy(3,cl,1,pck,1) 6878*rak: call dcopy(3,ck,1,pcl,1) 6879*rak: ptagk = tagl 6880*rak: ptagl = tagk 6881*rak: endif 6882*rak: endif 6883*rak: if (.not.geom_calc_dihedral 6884*rak: & (pci,pcj,pck,pcl,diangle)) call errquit 6885*rak: & ('geom_print_dih:geom_calc_dih death', 6886*rak: & 911) 6887*rak: if (.not.header) then 6888*rak: write(luout,10000) 6889*rak: header = FT 6890*rak: endif ! .not.header 6891*rak: write(luout,10001)num_prt, 6892*rak: & ipat,ptagi,jpat,ptagj, 6893*rak: & kpat,ptagk,lpat,ptagl, 6894*rak: & diangle 6895*rak:*rak: write(LuOut,*)'i',pci 6896*rak:*rak: write(LuOut,*)'j',pcj 6897*rak:*rak: write(LuOut,*)'k',pck 6898*rak:*rak: write(LuOut,*)'l',pcl 6899*rak:*rak: write(LuOut,*)'dihang::j::',num_prt,':', 6900*rak:*rak: & ipat,jpat,kpat,lpat,diangle 6901*rak: endif 6902*rak: enddo 6903 do ltmp = 1,xlist(kat) 6904 lat = xnet(ltmp,kat) 6905 if (lat.ne.kat.and. 6906 & lat.ne.jat.and.lat.ne.iat) then 6907 if (.not.geom_cent_get(geom,lat,tagl,cl,chg)) 6908 & call errquit 6909 & ('geom_prt_dihedrals:geom_cent_get:l ', 6910 & 911, GEOM_ERR) 6911 status_tagl = 6912 & geom_tag_to_element(tagl,syml,elel,latn) 6913 if ((syml.eq.'bq').and.(.not.status_tagl)) 6914 & status_tagl = FT 6915 if (.not.status_tagl) call errquit 6916 & ('geom_prt_dihedrals:tag2elmnt fail:l', 6917 & 911, GEOM_ERR) 6918 if (.not.geom_get_def_rcov(latn,l_rcov)) 6919 & call errquit 6920 & ('geom_prt_dihedrals:defrcov fail:l', 6921 & 911, GEOM_ERR) 6922 6923 if (.not.geom_calc_distance(ci,cl,dil)) 6924 & call errquit 6925 & ('geom_prt_dihedrals:calc_distance:il', 6926 & 911, GEOM_ERR) 6927 if (.not.geom_calc_distance(cj,cl,djl)) 6928 & call errquit 6929 & ('geom_prt_dihedrals:calc_distance:jl', 6930 & 911, GEOM_ERR) 6931 if (.not.geom_calc_distance(ck,cl,dkl)) 6932 & call errquit 6933 & ('geom_prt_dihedrals:calc_distance:kl', 6934 & 911, GEOM_ERR) 6935 dil_okay = dil.lt.(rscale*(i_rcov+l_rcov)) 6936 djl_okay = djl.lt. 6937 & (tscale*rscale*(j_rcov+l_rcov)) 6938 dkl_okay = dkl.lt. 6939 & (tscale*rscale*(k_rcov+l_rcov)) 6940 num_prt = num_prt + 1 6941 ipat = iat 6942 call dcopy(3,ci,1,pci,1) 6943 ptagi = tagi 6944 if (switch_jk) then 6945 jpat = kat 6946 call dcopy(3,ck,1,pcj,1) 6947 ptagj = tagk 6948 if (djk.gt.djl) then 6949 kpat = jat 6950 lpat = lat 6951 call dcopy(3,cj,1,pck,1) 6952 call dcopy(3,cl,1,pcl,1) 6953 ptagk = tagj 6954 ptagl = tagl 6955 else 6956 kpat = lat 6957 lpat = jat 6958 call dcopy(3,cl,1,pck,1) 6959 call dcopy(3,cj,1,pcl,1) 6960 ptagk = tagl 6961 ptagl = tagj 6962 endif 6963 else 6964 jpat = jat 6965 kpat = kat 6966 lpat = lat 6967 call dcopy(3,cj,1,pcj,1) 6968 call dcopy(3,ck,1,pck,1) 6969 call dcopy(3,cl,1,pcl,1) 6970 ptagj = tagj 6971 ptagk = tagk 6972 ptagl = tagl 6973 endif 6974 if (.not.geom_calc_dihedral 6975 & (pci,pcj,pck,pcl,diangle)) call errquit 6976 & ('geom_print_dih:geom_calc_dih death', 6977 & 911, GEOM_ERR) 6978 if (.not.header) then 6979 write(luout,10000) 6980 header = FT 6981 endif ! .not.header 6982 write(luout,10001) 6983 & ipat,ptagi,jpat,ptagj, 6984 & kpat,ptagk,lpat,ptagl, 6985 & diangle 6986*rak: write(LuOut,*)'i',pci 6987*rak: write(LuOut,*)'j',pcj 6988*rak: write(LuOut,*)'k',pck 6989*rak: write(LuOut,*)'l',pcl 6990*rak: write(LuOut,*)'dihang::k::',num_prt,':', 6991*rak: & ipat,jpat,kpat,lpat,diangle 6992 endif 6993 enddo 6994 endif 6995 enddo 6996 endif 6997 endif 6998 enddo 6999 enddo 7000 if (header) then 7001 write(luout,10002) 7002 write(luout,10003)num_prt 7003 write(luout,10004) 7004 write(luout,10005) 7005 endif 700610000 format(1x,78('='),/, 7007 & 29x,'internuclear dihedral angles',/,1x,78('-'),/, 7008 & 4x,'center 1',3x,'|', 7009 & 3x,'center 2',3x,'|', 7010 & 3x,'center 3',3x,'|', 7011 & 3x,'center 4',3x,'|', 7012 & ' degrees', 7013 & /,1x,78('-')) 701410001 format(1x, 7015 & i4,1x,a8,1x,'|', 7016 & i4,1x,a8,1x,'|', 7017 & i4,1x,a8,1x,'|', 7018 & i4,1x,a8,1x,'|', 7019 & 1x,f8.2) 702010002 format(1x,78('-')) 702110003 format(28x,'number of included dihedral angles: ',i10) 702210004 format(1x,78('=')) 702310005 format(/,/) 7024 geom_prt_dihedrals = .true. 7025 end 7026*B4-xnet: logical function geom_print_dihedrals(geom) 7027*B4-xnet: implicit none 7028*B4-xnet:#include "errquit.fh" 7029*B4-xnet:#include "mafdecls.fh" 7030*B4-xnet:#include "stdio.fh" 7031*B4-xnet:#include "inp.fh" 7032*B4-xnet:c::-functions 7033*B4-xnet: logical geom_calc_distance 7034*B4-xnet: external geom_calc_distance 7035*B4-xnet: logical geom_calc_dihedral 7036*B4-xnet: external geom_calc_dihedral 7037*B4-xnet: logical geom_get_def_rcov 7038*B4-xnet: external geom_get_def_rcov 7039*B4-xnet:c::-passed 7040*B4-xnet: integer geom ! [input] geometry handle 7041*B4-xnet:c::-local 7042*B4-xnet: double precision rscale, tscale 7043*B4-xnet: integer nat ! number of atoms 7044*B4-xnet: integer iat ! ith atom 7045*B4-xnet: integer jat ! jth atom 7046*B4-xnet: integer kat ! kth atom 7047*B4-xnet: integer lat ! lth atom 7048*B4-xnet: integer ipat,jpat,kpat,lpat 7049*B4-xnet: double precision chg ! charge (ignored) 7050*B4-xnet: double precision ci(3) ! coords of atom i 7051*B4-xnet: character*16 tagi ! tag of atom i 7052*B4-xnet: character*8 ptagi ! tag of atom i 7053*B4-xnet: double precision cj(3) ! coords of atom j 7054*B4-xnet: character*16 tagj ! tag of atom j 7055*B4-xnet: character*8 ptagj ! tag of atom j 7056*B4-xnet: double precision ck(3) ! coords of atom k 7057*B4-xnet: character*16 tagk ! tag of atom k 7058*B4-xnet: character*8 ptagk ! tag of atom k 7059*B4-xnet: double precision cl(3) ! coords of atom k 7060*B4-xnet: character*16 tagl ! tag of atom k 7061*B4-xnet: character*8 ptagl ! tag of atom k 7062*B4-xnet:* double precision c_all(3,4) ! all coords 7063*B4-xnet:* double precision dall(6) ! all distances 7064*B4-xnet: double precision dij ! distance between atoms i and j 7065*B4-xnet: double precision dik ! distance between atoms i and k 7066*B4-xnet: double precision dil ! distance between atoms i and l 7067*B4-xnet: double precision djk ! distance between atoms j and k 7068*B4-xnet: double precision djl ! distance between atoms j and l 7069*B4-xnet: double precision dkl ! distance between atoms k and l 7070*B4-xnet: double precision diangle ! dihedral angle to be printed 7071*B4-xnet: logical FF, FT ! fortran true and false 7072*B4-xnet: logical dij_okay ! dij under threshold 7073*B4-xnet: logical dik_okay ! dik under threshold 7074*B4-xnet: logical dil_okay ! dil under threshold 7075*B4-xnet: logical djk_okay ! djk under threshold 7076*B4-xnet: logical djl_okay ! djl under threshold 7077*B4-xnet: logical dkl_okay ! dkl under threshold 7078*B4-xnet: logical all_okay 7079*B4-xnet: logical switch_jk 7080*B4-xnet:c 7081*B4-xnet: logical status_tagi, status_tagj, status_tagk, status_tagl 7082*B4-xnet: character*2 symi, symj, symk, syml 7083*B4-xnet: character*16 elei, elej, elek, elel 7084*B4-xnet: integer iatn, jatn, katn, latn 7085*B4-xnet: double precision i_rcov, j_rcov, k_rcov, l_rcov 7086*B4-xnet:c 7087*B4-xnet:* integer ngood 7088*B4-xnet: integer num_pos 7089*B4-xnet: integer num_prt 7090*B4-xnet: logical header 7091*B4-xnet:* 7092*B4-xnet: if (.not.geom_ncent(geom,nat)) call errquit 7093*B4-xnet: & ('geom_print_dihedrals: geom_ncent failed',911) 7094*B4-xnet: 7095*B4-xnet: num_pos = nat*(nat-1)*(nat-2)*(nat-3)/24 7096*B4-xnet: 7097*B4-xnet: FF = .false. 7098*B4-xnet: FT = .true. 7099*B4-xnet: 7100*B4-xnet: geom_print_dihedrals = FF 7101*B4-xnet: if (nat.lt.4) then 7102*B4-xnet: geom_print_dihedrals = FT 7103*B4-xnet: return 7104*B4-xnet: endif 7105*B4-xnet:c initialize variables 7106*B4-xnet: rscale = 1.1d00 7107*B4-xnet: tscale = 1.1d00 7108*B4-xnet: header = FF 7109*B4-xnet: dij_okay = FF ! dij under threshold 7110*B4-xnet: dik_okay = FF ! dik under threshold 7111*B4-xnet: dil_okay = FF ! dil under threshold 7112*B4-xnet: djk_okay = FF ! djk under threshold 7113*B4-xnet: djl_okay = FF ! djl under threshold 7114*B4-xnet: dkl_okay = FF ! dkl under threshold 7115*B4-xnet: num_prt = 0 7116*B4-xnet:c 7117*B4-xnet: do iat = 1,nat 7118*B4-xnet: if (.not.geom_cent_get(geom,iat,tagi,ci,chg)) call errquit 7119*B4-xnet: & ('geom_print_dihedrals:geom_cent_get:i ',911) 7120*B4-xnet: status_tagi = geom_tag_to_element(tagi,symi,elei,iatn) 7121*B4-xnet: if ((symi.eq.'bq').and.(.not.status_tagi)) 7122*B4-xnet: & status_tagi = FT 7123*B4-xnet: if (.not.status_tagi) call errquit 7124*B4-xnet: & ('geom_print_dihedrals:tag2element failed:i',911) 7125*B4-xnet: if (.not.geom_get_def_rcov(iatn,i_rcov)) call errquit 7126*B4-xnet: & ('geom_print_dihedrals:defrcov failed:i',911) 7127*B4-xnet: do jat = 1,nat 7128*B4-xnet: if (iat.ne.jat) then 7129*B4-xnet: 7130*B4-xnet: if (.not.geom_cent_get(geom,jat,tagj,cj,chg)) call errquit 7131*B4-xnet: & ('geom_print_dihedrals:geom_cent_get:j ',911) 7132*B4-xnet: status_tagj = geom_tag_to_element(tagj,symj,elej,jatn) 7133*B4-xnet: if ((symj.eq.'bq').and.(.not.status_tagj)) 7134*B4-xnet: & status_tagj = FT 7135*B4-xnet: if (.not.status_tagj) call errquit 7136*B4-xnet: & ('geom_print_dihedrals:tag2element failed:j',911) 7137*B4-xnet: if (.not.geom_get_def_rcov(jatn,j_rcov)) call errquit 7138*B4-xnet: & ('geom_print_dihedrals:defrcov failed:j',911) 7139*B4-xnet: 7140*B4-xnet: if (.not.geom_calc_distance(ci,cj,dij)) call errquit 7141*B4-xnet: & ('geom_print_dihedrals:geom_calc_distance:ij ',911) 7142*B4-xnet: 7143*B4-xnet: dij_okay = dij.lt.(rscale*(i_rcov+j_rcov)) 7144*B4-xnet: if (dij_okay) then 7145*B4-xnet: do kat = 1,nat 7146*B4-xnet: if (kat.ne.jat.and.kat.ne.iat) then 7147*B4-xnet: if (.not.geom_cent_get(geom,kat,tagk,ck,chg)) 7148*B4-xnet: & call errquit 7149*B4-xnet: & ('geom_print_dihedrals:geom_cent_get:k ',911) 7150*B4-xnet: status_tagk = 7151*B4-xnet: & geom_tag_to_element(tagk,symk,elek,katn) 7152*B4-xnet: if ((symk.eq.'bq').and.(.not.status_tagk)) 7153*B4-xnet: & status_tagk = FT 7154*B4-xnet: if (.not.status_tagk) call errquit 7155*B4-xnet: & ('geom_print_dihedrals:tag2element failed:k', 7156*B4-xnet: & 911) 7157*B4-xnet: if (.not.geom_get_def_rcov(katn,k_rcov)) 7158*B4-xnet: & call errquit 7159*B4-xnet: & ('geom_print_dihedrals:defrcov failed:k',911) 7160*B4-xnet: 7161*B4-xnet: if (.not.geom_calc_distance(ci,ck,dik)) call errquit 7162*B4-xnet: & ('geom_print_dihedrals:geom_calc_distance:ik ', 7163*B4-xnet: & 911) 7164*B4-xnet: if (.not.geom_calc_distance(cj,ck,djk)) call errquit 7165*B4-xnet: & ('geom_print_dihedrals:geom_calc_distance:jk ', 7166*B4-xnet: & 911) 7167*B4-xnet: 7168*B4-xnet: dik_okay = dik.lt.(rscale*(i_rcov+k_rcov)) 7169*B4-xnet: djk_okay = djk.lt.(rscale*(j_rcov+k_rcov)) 7170*B4-xnet: switch_jk = dik.lt.dij.and.dik_okay 7171*B4-xnet: if (djk_okay)then 7172*B4-xnet: do lat = 1,nat 7173*B4-xnet: if(lat.ne.iat.and.lat.ne.jat.and. 7174*B4-xnet: & lat.ne.kat) then 7175*B4-xnet: if (.not.geom_cent_get(geom,lat,tagl,cl,chg)) 7176*B4-xnet: & call errquit 7177*B4-xnet: & ('geom_print_dihedrals:geom_cent_get:l ', 7178*B4-xnet: & 911) 7179*B4-xnet: status_tagl = 7180*B4-xnet: & geom_tag_to_element(tagl,syml,elel,latn) 7181*B4-xnet: if ((syml.eq.'bq').and.(.not.status_tagl)) 7182*B4-xnet: & status_tagl = FT 7183*B4-xnet: if (.not.status_tagl) call errquit 7184*B4-xnet: & ('geom_print_dihedrals:tag2elmnt fail:l', 7185*B4-xnet: & 911) 7186*B4-xnet: if (.not.geom_get_def_rcov(latn,l_rcov)) 7187*B4-xnet: & call errquit 7188*B4-xnet: & ('geom_print_dihedrals:defrcov fail:l', 7189*B4-xnet: & 911) 7190*B4-xnet: 7191*B4-xnet: if (.not.geom_calc_distance(ci,cl,dil)) 7192*B4-xnet: & call errquit 7193*B4-xnet: & ('geom_print_dihedrals:calc_distance:il', 7194*B4-xnet: & 911) 7195*B4-xnet: if (.not.geom_calc_distance(cj,cl,djl)) 7196*B4-xnet: & call errquit 7197*B4-xnet: & ('geom_print_dihedrals:calc_distance:jl', 7198*B4-xnet: & 911) 7199*B4-xnet: if (.not.geom_calc_distance(ck,cl,dkl)) 7200*B4-xnet: & call errquit 7201*B4-xnet: & ('geom_print_dihedrals:calc_distance:kl', 7202*B4-xnet: & 911) 7203*B4-xnet: dil_okay = dil.lt.(rscale*(i_rcov+l_rcov)) 7204*B4-xnet: djl_okay = djl.lt. 7205*B4-xnet: & (tscale*rscale*(j_rcov+l_rcov)) 7206*B4-xnet: dkl_okay = dkl.lt. 7207*B4-xnet: & (tscale*rscale*(k_rcov+l_rcov)) 7208*B4-xnet:* collect info calculate dihedral angle 7209*B4-xnet: ipat = iat 7210*B4-xnet: ptagi = tagi 7211*B4-xnet: lpat = lat 7212*B4-xnet: ptagl = tagl 7213*B4-xnet: if (switch_jk) then 7214*B4-xnet: jpat = kat 7215*B4-xnet: ptagj = tagk 7216*B4-xnet: kpat = jat 7217*B4-xnet: ptagk = tagk 7218*B4-xnet: all_okay = dij_okay.and.djk_okay.and. 7219*B4-xnet: & djl_okay 7220*B4-xnet: if (all_okay) then 7221*B4-xnet: if (.not.geom_calc_dihedral 7222*B4-xnet: & (ci,ck,cj,cl,diangle)) call errquit 7223*B4-xnet: & ('geom_print_dih:geom_calc_dih death', 7224*B4-xnet: & 911) 7225*B4-xnet: endif 7226*B4-xnet: else 7227*B4-xnet: jpat = jat 7228*B4-xnet: ptagj = tagj 7229*B4-xnet: kpat = kat 7230*B4-xnet: ptagk = tagk 7231*B4-xnet: all_okay = dij_okay.and.djk_okay.and. 7232*B4-xnet: & dkl_okay 7233*B4-xnet: if (all_okay) then 7234*B4-xnet: if (.not.geom_calc_dihedral 7235*B4-xnet: & (ci,cj,ck,cl,diangle)) call errquit 7236*B4-xnet: & ('geom_print_dih:geom_calc_dih death', 7237*B4-xnet: & 911) 7238*B4-xnet: endif 7239*B4-xnet: endif ! switch_jk 7240*B4-xnet: if (all_okay) then 7241*B4-xnet: num_prt = num_prt + 1 7242*B4-xnet: if (.not.header) then 7243*B4-xnet: write(luout,10000) 7244*B4-xnet: header = FT 7245*B4-xnet: endif ! .not.header 7246*B4-xnet: write(luout,10001)num_prt, 7247*B4-xnet: & ipat,ptagi,jpat,ptagj, 7248*B4-xnet: & kpat,ptagk,lpat,ptagl, 7249*B4-xnet: & diangle 7250*B4-xnet: endif ! all_okay 7251*B4-xnet: endif ! lat != iat,jat,kat 7252*B4-xnet: enddo ! lat loop 7253*B4-xnet: endif ! djk_okay 7254*B4-xnet: endif ! kat != iat,jat 7255*B4-xnet: enddo ! kat loop 7256*B4-xnet: endif ! dij_okay 7257*B4-xnet: endif ! jat != iat 7258*B4-xnet: enddo ! jat loop 7259*B4-xnet: enddo ! iat loop 7260*B4-xnet: if (header) write(luout,10002) 7261*B4-xnet:10000 format(1x,86('='),/, 7262*B4-xnet: & 29x,'internuclear dihedral angles',/,1x,86('-'),/, 7263*B4-xnet: & 1x,'count |', 7264*B4-xnet: & 3x,'center 1',3x,'|', 7265*B4-xnet: & 3x,'center 2',3x,'|', 7266*B4-xnet: & 3x,'center 3',3x,'|', 7267*B4-xnet: & 3x,'center 4',3x,'|', 7268*B4-xnet: & ' degrees', 7269*B4-xnet: & /,1x,86('-')) 7270*B4-xnet:10001 format(1x,i5,1x,'|', 7271*B4-xnet: & i4,1x,a8,1x,'|', 7272*B4-xnet: & i4,1x,a8,1x,'|', 7273*B4-xnet: & i4,1x,a8,1x,'|', 7274*B4-xnet: & i4,1x,a8,1x,'|', 7275*B4-xnet: & 1x,f8.2) 7276*B4-xnet:10002 format(1x,86('='),/,/) 7277*B4-xnet: geom_print_dihedrals = .true. 7278*B4-xnet: end 7279 logical function geom_get_def_rcov(atn,rcoval) 7280 implicit none 7281#include "errquit.fh" 7282c 7283c routine to return the default covalent radii (in a.u.) for the given 7284c atomic number. 7285c 7286c Written by: R. A. Kendall, PNNL, December 1996 7287c 7288#include "stdio.fh" 7289#include "nwc_const.fh" 7290#include "geomP.fh" 7291 integer atn ! [input] atomic number of element 7292 double precision rcoval ! [output] estimate of covalent 7293 ! radii for atom 7294c 7295 integer i 7296 double precision def_rcov(nelements) 7297C 7298C Data for 1-96 From "Covalent radii revisited", Cordero et al, Dalton Trans. 2832 (2008) 7299C data for 97-103 RA Kendall 7300* Guess = 1.2*atomic: Fr<87>, Ra<88>, Ac<89>, Th<90>, Pa<91>, 7301* 7302* Guess = U<92> 3.000 7303* 7304* Guess = 1.2*atomic: Np<93>, Pu<94>, Am<95> 7305* 7306* Guess = 1.3*largest cation radii: Bk<97>, Cf<98>, Es<99>, 7307* Fm<100>, Md<101>, No<102>, Lr<103> 7308* 7309* Added elements 104-109 with dummy values of 1.4 - KG Dyall. 7310* 7311* Note: values in data structure are in Angstroms. 7312* 7313 data (def_rcov(i), i=1,2) 7314 & /0.31D+00,0.28D+00/ 7315 data (def_rcov(i),i=3,10) 7316 & /1.28D+00,0.96D+00,0.84D+00,0.76D+00, 7317 & 0.71D+00,0.66D+00,0.57D+00,0.58D+00/ 7318 data (def_rcov(i),i=11,18) 7319 & /1.66D+00,1.41D+00,1.21D+00,1.11D+00, 7320 & 1.07D+00,1.05D+00,1.02D+00,1.06D+00/ 7321 data (def_rcov(i),i=19,36) 7322 & /2.03D+00,1.76D+00, 7323 & 1.70D+00,1.60D+00,1.53D+00,1.39D+00,1.39D+00, 7324 & 1.32D+00,1.26D+00,1.24D+00,1.32D+00,1.22D+00, 7325 & 1.22D+00,1.20D+00,1.19D+00,1.20D+00,1.20D+00,1.16D+00/ 7326 data (def_rcov(i),i=37,54) 7327 & /2.20D+00,1.95D+00, 7328 & 1.90D+00,1.75D+00,1.64D+00,1.54D+00,1.47D+00, 7329 & 1.46D+00,1.42D+00,1.39D+00,1.45D+00,1.44D+00, 7330 & 1.42D+00,1.39D+00,1.39D+00,1.38D+00,1.39D+00,1.40D+00/ 7331 data (def_rcov(i),i=55,86) 7332 & /2.44D+00,2.15D+00, 7333 & 2.07D+00,2.04D+00,2.03D+00,2.01D+00,1.99D+00, 7334 & 1.98D+00,1.98D+00, 7335 & 1.96D+00,1.94D+00,1.92D+00,1.92D+00,1.89D+00, 7336 & 1.90D+00,1.87D+00, 7337 & 1.87D+00,1.75D+00,1.70D+00,1.62D+00,1.51D+00, 7338 & 1.44D+00,1.41D+00,1.36D+00,1.36D+00,1.32D+00, 7339 & 1.45D+00,1.46D+00,1.48D+00,1.40D+00,1.50D+00,1.50D+00/ 7340 data (def_rcov(i),i=87,109) / 7341 & 2.60d00, 2.21d00, 2.15d00, 2.06d00, 2.00d00, 7342 & 1.96d00, 1.90d00, 1.87d00, 1.80d00, 1.69d00, 7343 & 1.42d00, 1.40d00, 1.39d00, 1.38d00, 1.37d00, 7344 & 1.36d00, 1.34d00, 1.40d00, 1.40d00, 1.40d00, 7345 & 1.40d00, 1.40d00, 1.40d00/ 7346 geom_get_def_rcov = .false. 7347 if (atn.eq.0) then 7348 rcoval = 2.0d00 ! dummy center sees lots of things? 7349 elseif (atn.gt.0.and.atn.le.nelements) then 7350 rcoval = def_rcov(atn) 7351 else 7352 write(luout,*)' geom_get_def_rcov: atomic number:',atn 7353 write(luout,*)' out of range 0 -> ',nelements 7354 call errquit('geom_get_def_rcov: fatal error',911, GEOM_ERR) 7355 endif 7356 rcoval = rcoval*angstrom_to_au 7357 geom_get_def_rcov = .true. 7358 end 7359c 7360C> \brief Create an new geometry instance 7361c 7362C> Create a new geometry instance with the specified name. 7363C> Return .true. if the instance was successfully created, 7364C> return .false. otherwise. 7365 logical function geom_create(geom, name) 7366 implicit none 7367#include "nwc_const.fh" 7368#include "geomP.fh" 7369#include "inp.fh" 7370#include "stdio.fh" 7371c 7372 integer geom !< [Output] the handle of the new geometry 7373 character*(*) name !< [Input] the geometry name 7374c 7375 integer i,j 7376 external geom_data ! This for T3D linker 7377c 7378c Assign the next free slot for a geometry 7379c 7380 do geom = 1, max_geom 7381 if (.not. active(geom)) goto 10 7382 end do 7383 write(LuOut,1) name 7384 1 format(' geom_create: too many geoms trying to create ', a) 7385 call geom_err_info('geom_create') 7386 geom_create = .false. 7387 return 7388 10 continue 7389c 7390c store info about the geometry 7391c 7392 names(geom) = name 7393 trans(geom) = ' ' 7394 lenn(geom) = inp_strlen(name) 7395 ncenter(geom) = 0 7396 active(geom) = .true. 7397 geom_create = .true. 7398 oefield(geom) = .false. 7399 operiodic(geom) = .false. 7400 ncenter_unique(geom) = 0 7401 isystype(geom) = 0 7402 group_number(geom) = 1 7403 setting_number(geom) = 0 7404 sym_center_map_handle(geom) = -1 7405 sym_center_map_index(geom) = 1 7406 group_name(geom) = 'C1' 7407 sym_num_ops(geom) = 0 7408 user_units(geom) = 'angstroms' 7409 include_bqbq(geom) = .false. 7410 use_primitive(geom) = .true. 7411 primitive_center(geom) = 'x' 7412c 7413 zmt_nizmat(geom) = 0 7414 zmt_nzvar(geom) = 0 7415 zmt_nzfrz(geom) = 0 7416 zmt_source(geom) = ' ' 7417 zmt_maxtor(geom) = 100 7418 zmt_cvr_scaling(geom) = 0d0 ! Indicates no user zcoord input 7419c 7420 do i = 1, 3 7421 lattice_vectors(i,geom) = 0 7422 lattice_angles(i,geom) = 0 7423 do j = 1, 3 7424 amatrix(j,i,geom) = 0.0d0 7425 amatrix_inv(j,i,geom) = 0.0d0 7426 bmatrix(j,i,geom) = 0.0d0 7427 end do 7428 amatrix(i,i,geom) = 1.0d0 7429 amatrix_inv(i,i,geom) = 1.0d0 7430 bmatrix(i,i,geom) = 1.0d0 7431 end do 7432c 7433* call dfill((3*max_cent),0.0d00,coord(1,1,geom),1) 7434* call dfill(max_cent,0.0d00,charge(1,geom),1) 7435* call dfill(3,0.0d00,efield(1,geom),1) 7436* erep(geom) = 0.0d00 7437* call dfill(3,0.0d00,ndipole(1,geom),1) 7438* do i = 1,max_cent 7439* oecpcent(i,geom) = .false. 7440* enddo 7441c 7442 end 7443************************************************************************ 7444 logical function geom_disable_zmatrix(geom) 7445 implicit none 7446#include "nwc_const.fh" 7447#include "geomP.fh" 7448 integer geom 7449 logical geom_check_handle 7450 external geom_check_handle 7451c 7452 geom_disable_zmatrix = geom_check_handle(geom, 'disable_zmat') 7453 if (geom_disable_zmatrix) then 7454 zmt_nizmat(geom) = 0 7455 zmt_nzvar(geom) = 0 7456 zmt_nzfrz(geom) = 0 7457 zmt_source(geom) = ' ' 7458 zmt_maxtor(geom) = 100 7459 zmt_cvr_scaling(geom) = 0d0 ! Indicates no user zcoord input 7460 end if 7461c 7462 end 7463************************************************************************ 7464 logical function geom_nucexps_set(geom, ncent, invnucexp) 7465 implicit none 7466#include "nwc_const.fh" 7467#include "stdio.fh" 7468#include "geomP.fh" 7469c 7470 integer geom ! [input] geometry handle 7471 integer ncent ! [input] number of centers 7472 double precision invnucexp(ncent) ! [input] inverse nuclear exponent on each center 7473c 7474 integer i 7475c 7476 logical geom_check_handle 7477 external geom_check_handle 7478c 7479 geom_nucexps_set = geom_check_handle(geom, 'geom_nucexps_set') 7480 if (.not. geom_nucexps_set) return 7481c 7482 if (ncent.le.0) then 7483 write(luout,*) ' geom_nucexps_set: too few centers ',ncent, 7484 $ names(geom)(1:lenn(geom)) 7485 geom_nucexps_set = .false. 7486 return 7487 else if (ncent.gt.max_cent) then 7488 write(luout,*) ' geom_nucexps_set: too many centers ',ncent, 7489 $ names(geom)(1:lenn(geom)) 7490 geom_nucexps_set = .false. 7491 return 7492 end if 7493c 7494 do i = 1, ncent 7495 geom_invnucexp(i,geom) = invnucexp(i) 7496 enddo 7497c 7498 end 7499************************************************************************ 7500 logical function geom_nucexps_get(geom, ncent, invnucexp) 7501 implicit none 7502#include "nwc_const.fh" 7503#include "geomP.fh" 7504c 7505 integer geom ! [input] geometry handle 7506 integer ncent ! [input] number of centers 7507 double precision invnucexp(ncent) ! [output] inverse nuclear exponent on each center 7508c 7509 integer i 7510c 7511 logical geom_check_handle 7512 external geom_check_handle 7513c 7514 geom_nucexps_get = geom_check_handle(geom, 'geom_nucexps_get') 7515 if (.not. geom_nucexps_get) return 7516c 7517 ncent = ncenter(geom) 7518 do i = 1, ncent 7519 invnucexp(i) = geom_invnucexp(i,geom) 7520 enddo 7521c 7522 end 7523************************************************************************ 7524 logical function geom_nucexp_set(geom, icent, invnucexp) 7525 implicit none 7526#include "nwc_const.fh" 7527#include "geomP.fh" 7528#include "stdio.fh" 7529c 7530 integer geom ! [input] geometry handle 7531 integer icent ! [input] index of center for invnucexp 7532 double precision invnucexp ! [input] inverse nuclear exponent on center icent 7533c 7534 logical geom_check_handle 7535 external geom_check_handle 7536c 7537 geom_nucexp_set = geom_check_handle(geom, 'geom_nucexp_set') 7538 if (.not. geom_nucexp_set) return 7539c 7540 if (icent.le.0 .or. icent.gt.ncenter(geom)) then 7541 write(luout,*) ' geom_nucexp_set: icent out of range',icent, 7542 & ncenter(geom),names(geom)(1:lenn(geom)) 7543 geom_nucexp_set = .false. 7544 else 7545 geom_invnucexp(icent,geom) = invnucexp 7546 end if 7547c 7548 return 7549 end 7550************************************************************************ 7551 logical function geom_nucexp_get(geom, icent, invnucexp) 7552 implicit none 7553#include "nwc_const.fh" 7554#include "geomP.fh" 7555#include "stdio.fh" 7556c 7557 integer geom ! [input] geometry handle 7558 integer icent ! [input] index of center for invnucexp 7559 double precision invnucexp ! [output] inverse nuclear exponent on center icent 7560c 7561 logical geom_check_handle 7562 external geom_check_handle 7563c 7564 geom_nucexp_get = geom_check_handle(geom, 'geom_nucexp_get') 7565 if (.not. geom_nucexp_get) return 7566c 7567 if (icent.le.0 .or. icent.gt.ncenter(geom)) then 7568 write(luout,*) ' geom_nucexp_get: icent out of range',icent, 7569 & ncenter(geom),names(geom)(1:lenn(geom)) 7570 geom_nucexp_get = .false. 7571 else 7572 invnucexp = geom_invnucexp(icent,geom) 7573 end if 7574c 7575 return 7576 end 7577************************************************************************ 7578 logical function geom_mass_to_invnucexp (mass, invnucexp) 7579 implicit none 7580#include "errquit.fh" 7581#include "nwc_const.fh" 7582#include "geomP.fh" 7583c 7584 double precision mass ! [input] nuclear mass 7585 double precision invnucexp ! [output] inverse nuclear exponent 7586c--local 7587 double precision athird 7588c 7589 geom_mass_to_invnucexp = mass .gt. 0.0d0 7590c 7591 if (mass .gt. 0.0d0) then 7592 athird = anint(mass)**(1.0d0/3.0d0) 7593 if (angstrom_to_au .eq. 0.0d0) call errquit( 7594 & 'geom_mass_to_invnucexp:zero conversion factor',911, 7595 & GEOM_ERR) 7596 invnucexp = ((0.836d0*athird+0.570d0)*angstrom_to_au)**2/1.5d10 7597 end if 7598c 7599 end 7600************************************************************************ 7601c 7602C> \brief Are there any finite sized nucleii 7603c 7604C> Assesses whether there are any finite sized nucleii in the specified 7605C> geometry instance. 7606c 7607C> \return Return .true. if there are finite size nucleii, and .false. 7608C> otherwise. 7609 logical function geom_any_finuc (geom) 7610 implicit none 7611#include "nwc_const.fh" 7612#include "geomP.fh" 7613c 7614 integer geom !< [Input] the geometry handle 7615 integer i 7616 double precision sum 7617c 7618 sum = 0.0d0 7619 do i = 1,ncenter(geom) 7620 sum = sum+geom_invnucexp(i,geom) 7621 end do 7622 geom_any_finuc = sum .gt. 1.0d-20 7623 return 7624 end 7625 subroutine geom_momint0(geom,coord,natoms,ci,AI,oprint, 7626 , considerbq,lautosym) 7627 implicit none 7628#include "errquit.fh" 7629#include "stdio.fh" 7630#include "geom.fh" 7631#include "inp.fh" 7632C 7633C ----- CENTER AND MOMENTS OF INERTIA ----- 7634C 7635 integer geom ! [in] 7636 integer natoms ! [in] 7637 double precision coord(3,*) ! [in] 7638 double precision ci(3),ai(3,3) ! [out] ctr of mass and inertua tensor 7639 logical oprint, considerbq,lautosym 7640 character*16 element 7641 character*16 tag 7642 character*2 symbol 7643c 7644 integer iat,i,j 7645 double precision mass,x,y,z 7646 integer ibq,maxbqtype,mybq,lll 7647 parameter(maxbqtype=20) 7648 character*6 tagbq(maxbqtype) 7649 logical lisbq 7650c 7651c 7652 do j=1,3 7653 do i=1,3 7654 ai(j,i)=0d0 7655 enddo 7656 enddo 7657 do j=1,maxbqtype 7658 tagbq(j)=' ' 7659 enddo 7660 ibq=0 7661c 7662 if (.not.geom_center_of_mass(geom,ci)) call errquit 7663 & ('geom_momint0: could not get center of mass',555, GEOM_ERR) 7664c 7665 do iat=1,natoms 7666 if (.not. geom_cent_tag(geom,iat,tag)) call 7667 & errquit(' momint0 hosed ',0, GEOM_ERR) 7668 lisbq=inp_compare(.false.,tag(1:2),'bq') 7669 if (considerbq.and.lisbq) then 7670c 7671c ahah bq 7672c 7673 if(tag(3:3).ne.' ') then 7674 if(.not.geom_tag_to_default_mass(tag(3:),mass)) 7675 . call errquit(' momint fails ',2, GEOM_ERR) 7676 else 7677 mass=0d0 7678 endif 7679 else 7680 if(.not.geom_mass_get(geom, iat, mass)) call 7681 & errquit(' mass_get failed ',iat, GEOM_ERR) 7682c 7683c assign some mass to bqs 7684c 7685 if(mass.eq.0d0.and.lisbq.and.lautosym) then 7686c 7687c check if we alreayd have this bq 7688c 7689 lll=inp_strlen(tag) 7690 do j=1,ibq 7691 if(tagbq(j).eq.tag(3:lll)) then 7692 mybq=j 7693 goto 123 7694 endif 7695 enddo 7696 ibq=ibq+1 7697 if(ibq.gt.maxbqtype) call errquit( 7698 * ' momint0: maxbqtype too small ',ibq,0) 7699 tagbq(ibq)=tag(3:lll) 7700 mybq=ibq 7701 123 mass=mybq*1d0 7702 endif 7703 endif 7704 x =coord(1,iat) - ci(1) 7705 y =coord(2,iat) - ci(2) 7706 z =coord(3,iat) - ci(3) 7707 ai(1,1)=ai(1,1)+mass*(y*y+z*z) 7708 ai(2,1)=ai(2,1)-mass* x*y 7709 ai(1,2)=ai(2,1) 7710 ai(3,1)=ai(3,1)-mass* x*z 7711 ai(1,3)=ai(3,1) 7712 ai(2,2)=ai(2,2)+mass*(x*x+z*z) 7713 ai(3,2)=ai(3,2)-mass* y*z 7714 ai(2,3)=ai(3,2) 7715 ai(3,3)=ai(3,3)+mass*(x*x+y*y) 7716 enddo 7717 if(oprint) then 7718 write(luout,9999) 7719 write(luout,9998) (ci(i),i=1,3) 7720 write(luout,9997) 7721 do i=1,3 7722 write(luout,'(3f25.12)') (ai(i,j),j=1,3) 7723 enddo 7724 endif 7725c 7726 return 7727 9999 format(/,1x,'center of mass',/,1x,14(1h-)) 7728 9998 format(' x = ',f12.8,' y = ',f12.8,' z = ',f12.8) 7729 9997 format(/,1x,'moments of inertia (a.u.)',/,1x,18(1h-)) 7730 end 7731 subroutine geom_momint(geom) 7732 implicit none 7733#include "errquit.fh" 7734#include "mafdecls.fh" 7735#include "geom.fh" 7736 integer geom 7737c 7738 integer natoms,l_coord,k_coord, 7739 , k_charge,l_charge,k_tag,l_tag 7740 logical oprint 7741 double precision ci(3),ai(3,3) 7742 oprint = .true. 7743c 7744c print moment of inertia 7745c 7746 if ( .NOT. geom_ncent(geom, natoms) ) call errquit( 7747 $ 'rohf: problem with call to geom_ncent', geom , GEOM_ERR) 7748 if (.not. ma_push_get(mt_dbl,3*natoms,'tcoords',l_coord,k_coord)) 7749 $ call errquit('uhf_analyze: ma failed on tmp', natoms, 7750 & MA_ERR) 7751 if (.not. ma_push_get(mt_dbl,natoms,'coords',l_charge,k_charge)) 7752 $ call errquit('uhf_analyze: ma failed on tmp', natoms, 7753 & MA_ERR) 7754 if (.not. ma_push_get(mt_byte,natoms*16,'coords',l_tag,k_tag)) 7755 $ call errquit('uhf_analyze: ma failed on tmp', natoms, 7756 & MA_ERR) 7757 if (.not. geom_cart_get(geom, natoms, byte_mb(k_tag), 7758 . dbl_mb(k_coord), dbl_mb(k_charge))) 7759 $ call errquit('uhf_anal: geom_cent_tag failed',0, 7760 & MA_ERR) 7761 if (.not. ma_chop_stack(l_charge)) 7762 $ call errquit('uhf_analyze: pop failed', 0, 7763 & MA_ERR) 7764 call geom_momint0(geom,dbl_mb(k_coord),natoms,ci,AI,oprint, 7765 & .false.,.false.) 7766 if (.not. ma_chop_stack(l_coord)) 7767 $ call errquit('uhf_analyze: pop failed', 0, 7768 & MA_ERR) 7769 return 7770 end 7771c 7772C> \brief Converts center coordinates from Cartesian to fractional 7773C> coordinates 7774c 7775C> In finite systems Cartesian coordinates are in common use whereas 7776C> in crystal structures fractional coordinates are used. This routine 7777C> converts a set of Cartesian coordinates into the corresponding 7778C> fractional coordinates based on a transformation that is stored 7779C> within the geometry instance. 7780c 7781C> \return Return .true. if the conversion was successful, and .false. 7782C> otherwise. 7783c 7784 logical function geom_cart_to_frac(geom, c) 7785 implicit none 7786#include "errquit.fh" 7787 integer geom !< [Input] the geometry handle 7788 double precision c(3,*) !< [Input|Output] the center coordinates 7789c 7790 integer iat, nat, i, j 7791 logical geom_check_handle, geom_amatinv_get, geom_ncent 7792 external geom_check_handle, geom_amatinv_get 7793 double precision ainv(3,3), t(3) 7794c 7795 geom_cart_to_frac = geom_check_handle(geom, 'geom_cart_to_frac') 7796 if (.not. geom_cart_to_frac) return 7797 if (.not. geom_ncent(geom,nat)) 7798 $ call errquit('geom_cart_to_frac: nat', 0, GEOM_ERR) 7799 if (.not. geom_amatinv_get(geom, ainv)) 7800 $ call errquit('geom_cart_to_frac: ainv', 0, GEOM_ERR) 7801* write(6,*) ' The amatrix inverse' 7802* call output(ainv, 1, 3, 1, 3, 3, 3, 1) 7803c 7804 do iat = 1, nat 7805* write(6,*) 'c2f before ', iat, (c(i,iat),i=1,3) 7806 do i = 1, 3 7807 t(i) = 0.0d0 7808 do j = 1, 3 7809 t(i) = t(i) + ainv(i,j)*c(j,iat) 7810 end do 7811 end do 7812 do i = 1, 3 7813 c(i,iat) = t(i) 7814 end do 7815* write(6,*) 'c2f after ', iat, (c(i,iat),i=1,3) 7816 end do 7817c 7818 end 7819c 7820C> \brief Converts center coordinates from fractional to Cartesian 7821C> coordinates 7822c 7823C> In finite systems Cartesian coordinates are in common use whereas 7824C> in crystal structures fractional coordinates are used. This routine 7825C> converts a set of fractional coordinates into the corresponding 7826C> Cartesian coordinates based on a transformation that is stored 7827C> within the geometry instance. 7828c 7829C> \return Return .true. if the conversion was successful, and .false. 7830C> otherwise. 7831c 7832 logical function geom_frac_to_cart(geom, c) 7833 implicit none 7834#include "errquit.fh" 7835 integer geom !< [Input] the geometry handle 7836 double precision c(3,*) !< [Input|Output] the center coordinates 7837c 7838 integer iat, nat, i, j 7839 logical geom_check_handle, geom_amatrix_get, geom_ncent 7840 external geom_check_handle, geom_amatrix_get 7841 double precision a(3,3), t(3) 7842c 7843 geom_frac_to_cart = geom_check_handle(geom, 'geom_frac_to_cart') 7844 if (.not. geom_frac_to_cart) return 7845 if (.not. geom_ncent(geom,nat)) 7846 $ call errquit('geom_frac_to_cart: nat', 0, GEOM_ERR) 7847 if (.not. geom_amatrix_get(geom, a)) 7848 $ call errquit('geom_frac_to_cart: a', 0, GEOM_ERR) 7849c 7850 do iat = 1, nat 7851 do i = 1, 3 7852 t(i) = 0.0d0 7853 do j = 1, 3 7854 t(i) = t(i) + a(i,j)*c(j,iat) 7855 end do 7856 end do 7857 do i = 1, 3 7858 c(i,iat) = t(i) 7859 end do 7860 end do 7861c 7862 end 7863 logical function geom_grad_cart_to_frac(geom, c) 7864 implicit none 7865#include "errquit.fh" 7866 integer geom 7867 double precision c(3,*) 7868c 7869 integer iat, nat, i, j 7870 logical geom_check_handle, geom_amatrix_get, geom_ncent 7871 external geom_check_handle, geom_amatrix_get 7872 double precision a(3,3), t(3) 7873c 7874 geom_grad_cart_to_frac = 7875 $ geom_check_handle(geom, 'geom_grad_cart_to_frac') 7876 if (.not. geom_grad_cart_to_frac) return 7877 if (.not. geom_ncent(geom,nat)) 7878 $ call errquit('geom_grad_cart_to_frac: nat', 0, GEOM_ERR) 7879 if (.not. geom_amatrix_get(geom, a)) 7880 $ call errquit('geom_grad_cart_to_frac: a', 0, GEOM_ERR) 7881c 7882 do iat = 1, nat 7883 do i = 1, 3 7884 t(i) = 0.0d0 7885 do j = 1, 3 7886 t(i) = t(i) + a(j,i)*c(j,iat) 7887 end do 7888 end do 7889 do i = 1, 3 7890 c(i,iat) = t(i) 7891 end do 7892 end do 7893c 7894 end 7895 logical function geom_makec1(geom1, geom2) 7896 implicit none 7897#include "errquit.fh" 7898#include "nwc_const.fh" 7899c 7900c Creates a new geometry which is like the old one, but has C1 symmetry 7901c 7902 integer geom1 ! [in] Geometry potentially with symmetry 7903 integer geom2 ! [out] New geometry without symmetry 7904 integer ncenter ! no. of centers 7905 character*16 tags(nw_max_atom) 7906 double precision coords(3,nw_max_atom) 7907 double precision charge(nw_max_atom), mass(nw_max_atom) 7908c 7909 logical geom_create, geom_set_user_units 7910 logical geom_cart_get, geom_cart_set 7911 logical geom_masses_get, geom_masses_set 7912 external geom_create, geom_set_user_units 7913 external geom_cart_get, geom_cart_set 7914 external geom_masses_get, geom_masses_set 7915c 7916 geom_makec1 = .false. 7917c 7918 if (.not.geom_create(geom2,'geometrytemp')) 7919 & call errquit('geom_makec1: geom_create failed',555, GEOM_ERR) 7920 if (.not.geom_set_user_units(geom2,'a.u.')) 7921 & call errquit('geom_makec1: geom_set_user_units failed',555, 7922 & GEOM_ERR) 7923 if (.not.geom_cart_get(geom1,ncenter,tags,coords,charge)) 7924 & call errquit('geom_makec1: failed to get geom1',555, GEOM_ERR) 7925 if (.not.geom_cart_set(geom2,ncenter,tags,coords,charge)) 7926 & call errquit('geom_makec1: geom_cart_set failed',555, 7927 & GEOM_ERR) 7928 if (.not.geom_masses_get(geom1,ncenter,mass)) 7929 & call errquit('geom_makec1:geom_masses_get failed',555, 7930 & GEOM_ERR) 7931 if (.not.geom_masses_set(geom2,ncenter,mass)) 7932 & call errquit('geom_makec1:geom_masses_set failed',555, 7933 & GEOM_ERR) 7934c 7935 geom_makec1 = .true. 7936 return 7937 end 7938c 7939C> \brief Returns whether there is an active external Bq instance. 7940c 7941C> \return Returns .true. if there is an active external Bq instance, 7942C> and .false. otherwise. 7943 function geom_extbq_on() 7944 implicit none 7945#include "bq.fh" 7946 logical geom_extbq_on 7947 geom_extbq_on = bq_on() 7948 return 7949 end 7950c 7951C> \brief Look up the number of centers in the external Bq instance 7952c 7953C> A problem with geometries is that the maximum number of centers is 7954C> fixed. In particular for QM/MM calculations this is problematic 7955C> as the embedding requires up to thousands of point charges. To 7956C> address this issue the point charges can be stored in an instance 7957C> outside of the geometry. These external Bq instances require an 7958C> interface of their own to interact with them. This particular 7959C> function extracts the number of Bq centers in the active 7960C> external Bq instance. 7961C 7962C> \returns The number of Bq centers in the active external Bq 7963C> instance. 7964 function geom_extbq_ncenter() 7965 implicit none 7966#include "bq.fh" 7967#include "errquit.fh" 7968 integer geom_extbq_ncenter 7969c 7970 integer bq_handle 7971 integer bq_ncent 7972 character*32 pname 7973 7974 pname = "geom_extbq_ncenter" 7975 7976 if(.not.bq_get_active(bq_handle)) 7977 > call errquit(pname//'no active bq handle',0,0) 7978 if(.not.bq_ncenter(bq_handle,bq_ncent)) 7979 > call errquit(pname//':no bq centers',0,0) 7980 7981 geom_extbq_ncenter = bq_ncent 7982 7983 return 7984 end 7985 7986c 7987C> \brief Look up the index of the array holding the Bq charges 7988c 7989C> The charges of the Bq centers are stored in an array that can 7990C> be accessed through an offset in a common block (array dbl_mb in 7991C> mafdecls.fh). This function returns that offset for active 7992C> external Bq instance. 7993c 7994C> \returns The offset of the Bq charges for the currently 7995C> active Bq instance. 7996 function geom_extbq_charge() 7997 implicit none 7998#include "bq.fh" 7999#include "errquit.fh" 8000 integer geom_extbq_charge 8001c 8002 integer bq_handle 8003 integer i_qbq 8004 character*32 pname 8005 8006 pname = "geom_extbq_charge" 8007 8008 if(.not.bq_get_active(bq_handle)) 8009 > call errquit(pname//':no active bq handle',0,0) 8010 if(.not.bq_index_charge(bq_handle,i_qbq)) 8011 > call errquit(pname//':no bq coords',0,0) 8012 8013 geom_extbq_charge = i_qbq 8014 return 8015 end 8016c 8017C> \brief Look up the index of the array holding the Bq coordinates 8018c 8019C> The coordinates of the Bq centers are stored in an array that can 8020C> be accessed through an offset in a common block (array dbl_mb in 8021C> mafdecls.fh). This function returns that offset for active 8022C> external Bq instance. 8023c 8024C> \returns The offset of the Bq coordinates for the currently 8025C> active Bq instance. 8026 function geom_extbq_coord() 8027 implicit none 8028#include "bq.fh" 8029#include "errquit.fh" 8030 integer geom_extbq_coord 8031c 8032 integer bq_handle 8033 integer i_cbq 8034 character*32 pname 8035 8036 pname = "geom_extbq_coord" 8037 8038 if(.not.bq_get_active(bq_handle)) 8039 > call errquit(pname//':no active bq handle',0,0) 8040 if(.not.bq_index_coord(bq_handle,i_cbq)) 8041 > call errquit(pname//':no bq coords',0,0) 8042 8043 geom_extbq_coord = i_cbq 8044 return 8045 end 8046 8047 function geom_create_from_file(in_xyz,irtdb) 8048 implicit none 8049#include "mafdecls.fh" 8050#include "errquit.fh" 8051#include "msgids.fh" 8052#include "global.fh" 8053#include "inp.fh" 8054#include "stdio.fh" 8055#include "util.fh" 8056 character*(*) in_xyz 8057 integer irtdb 8058 logical geom_create_from_file 8059c local variables 8060 integer ns 8061 integer i,j 8062 integer k 8063 logical otitle 8064 integer i_t,h_t 8065 integer i_m,h_m 8066 integer i_q,h_q 8067 integer i_ctmp,h_ctmp 8068 integer atn 8069 character*32 pname 8070 character*72 title 8071 character*16 tag 8072 character*16 buf 8073 character*255 filename 8074 character*255 xyzfile 8075 character*255 trjfile 8076 character*255 message 8077 8078 integer fn_xyz,fn_trj 8079 logical end_of_file 8080 logical master 8081 integer geom ! handle for geometry 8082 character*255 geomname ! for name of geometry 8083 8084 logical geom_create,geom_print 8085 external geom_create,geom_print 8086 logical geom_tag_to_element 8087 external geom_tag_to_element 8088 logical geom_cart_set,geom_masses_set 8089 external geom_cart_set,geom_masses_set 8090 logical geom_tag_to_default_mass 8091 external geom_tag_to_default_mass 8092 logical geom_rtdb_store,geom_destroy 8093 external geom_rtdb_store,geom_destroy 8094 8095 master = ga_nodeid().eq.0 8096 pname = "geom_create_from_file" 8097c 8098c we assume that xyz file has a title 8099c ----------------------------------- 8100 otitle = .true. 8101 geom_create_from_file = .false. 8102c 8103 xyzfile = in_xyz(1:inp_strlen(in_xyz)) 8104 call util_file_name_resolve(xyzfile, .false.) 8105c 8106 filename = in_xyz(1:inp_strlen(xyzfile)) 8107 if(master) 8108 + call util_print_centered(luout, 8109 + "reading external xyz file "// 8110 + filename, 8111 + 40,.true.) 8112c 8113c prepare files for reading/writing 8114c --------------------------------- 8115 if(.not.util_get_io_unit(fn_xyz)) 8116 > call errquit("cannot get file number",0,0) 8117 filename = xyzfile 8118 open(fn_xyz,file=filename,form='formatted',status='old', 8119 $ err=133) 8120c 8121c get number of atoms 8122c ------------------ 8123 message = " number of atoms " 8124 read(fn_xyz,*,err=134) ns 8125c 8126c temporary stack memory 8127c ---------------------- 8128 if(.not.ma_push_get(mt_byte,16*ns,'t',h_t,i_t)) 8129 + call errquit(pname//'Failed to allocate memory for t',ns, 8130 & MA_ERR) 8131 8132 if(.not.ma_push_get(mt_dbl,3*ns,'ctmp',h_ctmp,i_ctmp)) 8133 + call errquit( pname//'Failed to allocate memory for ctmp', 8134 + 3*ns, MA_ERR) 8135 8136 if(.not.ma_push_get(mt_dbl,ns,'q',h_q,i_q)) 8137 + call errquit(pname//'Failed to allocate memory for q',ns, 8138 & MA_ERR) 8139 8140 if(.not.ma_push_get(mt_dbl,ns,'m',h_m,i_m)) 8141 + call errquit('qmmm: Failed to allocate memory for m',ns, 8142 & MA_ERR) 8143 8144c 8145c read the coords 8146c -------------------------------- 8147 message = " title field" 8148 if(otitle) 8149 + read(fn_xyz,*,err=134,end=135) title 8150 8151 do i=1,ns 8152 tag = " " 8153 read(fn_xyz,*,err=134,end=135) tag, 8154 + (dbl_mb(i_ctmp+3*(i-1)+k-1),k=1,3) 8155 do j=1,16 8156 byte_mb(i_t+16*(i-1)+j-1)=tag(j:j) 8157 end do 8158 8159 if (.not. 8160 & geom_tag_to_default_mass(tag,dbl_mb(i_m+i-1))) 8161 & call errquit(pname//'default mass failed', 8162 & 911, INPUT_ERR) 8163 8164 if (.not. 8165 & geom_tag_to_element(tag,buf,buf,atn)) 8166 & call errquit(pname//'default atn failed', 8167 & 911, INPUT_ERR) 8168 8169 dbl_mb(i_q+i-1)=atn 8170 end do 8171c call dscal(3*ns,1/cau2ang,dbl_mb(i_ctmp),1) 8172c 8173c 8174 geomname = "geometry" 8175 if (.not. geom_create(geom, geomname)) call errquit 8176 $ (pname//'geom_create failed !', 0, GEOM_ERR) 8177c 8178 if(.not.geom_cart_set(geom,ns,byte_mb(i_t), 8179 + dbl_mb(i_ctmp),dbl_mb(i_q))) 8180 + call errquit('qmmm: Failed to initialize geometry',0, GEOM_ERR) 8181c 8182 if(.not.geom_masses_set(geom,ns,dbl_mb(i_m))) 8183 + call errquit('qmmm: Failed to initialize masses',0, GEOM_ERR) 8184 call geom_compute_values(geom) 8185c 8186 if(.not.geom_print(geom)) 8187 + call errquit('qmmm: Failed to print geom',0, RTDB_ERR) 8188c 8189 if(.not.geom_rtdb_store(irtdb,geom,geomname)) 8190 + call errquit('qmmm: Failed to store geom to rtdb',0, RTDB_ERR) 8191 8192 if(.not.geom_destroy(geom)) 8193 + call errquit('qmmm: Failed to destroy geometry',0, GEOM_ERR) 8194 8195c 8196 if(.not.ma_pop_stack(h_m)) 8197 & call errquit(pname//' 8198 > Failed to deallocate stack c_tmp',ns, 8199 & MA_ERR) 8200 8201 if(.not.ma_pop_stack(h_q)) 8202 & call errquit(pname//' 8203 > Failed to deallocate stack c_tmp',ns, 8204 & MA_ERR) 8205 8206 if(.not.ma_pop_stack(h_ctmp)) 8207 & call errquit(pname//' 8208 > Failed to deallocate stack c_tmp',ns, 8209 & MA_ERR) 8210 8211 if(.not.ma_pop_stack(h_t)) 8212 & call errquit(pname//' 8213 > Failed to deallocate stack i_itmp',ns, 8214 & MA_ERR) 8215 8216 close(fn_xyz) 8217 geom_create_from_file = .true. 8218 return 8219 8220 133 call errquit(pname//'error opening/closing '//filename,0, 0) 8221 134 call errquit(pname//'error reading xyz file'//message,0, 0) 8222 135 call errquit(pname//'error end of file at'//message,0, 0) 8223 8224 end 8225 8226 function geom_create_from_trj(in_xyz,nf,irtdb) 8227 implicit none 8228#include "mafdecls.fh" 8229#include "errquit.fh" 8230#include "msgids.fh" 8231#include "global.fh" 8232#include "inp.fh" 8233#include "stdio.fh" 8234#include "util.fh" 8235 character*(*) in_xyz 8236 integer nf 8237 integer irtdb 8238 logical geom_create_from_trj 8239c local variables 8240 integer ns 8241 integer i,j 8242 integer k 8243 logical otitle 8244 integer i_t,h_t 8245 integer i_m,h_m 8246 integer i_q,h_q 8247 integer i_ctmp,h_ctmp 8248 integer atn 8249 character*32 pname 8250 character*72 title 8251 character*16 tag 8252 character*16 buf 8253 character*255 filename 8254 character*255 xyzfile 8255 character*255 trjfile 8256 character*255 message 8257 8258 integer fn_xyz,fn_trj 8259 logical end_of_file 8260 logical master 8261 integer geom ! handle for geometry 8262 character*255 geomname ! for name of geometry 8263 8264 logical geom_create,geom_print 8265 external geom_create,geom_print 8266 logical geom_tag_to_element 8267 external geom_tag_to_element 8268 logical geom_cart_set,geom_masses_set 8269 external geom_cart_set,geom_masses_set 8270 logical geom_tag_to_default_mass 8271 external geom_tag_to_default_mass 8272 logical geom_rtdb_store,geom_destroy 8273 external geom_rtdb_store,geom_destroy 8274 8275 8276 master = ga_nodeid().eq.0 8277 pname = "geom_create_from_trj" 8278 geom_create_from_trj = .false. 8279c 8280c we assume that xyz file has a title 8281c ----------------------------------- 8282 otitle = .true. 8283c 8284c if(.not.util_xyz_nframes(in_xyz,fn_xyz)) 8285c > call errquit("cannot get number of frames",0,0) 8286c write(*,*) "number of frames ", fn_xyz 8287 8288 xyzfile = in_xyz(1:inp_strlen(in_xyz)) 8289 call util_file_name_resolve(xyzfile, .false.) 8290c 8291 filename = in_xyz(1:inp_strlen(xyzfile)) 8292 if(master) 8293 + call util_print_centered(luout, 8294 + "reading external xyz file "// 8295 + filename, 8296 + 40,.true.) 8297c 8298c prepare files for reading/writing 8299c --------------------------------- 8300 if(.not.util_get_io_unit(fn_xyz)) 8301 > call errquit("cannot get file number",0,0) 8302 filename = xyzfile 8303 open(fn_xyz,file=filename,form='formatted',status='old', 8304 $ err=133) 8305c 8306c 8307c seek frame 8308c ---------- 8309 if(.not.util_xyz_seek(fn_xyz,nf)) 8310 > call errquit("cannot get frame",0,0) 8311 8312c 8313c get number of atoms 8314c ------------------ 8315 message = " number of atoms " 8316 read(fn_xyz,*,err=134) ns 8317c 8318c temporary stack memory 8319c ---------------------- 8320 if(.not.ma_push_get(mt_byte,16*ns,'t',h_t,i_t)) 8321 + call errquit(pname//'Failed to allocate memory for t',ns, 8322 & MA_ERR) 8323 8324 if(.not.ma_push_get(mt_dbl,3*ns,'ctmp',h_ctmp,i_ctmp)) 8325 + call errquit( pname//'Failed to allocate memory for ctmp', 8326 + 3*ns, MA_ERR) 8327 8328 if(.not.ma_push_get(mt_dbl,ns,'q',h_q,i_q)) 8329 + call errquit(pname//'Failed to allocate memory for q',ns, 8330 & MA_ERR) 8331 8332 if(.not.ma_push_get(mt_dbl,ns,'m',h_m,i_m)) 8333 + call errquit('qmmm: Failed to allocate memory for m',ns, 8334 & MA_ERR) 8335 8336 8337c read the coords 8338c -------------------------------- 8339 message = " title field" 8340 if(otitle) 8341 + read(fn_xyz,*,err=134,end=135) title 8342 8343 do i=1,ns 8344 tag = " " 8345 read(fn_xyz,*,err=134,end=135) tag, 8346 + (dbl_mb(i_ctmp+3*(i-1)+k-1),k=1,3) 8347 do j=1,16 8348 byte_mb(i_t+16*(i-1)+j-1)=tag(j:j) 8349 end do 8350 8351 if (.not. 8352 & geom_tag_to_default_mass(tag,dbl_mb(i_m+i-1))) 8353 & call errquit(pname//'default mass failed', 8354 & 911, INPUT_ERR) 8355 8356 if (.not. 8357 & geom_tag_to_element(tag,buf,buf,atn)) 8358 & call errquit(pname//'default atn failed', 8359 & 911, INPUT_ERR) 8360 8361 dbl_mb(i_q+i-1)=atn 8362 end do 8363c call dscal(3*ns,1/cau2ang,dbl_mb(i_ctmp),1) 8364c 8365c 8366 geomname = "geometry" 8367 if (.not. geom_create(geom, geomname)) call errquit 8368 $ (pname//'geom_create failed !', 0, GEOM_ERR) 8369c 8370 if(.not.geom_cart_set(geom,ns,byte_mb(i_t), 8371 + dbl_mb(i_ctmp),dbl_mb(i_q))) 8372 + call errquit('qmmm: Failed to initialize geometry',0, GEOM_ERR) 8373c 8374 if(.not.geom_masses_set(geom,ns,dbl_mb(i_m))) 8375 + call errquit('qmmm: Failed to initialize masses',0, GEOM_ERR) 8376 call geom_compute_values(geom) 8377c 8378 if(.not.geom_print(geom)) 8379 + call errquit('qmmm: Failed to print geom',0, RTDB_ERR) 8380c 8381 if(.not.geom_rtdb_store(irtdb,geom,geomname)) 8382 + call errquit('qmmm: Failed to store geom to rtdb',0, RTDB_ERR) 8383 8384 if(.not.geom_destroy(geom)) 8385 + call errquit('qmmm: Failed to destroy geometry',0, GEOM_ERR) 8386 8387c 8388 if(.not.ma_pop_stack(h_m)) 8389 & call errquit(pname//' 8390 > Failed to deallocate stack c_tmp',ns, 8391 & MA_ERR) 8392 8393 if(.not.ma_pop_stack(h_q)) 8394 & call errquit(pname//' 8395 > Failed to deallocate stack c_tmp',ns, 8396 & MA_ERR) 8397 8398 if(.not.ma_pop_stack(h_ctmp)) 8399 & call errquit(pname//' 8400 > Failed to deallocate stack c_tmp',ns, 8401 & MA_ERR) 8402 8403 if(.not.ma_pop_stack(h_t)) 8404 & call errquit(pname//' 8405 > Failed to deallocate stack i_itmp',ns, 8406 & MA_ERR) 8407 8408 close(fn_xyz) 8409 geom_create_from_trj = .true. 8410 return 8411 8412 133 call errquit(pname//'error opening/closing '//filename,0, 0) 8413 134 call errquit(pname//'error reading xyz file'//message,0, 0) 8414 135 call errquit(pname//'error end of file at'//message,0, 0) 8415 8416 end 8417 8418C********************************************************************** 8419 8420 integer function geom_get_group_number(geom) 8421 implicit none 8422#include "nwc_const.fh" 8423#include "geomP.fh" 8424 integer geom 8425 geom_get_group_number = group_number(geom) 8426 return 8427 end 8428C> @} 8429 8430