1! 2! Dalton, a molecular electronic structure program 3! Copyright (C) by the authors of Dalton. 4! 5! This program is free software; you can redistribute it and/or 6! modify it under the terms of the GNU Lesser General Public 7! License version 2.1 as published by the Free Software Foundation. 8! 9! This program is distributed in the hope that it will be useful, 10! but WITHOUT ANY WARRANTY; without even the implied warranty of 11! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 12! Lesser General Public License for more details. 13! 14! If a copy of the GNU LGPL v2.1 was not distributed with this 15! code, you can obtain one at https://www.gnu.org/licenses/old-licenses/lgpl-2.1.en.html. 16! 17! 18C FILE: sirius/sirqmmm.F 19C Oct. 2009: JMO and AHS 20C Moved all routines relevant for the new QMMM code to this file and 21C added parallel QMMM routines. 22******************************************************************************* 23C /* Deck qmmmfck */ 24 SUBROUTINE QMMMFCK(DCAO,DVAO,FSOL,EQMMM,WRK,LWRK,IPRINT) 25 26#include "implicit.h" 27#include "dummy.h" 28#include "inftap.h" 29#include "priunit.h" 30#include "mxcent.h" 31#include "qmmm.h" 32#include "thrzer.h" 33#include "iratdef.h" 34#include "codata.h" 35#include "maxash.h" 36#include "maxorb.h" 37#include "infinp.h" 38#include "inforb.h" 39#include "infpri.h" 40#include "scbrhf.h" 41#include "maxaqn.h" 42#include "symmet.h" 43#include "orgcom.h" 44 45 DIMENSION DCAO(*), DVAO(*) 46 DIMENSION FSOL(*), WRK(LWRK) 47 48 CALL QENTER('QMMMFCK') 49 KDTAO = 1 50 KTAO = KDTAO + NNBASX 51 KEND = KTAO + NNBASX 52 LWRK1 = LWRK - KEND 53 IF (LWRK1 .LT. 0) CALL ERRWRK('QMMMFCK',-KEND,LWRK) 54 55 56C Get total density 57 IF (NASHT .EQ. 0) THEN 58 CALL PKSYM1(WRK(KDTAO),DCAO,NBAS,NSYM,-1) 59 ELSE 60 DO I = 1,NNBAST 61 IF (HSROHF) THEN 62 WRK(KTAO-1+I) = DCAO(I) 63 ELSE 64 WRK(KTAO-1+I) = DCAO(I) + DVAO(I) 65 END IF 66 END DO 67 CALL PKSYM1(WRK(KDTAO),WRK(KTAO),NBAS,NSYM,-1) 68 END IF 69 70C Modify the fock operator. Modification returned in FSOL. 71C QMMM contribution to the energy returned in EQMMM. 72 CALL QMMM_FCK_AO(FSOL,WRK(KDTAO),EQMMM,WRK(KEND),LWRK1,IPRINT) 73 74 CALL QEXIT('QMMMFCK') 75 RETURN 76 END 77 78C****************************************************************************** 79C /* Deck qmmm_fck_ao */ 80 SUBROUTINE QMMM_FCK_AO(FSOL,DCAO,ESOLT,WRK,LWRK,IPRINT) 81 82#include "implicit.h" 83#include "priunit.h" 84#include "dummy.h" 85#include "mxcent.h" 86#include "iratdef.h" 87#include "maxash.h" 88#include "maxorb.h" 89 90#include "qmmm.h" 91#include "mmtimes.h" 92#include "qm3.h" 93#include "inforb.h" 94#include "inftap.h" 95#include "infpri.h" 96#include "scbrhf.h" 97#include "maxaqn.h" 98#include "symmet.h" 99#include "orgcom.h" 100#include "infinp.h" 101#include "nuclei.h" 102#include "codata.h" 103#include "infpar.h" 104 105 DIMENSION WRK(LWRK) 106 DIMENSION FSOL(*),DCAO(*) 107 CHARACTER*8 LABINT(9*MXCENT) 108 LOGICAL TOFILE, TRIMAT, EXP1VL 109 LOGICAL EXCENT,LOCDEB 110 INTEGER NZERAL 111 DIMENSION INTREP(9*MXCENT), INTADR(9*MXCENT) 112 PARAMETER ( D2 = 2.0D0, DMINV2 = -0.50D0, D3 = 3.0D0, D6 = 6.0D0 ) 113 PARAMETER ( D3I = 1.0D0/3.0D0, D6I = 1.0D0/6.0D0) 114 115 LOGICAL FIRST 116 SAVE FIRST 117 DATA FIRST /.TRUE./ 118 119 CALL QENTER('QMMM_FCK_AO') 120 121 LOCDEB = .FALSE. 122 123 KTAO = 1 124 KWRK1 = KTAO + NNBASX 125 LWRK1 = LWRK - KWRK1 126 127 IF (LWRK1 .LT. 0) CALL ERRWRK('QMMM_FCK_AO',-KWRK1,LWRK) 128 129 CALL DZERO(WRK(KTAO),NNBASX) 130 131C The different static energy contributions 132 ECHART = 0.0D0 133 EDIPT = 0.0D0 134 EQUADT = 0.0D0 135 136C Backup diporg. We use diporg to transfer coordinates to int. program. 137 138 OBKPX = DIPORG(1) 139 OBKPY = DIPORG(2) 140 OBKPZ = DIPORG(3) 141 142 IF (MMTIME) DTIME = SECOND() 143#if defined(VAR_MPI) 144 IF (NODTOT.GE.1) THEN 145C All the corrections to the Fock/KS operator due to the static 146C multipoles when the calculation is done in parallel 147 CALL PARQMMM_M(DCAO,WRK(KTAO),ESOLT,LOCDEB, 148 & WRK(KWRK1),LWRK1,IPRINT) 149 ELSE 150#endif 151C 1) The charge correction to the Fock/KS operator 152 IF (NMULT .GE. 0) CALL QMMM_CHARGE(DCAO,ESOLT,WRK(KTAO), 153 & LOCDEB,FIRST,WRK(KWRK1),LWRK1,IPRINT) 154C 2) The dipole correction to the Fock/KS operator 155 IF (NMULT .GE. 1) CALL QMMM_DIPOLE(DCAO,ESOLT,WRK(KTAO), 156 & LOCDEB,FIRST,WRK(KWRK1),LWRK1,IPRINT) 157 158C 3) The quadrupole correction to the Fock/KS operator 159 IF (NMULT .GE. 2) CALL QMMM_QUADPOLE(DCAO,ESOLT,WRK(KTAO), 160 & LOCDEB,FIRST,WRK(KWRK1),LWRK1,IPRINT) 161 162 163#if defined(VAR_MPI) 164 ENDIF ! nodtot .ge. 1 165#endif 166 IF (MMTIME) THEN 167 DTIME = SECOND() - DTIME 168 TMMMULPOL = TMMMULPOL + DTIME 169 ENDIF 170 171 IF ( (IPRINT.GT.1) .OR. (LOCDEB) ) THEN 172 write(lupri,*) 173 write(lupri,*) 'MM-charge QM density interaction energy:',ECHART 174 write(lupri,*) 'MM-dipole QM density interaction energy:',EDIPT 175 write(lupri,*) 'MM-quadr. QM density interaction energy:',EQUADT 176 ENDIF 177 178C 5) The polarization correction to the Fock/KS operator 179 180 IF (MMTIME) DTIME = SECOND() 181 IF (IPOLTP .GT. 0) CALL QMMM_POLARI(DCAO,ESOLT,WRK(KTAO), 182 & LOCDEB,WRK(KWRK1),LWRK1,IPRINT) 183 IF (MMTIME) THEN 184 DTIME = SECOND() - DTIME 185 TMMPOL = TMMPOL + DTIME 186 ENDIF 187 188C Finally, put back the dipole origin 189 190 DIPORG(1) = OBKPX 191 DIPORG(2) = OBKPY 192 DIPORG(3) = OBKPZ 193 194 CALL PKSYM1(WRK(KTAO),FSOL,NBAS,NSYM,+1) 195 CALL QEXIT('QMMM_FCK_AO') 196 197 IF (FIRST) THEN 198 FIRST = .FALSE. 199 END IF 200 201 RETURN 202 END 203C****************************************************************************** 204C /* Deck qmmm_charge */ 205 SUBROUTINE QMMM_CHARGE(DCAO,ESOLT,TAO,LOCDEB,FIRST, 206 & WRK,LWRK,IPRINT) 207 208#include "implicit.h" 209#include "priunit.h" 210#include "dummy.h" 211#include "mxcent.h" 212#include "iratdef.h" 213#include "maxash.h" 214#include "maxorb.h" 215 216#include "qmmm.h" 217#include "qm3.h" 218#include "inforb.h" 219#include "inftap.h" 220#include "infpri.h" 221#include "scbrhf.h" 222#include "maxaqn.h" 223#include "symmet.h" 224#include "orgcom.h" 225#include "infinp.h" 226#include "nuclei.h" 227#include "codata.h" 228#include "infpar.h" 229 230 DIMENSION WRK(LWRK), TAO(NNBASX), DCAO(*) 231 LOGICAL LOCDEB, FIRST 232 233 CALL QENTER('QMMM_CHARGE') 234 235 KTAO = 1 236 KNSEL = KTAO + NNBASX 237 KNSNUC = KNSEL + MMCENT 238 KLAST = KNSNUC + MMCENT 239 LWRK2 = LWRK - KLAST + 1 240 241 IF (LWRK2 .LT. 0) CALL ERRWRK('QMMM_CHARGE 1',-KLAST,LWRK) 242 243 FAC1 = 1.0D0 244 EXPNST = 0.0D0 245 ECHCH = 0.0D0 246 247 CALL DZERO(WRK(KTAO),NNBASX) 248 249 DO 100 I = 1,MMCENT 250 251 DIST2 = (MMCORD(1,I)-QMCOM(1))**2 + 252 * (MMCORD(2,I)-QMCOM(2))**2 + 253 * (MMCORD(3,I)-QMCOM(3))**2 254 DIST = SQRT(DIST2) 255 256 IF (DIST .GT. RCUTMM) THEN 257 WRK(KNSEL + I - 1) = 0.0D0 258 WRK(KNSNUC + I - 1) = 0.0D0 259 IF (LOCDEB) THEN 260 WRITE(LUPRI,*) 'Skipping charge ', I 261 ENDIF 262 GOTO 100 263 ENDIF 264 265 CALL CHARGE_ITER(I,DCAO,WRK(KNSEL+I-1),WRK(KNSNUC+I-1),LOCDEB, 266 * WRK(KTAO),WRK(KLAST),LWRK2,IPRINT) 267 EXPNST = EXPNST + WRK(KNSEL+I-1) 268 ECHCH = ECHCH + WRK(KNSNUC+I-1) 269 270 100 CONTINUE 271C Transfering the QM nuclei - MM multipole energy contribution 272C to the CC part of the code. We start with the charge contribution 273 ENUMUL = 0.0D0 274 ENUMUL = ECHCH 275 276 IF (FIRST) THEN 277C Write integrals to file 278 LUQMMM = -1 279 IF (LUQMMM .LT. 0) THEN 280 CALL GPOPEN(LUQMMM,'MU0INT','UNKNOWN','','', 281 & IDUMMY,.FALSE.) 282 ENDIF 283 REWIND(LUQMMM) 284 WRITE (LUQMMM) (WRK(KTAO+J-1), J=1,NNBASX) 285 CALL GPCLOSE(LUQMMM,'KEEP') 286 ENDIF 287 288 CALL DAXPY(NNBASX,1.0D0,WRK(KTAO),1,TAO,1) 289 290 ECHART = EXPNST + ECHCH 291 ESOLT = ECHART 292 293 IF ( (IPRINT.GT.5) .OR. (LOCDEB) ) THEN 294 WRITE(LUPRI,*) 295 WRITE(LUPRI,*) ' Center Charge-electronic Charge-nuclear Total' 296 DO 102 I = 1,MMCENT 297 ELTEMP = WRK(KNSEL + I - 1) + WRK(KNSNUC + I - 1) 298 WRITE(LUPRI,*) I,WRK(KNSEL + I - 1),WRK(KNSNUC + I - 1),ELTEMP 299 102 CONTINUE 300 301 WRITE(LUPRI,*) 302 WRITE(LUPRI,*) ' Total ' 303 WRITE(LUPRI,*) EXPNST, ECHCH, EXPNST+ECHCH 304 WRITE(LUPRI,*) 305 ENDIF 306 307 CALL QEXIT('QMMM_CHARGE') 308 309 RETURN 310 END 311C****************************************************************************** 312C /* Deck qmmm_dipole */ 313 SUBROUTINE QMMM_DIPOLE(DCAO,ESOLT,TAO,LOCDEB,FIRST, 314 & WRK,LWRK,IPRINT) 315 316#include "implicit.h" 317#include "priunit.h" 318#include "dummy.h" 319#include "mxcent.h" 320#include "iratdef.h" 321#include "maxash.h" 322#include "maxorb.h" 323 324#include "qmmm.h" 325#include "qm3.h" 326#include "inforb.h" 327#include "inftap.h" 328#include "infpri.h" 329#include "scbrhf.h" 330#include "maxaqn.h" 331#include "symmet.h" 332#include "orgcom.h" 333#include "infinp.h" 334#include "nuclei.h" 335#include "codata.h" 336#include "infpar.h" 337 338 DIMENSION WRK(LWRK), TAO(NNBASX), DCAO(*) 339 LOGICAL LOCDEB, FIRST 340 341 CALL QENTER('QMMM_DIPOLE') 342 343 KTAO = 1 344 KNSEL = KTAO + NNBASX 345 KNSNUC = KNSEL + MMCENT 346 KLAST = KNSNUC + MMCENT 347 LWRK2 = LWRK - KLAST + 1 348 349 IF (LWRK2 .LT. 0) CALL ERRWRK('QMMM_DIPOLE 1',-KLAST,LWRK) 350 351 FAC1 = 1.0D0 352 FACM1 = -1.0D0 353 EMUL1T = 0.0D0 354 ELOCT = 0.0D0 355 356 CALL DZERO(WRK(KTAO),NNBASX) 357 358 DO 200 I = 1,MMCENT 359 360 DIST2 = (MMCORD(1,I)-QMCOM(1))**2 + 361 * (MMCORD(2,I)-QMCOM(2))**2 + 362 * (MMCORD(3,I)-QMCOM(3))**2 363 DIST = SQRT(DIST2) 364 365 IF (DIST .GT. RCUTMM) THEN 366 WRK(KNSEL + I - 1) = 0.0D0 367 WRK(KNSNUC + I - 1) = 0.0D0 368 IF (LOCDEB) THEN 369 WRITE(LUPRI,*) 'Skipping dipole ', I 370 ENDIF 371 GOTO 200 372 ENDIF 373 374 CALL DIPOLE_ITER(I,DCAO,WRK(KNSEL+I-1),WRK(KNSNUC+I-1),LOCDEB, 375 * WRK(KTAO),WRK(KLAST),LWRK2,IPRINT) 376 EMUL1T = EMUL1T + WRK(KNSEL+I-1) 377 ELOCT = ELOCT + WRK(KNSNUC+I-1) 378 379 200 CONTINUE 380 381C Add up QM nuclei - multipole energy contributions to be used in CC 382 ENUMUL = ENUMUL + ELOCT 383 IF (FIRST) THEN 384C Write integrals to file 385 LUQMMM = -1 386 IF (LUQMMM .LT. 0) THEN 387 CALL GPOPEN(LUQMMM,'MU1INT','UNKNOWN','','', 388 & IDUMMY,.FALSE.) 389 ENDIF 390 REWIND(LUQMMM) 391 WRITE (LUQMMM) (WRK(KTAO+J-1), J=1,NNBASX) 392 CALL GPCLOSE(LUQMMM,'KEEP') 393 ENDIF 394 395 CALL DAXPY(NNBASX,1.0D0,WRK(KTAO),1,TAO,1) 396 397 EDIPT = EMUL1T + ELOCT 398 ESOLT = ESOLT + EDIPT 399 400 IF ( (IPRINT.GT.5) .OR. (LOCDEB) ) THEN 401 WRITE(LUPRI,*) 402 WRITE(LUPRI,*) ' Center Dipole-electronic Dipole-nuclear Total' 403 DO 202 I = 1,MMCENT 404 ETEMP = WRK(KNSEL + I - 1) + WRK(KNSNUC + I - 1) 405 WRITE(LUPRI,*) I,WRK(KNSEL + I - 1),WRK(KNSNUC + I - 1),ETEMP 406 202 CONTINUE 407 408 WRITE(LUPRI,*) 409 WRITE(LUPRI,*) ' Total ' 410 WRITE(LUPRI,*) EMUL1T, ELOCT, EMUL1T+ELOCT 411 WRITE(LUPRI,*) 412 ENDIF 413 414 CALL QEXIT('QMMM_DIPOLE') 415 416 RETURN 417 END 418C****************************************************************************** 419C /* Deck qmmm_quadpole */ 420 SUBROUTINE QMMM_QUADPOLE(DCAO,ESOLT,TAO,LOCDEB,FIRST, 421 & WRK,LWRK,IPRINT) 422 423#include "implicit.h" 424#include "priunit.h" 425#include "dummy.h" 426#include "mxcent.h" 427#include "iratdef.h" 428#include "maxash.h" 429#include "maxorb.h" 430 431#include "qmmm.h" 432#include "qm3.h" 433#include "inforb.h" 434#include "inftap.h" 435#include "infpri.h" 436#include "scbrhf.h" 437#include "maxaqn.h" 438#include "symmet.h" 439#include "orgcom.h" 440#include "infinp.h" 441#include "nuclei.h" 442#include "codata.h" 443#include "infpar.h" 444 445 DIMENSION WRK(LWRK), TAO(NNBASX), DCAO(*) 446 LOGICAL LOCDEB, FIRST 447 448 CALL QENTER('QMMM_QUADPOLE') 449 450 KTAO = 1 451 KNSEL = KTAO + NNBASX 452 KNSNUC = KNSEL + MMCENT 453 KLAST = KNSNUC + MMCENT 454 LWRK2 = LWRK - KLAST + 1 455 456 IF (LWRK2 .LT. 0) CALL ERRWRK('QMMM_QUADPOLE 1',-KLAST,LWRK) 457 458 FAC1 = 1.0D0 459 EMUL2T = 0.0D0 460 ELOCT = 0.0D0 461 462 CALL DZERO(WRK(KTAO),NNBASX) 463 464 DO 300 I = 1,MMCENT 465 466 DIST2 = (MMCORD(1,I)-QMCOM(1))**2 + 467 * (MMCORD(2,I)-QMCOM(2))**2 + 468 * (MMCORD(3,I)-QMCOM(3))**2 469 DIST = SQRT(DIST2) 470 471 IF (DIST .GT. RCUTMM) THEN 472 WRK(KNSEL + I - 1) = 0.0D0 473 WRK(KNSNUC + I - 1) = 0.0D0 474 IF (LOCDEB) THEN 475 WRITE(LUPRI,*) 'Skipping quadrupole ', I 476 ENDIF 477 GOTO 300 478 ENDIF 479 480 CALL QUADPOLE_ITER(I,DCAO,WRK(KNSEL+I-1),WRK(KNSNUC+I-1),LOCDEB, 481 * WRK(KTAO),WRK(KLAST),LWRK2,IPRINT) 482 EMUL2T = EMUL2T + WRK(KNSEL+I-1) 483 ELOCT = ELOCT + WRK(KNSNUC+I-1) 484 485 300 CONTINUE 486 487C Add up QM nuclei - multipole energy contributions to be used in CC 488 ENUMUL = ENUMUL + ELOCT 489 IF (FIRST) THEN 490C Write integrals to file 491 LUQMMM = -1 492 IF (LUQMMM .LT. 0) THEN 493 CALL GPOPEN(LUQMMM,'MU2INT','UNKNOWN','','', 494 & IDUMMY,.FALSE.) 495 ENDIF 496 REWIND(LUQMMM) 497 WRITE (LUQMMM) (WRK(KTAO+J-1), J=1,NNBASX) 498 CALL GPCLOSE(LUQMMM,'KEEP') 499 ENDIF 500 501 CALL DAXPY(NNBASX,1.0D0,WRK(KTAO),1,TAO,1) 502 503 EQUADT = EMUL2T + ELOCT 504 ESOLT = ESOLT + EQUADT 505 506 IF ( (IPRINT.GT.5) .OR. (LOCDEB) ) THEN 507 WRITE(LUPRI,*) 508 WRITE(LUPRI,*) ' Center Quadr.-electronic Quadr.-nuclear Total' 509 DO 302 I = 1,MMCENT 510 ETEMP = WRK(KNSEL + I - 1) + WRK(KNSNUC + I - 1) 511 WRITE(LUPRI,*) I,WRK(KNSEL + I - 1),WRK(KNSNUC + I - 1),ETEMP 512 302 CONTINUE 513 514 WRITE(LUPRI,*) 515 WRITE(LUPRI,*) ' Total ' 516 WRITE(LUPRI,*) EMUL2T, ELOCT, EMUL2T+ELOCT 517 WRITE(LUPRI,*) 518 ENDIF 519 520 CALL QEXIT('QMMM_QUADPOLE') 521 522 RETURN 523 END 524 525C****************************************************************************** 526C /* Deck qmmm_polari */ 527 SUBROUTINE QMMM_POLARI(DCAO,ESOLT,TAO,LOCDEB, 528 & WRK,LWRK,IPRINT) 529C 530#include "implicit.h" 531#include "priunit.h" 532#include "dummy.h" 533#include "mxcent.h" 534#include "iratdef.h" 535#include "maxash.h" 536#include "maxorb.h" 537#include "qmmm.h" 538#include "mmtimes.h" 539#include "qm3.h" 540#include "inforb.h" 541#include "inftap.h" 542#include "infpri.h" 543#include "scbrhf.h" 544#include "maxaqn.h" 545#include "symmet.h" 546#include "orgcom.h" 547#include "infinp.h" 548#include "nuclei.h" 549#include "codata.h" 550#include "infpar.h" 551 552 DIMENSION WRK(LWRK), TAO(NNBASX), DCAO(*) 553 CHARACTER*8 LABINT(9*MXCENT) 554 LOGICAL TOFILE, TRIMAT, EXP1VL, EXCENT, LOCDEB, LSKIP 555 INTEGER NZERAL 556 DIMENSION INTREP(9*MXCENT), INTADR(9*MXCENT) 557 PARAMETER ( D2 = 2.0D0, DMINV2 = -0.50D0, D3 = 3.0D0, D6 = 6.0D0 ) 558 PARAMETER ( D3I = 1.0D0/3.0D0, D6I = 1.0D0/6.0D0) 559 560 CALL QENTER('QMMM_POLARI') 561 562C Zero out a list of centers having zero polarizability. We don't 563C know yet the number of zero polarizabilities so we take the 564C worst case, i.e. MXMMCT, for the length of this list 565 566 DO 443 I=1,MXMMCT 567 ZEROAL(I) = 0 568 443 CONTINUE 569c 570c Check if the polarizability is equal to zero; if so put -1 on 571c the list for this center. If not equal to zero put +1 on the 572c list for this center and if not touched upon leave zero 573 574 LIZA = 1 ! Counts centers having polarizability equal to zero 575 576 DO 400 I=1,MMCENT 577 578 IF (IPOLTP .EQ. 1) THEN 579 ANORM2 = 3*(POLIMM(I)**2) 580 ANORM = SQRT(ANORM2) 581 IF (ANORM .LE. THRMM) THEN 582 ZEROAL(I) = -1 583 LIZA = LIZA + 1 584 ELSE 585 ZEROAL(I) = 1 586 ENDIF 587 ENDIF 588 589 IF (IPOLTP .EQ. 2) THEN 590 ANORM2 = POLMM(1,I)**2 + 2*(POLMM(2,I)**2) + 591 & 2*(POLMM(3,I)**2) + 592 & POLMM(4,I)**2 + 2*(POLMM(5,I)**2) + 593 & POLMM(6,I)**2 594 ANORM = SQRT(ANORM2) 595 IF (ANORM .LE. THRMM) THEN 596 ZEROAL(I) = -1 597 LIZA = LIZA + 1 598 ELSE 599 ZEROAL(I) = 1 600 ENDIF 601 ENDIF 602 603 400 CONTINUE 604 605 NZERAL = LIZA - 1 606 NNZAL = MMCENT - NZERAL ! Number of MM centers with ALPHA .NE. 0 607 608 IF ( (IPRINT.GT.1) .OR. (LOCDEB) ) THEN 609 WRITE(LUPRI,*) 610 WRITE(LUPRI,*) ' Number of polarizable sites: ', NNZAL 611 WRITE(LUPRI,*) 612 ENDIF 613 614 IF (MMMAT) THEN 615 616 KINVMAT = 1 617 KINDMOM = KINVMAT + 3*NNZAL*(3*NNZAL+1)/2 ! for packed response matrix 618 KMAT = KINDMOM + 3*NNZAL ! List for induced dipoles 619 KIPVT = KMAT + 3*NNBASX ! For Rr_a integrals 620 KWRKV = KIPVT + 3*NNZAL ! For matrix inv. 621 KTAO = KWRKV + 3*NNZAL ! For matrix inv. 622 KWRK2 = KTAO + NNBASX 623 LWRK2 = LWRK - KWRK2 + 1 624 625 IF (LWRK2 .LT. 0) THEN 626 CALL ERRWRK('QMMM_POLARI 1',-KWRK2,LWRK) 627 ENDIF 628 629 CALL DZERO(WRK(KINVMAT), 3*NNZAL*(3*NNZAL+1)/2) 630 CALL DZERO(WRK(KINDMOM), 3*NNZAL) 631 CALL DZERO(WRK(KIPVT), 3*NNZAL) 632 CALL DZERO(WRK(KWRKV), 3*NNZAL) 633 CALL DZERO(WRK(KMAT), 3*NNBASX) 634 635C FIXDIP assumes induced dipoles are calculated in a previous run. 636C Mainly due to debugging. Assumes identical molecules and order 637C of atoms in previous and current run. 638 639 IF (.NOT. FIXDIP) THEN 640 CALL GET_IND_DIPOLES_1(DCAO,NNZAL,WRK(KINVMAT),WRK(KINDMOM), 641 & WRK(KWRK2),WRK(KIPVT),WRK(KWRKV), 642 & LWRK2,IPRINT) 643 ELSE 644 WRITE(LUPRI,*) 'Ind. dips. from a prev. calc. read from file' 645 CALL GET_FROM_FILE_1('INDUCED_DIPOLES',NNZAL,WRK(KINDMOM)) 646 ENDIF 647 ELSE IF (MMITER) THEN 648 649 KINDMOM = 1 650 KMAT = KINDMOM + 3*NNZAL ! List for induced dipoles 651 KTAO = KMAT + 3*NNBASX 652 KWRK2 = KTAO + NNBASX 653 LWRK2 = LWRK - KWRK2 + 1 654 655 IF (LWRK2 .LT. 0) THEN 656 CALL ERRWRK('QMMM_POLARI 2',-KWRK2,LWRK) 657 ENDIF 658 659 CALL DZERO(WRK(KINDMOM),(3*NNZAL)) 660 661C FIXDIP assumes induced dipoles are calculated in a previous run. 662C Mainly due to debugging. Assumes identical molecules and order 663C of atoms in previous and current run. 664 665 IF (.NOT. FIXDIP) THEN 666 IF (MMTIME) DTIME = SECOND() 667 CALL GET_IND_DIPOLES_2(DCAO,NNZAL,WRK(KINDMOM), 668 & WRK(KWRK2),LWRK2,IPRINT) 669 IF (MMTIME) THEN 670 DTIME = SECOND() - DTIME 671 TMMGID2 = TMMGID2 + DTIME 672 ENDIF 673 ELSE 674 WRITE(LUPRI,*) 'Ind. dips. from a prev. calc. read from file' 675 CALL GET_FROM_FILE_1('INDUCED_DIPOLES',NNZAL,WRK(KINDMOM)) 676 ENDIF 677 678 ENDIF 679 680C Compute polarization contributions to the Fock/KS matrix and 681C total solvation energy 682 683 FACM1 = -1.0D0 684 IINIM = 0 ! important should be zero due to the indexing used ! 685 686 EDELD = 0.0D0 ! For interaction with electronic density 687 EDNUC = 0.0D0 ! For interaction with QM nuclei 688 ED0MOM = 0.0D0 ! For interaction with point-charges 689 ED1MOM = 0.0D0 ! For interaction with permanent dipoles 690 ED2MOM = 0.0D0 ! For interaction with quadrupoles 691 EDMULT = 0.0D0 ! For interaction with permanent multipoles 692 EPOLT = 0.0D0 ! Total polarization energy 693 694 CALL DZERO(WRK(KTAO),NNBASX) 695 696#if defined(VAR_MPI) 697 IF (NODTOT .GE. 1) THEN 698 CALL MM_POLAR_CONTR_M(DCAO(1),WRK(KTAO),WRK(KINDMOM), 699 & WRK(KWRK2),LWRK2,IPRINT) 700 ELSE 701#endif 702 KEDALL = KWRK2 703 KWRK3 = KEDALL + 6 704 LWRK3 = LWRK - KWRK3 + 1 705 706 DO 500 I=1,MMCENT 707 708 IF (ZEROAL(I) .EQ. -1) GOTO 500 709 710 CALL GET_POL_CONTR(I,WRK(KINDMOM+IINIM),WRK(KEDALL), 711 & DCAO,WRK(KTAO),WRK(KWRK3),LWRK3) 712 713 EDELD = EDELD + WRK(KEDALL) 714 EDNUC = EDNUC + WRK(KEDALL+1) 715 ED0MOM = ED0MOM + WRK(KEDALL+2) 716 ED1MOM = ED1MOM + WRK(KEDALL+3) 717 ED2MOM = ED2MOM + WRK(KEDALL+4) 718 719 IINIM = IINIM + 3 720 721 500 CONTINUE 722 723 EDMULT = ED0MOM + ED1MOM + ED2MOM 724 725#if defined(VAR_MPI) 726 ENDIF ! IF (NODTOT .GE. 1) ... ELSE 727#endif 728 CALL DAXPY(NNBASX,1.0D0,WRK(KTAO),1,TAO,1) 729 730 EPOLT = EDELD + EDNUC + EDMULT 731 732 ESOLT = ESOLT + EPOLT 733 734 IF (IPRINT .GT. 1) THEN 735 WRITE(LUPRI,*) 736 WRITE(LUPRI,5001) 737 WRITE(LUPRI,*) 738 WRITE(LUPRI,5002) EDELD 739 WRITE(LUPRI,5003) EDNUC 740 WRITE(LUPRI,5004) EDMULT 741 WRITE(LUPRI,*) 742 WRITE(LUPRI,5005) EPOLT 743 WRITE(LUPRI,*) 744 ENDIF 745 746C IF (MMPROP) CALL MM_PROPS(WRK(KWRK2),LWRK2,IPRINT) 747 748 5001 FORMAT(' Polarization energy: ') 749 5002 FORMAT(' Electronic contribution: ',F15.9) 750 5003 FORMAT(' Nuclear contribution: ',F15.9) 751 5004 FORMAT(' Multipole contribution: ',F15.9) 752 5005 FORMAT(' Total: ',F15.9) 753 754 755 756 CALL QEXIT('QMMM_POLARI') 757 758 RETURN 759 END 760C 761C****************************************************************************** 762C /* Deck qmmmfckmo */ 763 SUBROUTINE QMMMFCKMO(CMO,FSOL,WRK,LWRK,IPRINT) 764C 765C Construct the QMMM contribution to the Fock-matrix in MO basis 766C 767#include "implicit.h" 768#include "priunit.h" 769#include "dummy.h" 770#include "mxcent.h" 771#include "qmmm.h" 772#include "inforb.h" 773#include "infopt.h" 774C 775 DIMENSION CMO(*), FSOL(*), WRK(LWRK) 776C 777 CALL QENTER('QMMMFCKMO') 778C 779 KDV = 1 780 KDENS = KDV + N2BASX 781 KDVS = KDENS + NNBASX 782 KFSOLAO = KDVS + NNBASX 783 KUCMO = KFSOLAO + NNBASX 784 KZERO = KUCMO + NORBT*NBAST 785 KWRK = KZERO + NNBASX 786 LWRK1 = LWRK - KWRK 787 788 IF (LWRK1 .LT. 0) CALL ERRWRK('QMMMFCKMO',-KWRK,LWRK) 789 790 CALL DZERO(WRK(KZERO),NNBASX) 791 792C Construct the density matrix 793 CALL FCKDEN((NISHT.GT.0),.FALSE.,WRK(KDV), 794 * DUMMY,CMO,DUMMY,WRK(KWRK),LWRK1) 795 796 CALL DGEFSP(NBAST,WRK(KDV),WRK(KDVS)) 797 CALL PKSYM1(WRK(KDVS),WRK(KDENS),NBAS,NSYM,1) 798 799C Construct the QMMM contribution to the Fock-matrix in AO 800C For the openshell density we Put in zero as this is now included 801C in 802C KDENS already. 803 CALL QMMMFCK(WRK(KDENS),WRK(KZERO),WRK(KFSOLAO),ESOLT, 804 * WRK(KWRK),LWRK1,IPRINT) 805 806C Transform to mo 807 CALL UPKCMO(CMO,WRK(KUCMO)) 808 CALL UTHU(WRK(KFSOLAO),FSOL,WRK(KUCMO),WRK(KWRK), 809 & NBAST,NORBT) 810C 811 CALL QEXIT('QMMMFCKMO') 812 RETURN 813 END 814C****************************************************************************** 815C /* Deck GET_IND_DIPOLES_1 */ 816 SUBROUTINE GET_IND_DIPOLES_1(DCAO,POLDIM,INVMAT,INDMOM,WRK,IPVT, 817 & WRKV,LWRK,IPRINT) 818C 819C A subroutine to calculate induced dipole moments 820C 821C Input: 822C 823C DCAO - density matrix in AO basis 824C POLDIM - number of polarizable MM centers. Actually in common as 825C NNZAL. 826C 827C Output: 828C 829C INVMAT - the classical response matrix, i.e. [ALPHA^(-1) - T]^(-1) 830C INDMOM - a vector containing induced dipole moments 831C 832C From Common 833C 834C ZEROAL - a vector containing +1 for polarizable MM centers and -1 835C for non-polarizable 836C 837C Oct. 2009: JMO 838C Changed the routines used to construct the classical response matrix 839C to more efficient ones that use the fact that it is symmetric. 840C Sep 2010: JMO & KS 841C Starting sharing of DFT/MM and CC/MM field routines 842C Oct 2010: AHS 843C Sharing of parallel and serial routines 844C Jan 2011: JMO 845C Construct the classical response matrix using packed storage. 846#include "implicit.h" 847#include "priunit.h" 848#include "dummy.h" 849#include "mxcent.h" 850#include "iratdef.h" 851#include "maxash.h" 852#include "maxorb.h" 853#include "qmmm.h" 854#include "qm3.h" 855#include "inforb.h" 856#include "inftap.h" 857#include "infpri.h" 858#include "scbrhf.h" 859#include "maxaqn.h" 860#include "symmet.h" 861#include "orgcom.h" 862#include "infinp.h" 863#include "nuclei.h" 864#include "codata.h" 865#include "infpar.h" 866 867 CHARACTER LLAB 868 LOGICAL EXCENT,FNDLAB, LSKIP 869 LOGICAL TOFILE,TRIMAT,EXP1VL,LOCDEB 870 INTEGER POLDIM, IPVT 871 DOUBLE PRECISION WRK, INVMAT, INDMOM, WRKV 872 DIMENSION INVMAT(3*POLDIM*(3*POLDIM+1)/2) 873 DIMENSION INDMOM(3*POLDIM) 874 DIMENSION IPVT(3*POLDIM) 875 DIMENSION WRKV(3*POLDIM) 876 DIMENSION INTREP(9*MXCENT), INTADR(9*MXCENT) 877 DIMENSION WRK(LWRK) 878 DIMENSION DCAO(*) 879 880 CHARACTER*8 LABINT(9*MXCENT) 881 882 PARAMETER ( D2 = 2.0D0, D0 = 0.0D0, D1 = 1.0D0 ) 883 PARAMETER ( D3I = 1.0D0/3.0D0, D6I = 1.0D0/6.0D0) 884 885 CALL QENTER('GET_IND_DIPOLES_1') 886 887 LOCDEB = .FALSE. 888 889 IF (POLDIM .NE. NNZAL) THEN 890 WRITE(LUPRI,*) 'ERROR in no. of polarizabilities' 891 CALL QUIT('ERROR in GET_IND_DIPOLES_1') 892 ENDIF 893 894C Allocate memory for electric field integrals and electric fields 895C (the order KELF KELFEL KELFNU has to be kept because of QMMM_POLARI_M1! AHS) 896 KMAT = 1 897 KELF = KMAT + 3*NNBASX ! For electric field integrals 898 KELFEL = KELF + 3*POLDIM ! For total OR (if SPLDIP) multipole electric field 899 IF (SPLDIP) THEN 900 KELFNU = KELFEL + 3*POLDIM ! For electronic electric field 901 KIMMUL = KELFNU + 3*POLDIM ! For nuclear electric field 902 KIMNUC = KIMMUL + 3*POLDIM ! For induced moments due to permanent multipoles 903 KIMELD = KIMNUC + 3*POLDIM ! For induced moments due to QM nuclei 904 KEND = KIMELD + 3*POLDIM ! For induced moments due to electronic density 905 ELSE 906 KEND = KELFEL 907 ENDIF 908 LWRK1 = LWRK - KEND 909 IF (LWRK1 .LT. 0) CALL ERRWRK('GET_IND_DIPOLES_1',-KEND,LWRK) 910 911 CALL DZERO(WRK(KMAT),3*NNBASX) 912 CALL DZERO(WRK(KELF),3*POLDIM) 913 IF (SPLDIP) THEN 914 CALL DZERO(WRK(KELFEL),3*POLDIM) 915 CALL DZERO(WRK(KELFNU),3*POLDIM) 916 CALL DZERO(WRK(KIMMUL),3*POLDIM) 917 CALL DZERO(WRK(KIMNUC),3*POLDIM) 918 CALL DZERO(WRK(KIMELD),3*POLDIM) 919 ENDIF 920 921C Form F vector due to permanent MM moments 922#if defined(VAR_MPI) 923 IF (NODTOT .GE. 1) THEN 924 CALL MM_FIELD_M1(DCAO(1),WRK(KELF),POLDIM, 925 & WRK(KEND),LWRK1,IPRINT) 926 ELSE 927#endif 928 LRI = 1 ! Row index in the large matrix 929 930 DO 200 I=1,MMCENT 931 932 IF (ZEROAL(I) .EQ. -1) GOTO 200 933 934 CALL GET_FIELD(I,LRI,WRK(KELF),WRK(KELFEL),WRK(KELFNU), 935 & DCAO,LOCDEB,WRK(KEND),LWRK1) 936 LRI = LRI + 3 937 200 CONTINUE 938 939#if defined(VAR_MPI) 940 ENDIF 941#endif 942 NDIM = 3*POLDIM 943 944 IF (LOCDEB) THEN 945 WRITE(LUPRI,*) 'Done generating the F-Vector' 946 WRITE(LUPRI,*) 'Done generating the interaction matrix' 947 WRITE(LUPRI,*) 'F-Vector' 948 DO 777 KK=1,NDIM 949 WRITE(LUPRI,*) WRK(KELF+KK-1) 950 777 CONTINUE 951 ENDIF 952 953C If needed, construct the [ALPHA^(-1) - T]^(-1) matrix and write it to 954C file. ELSE: read matrix from the file. CONMAT = CONstruct MATrix 955 956 IF (CONMAT) THEN 957 958 CALL MAKE_QMMM_INVERSE_RESPONSE_MATRIX(INVMAT,POLDIM) ! Construct inverse response matrix 959 960 IF (IPRINT .GT. 1) THEN 961 WRITE(LUPRI,*) 962 WRITE(LUPRI,*) ' The classical response matrix is'// 963 & ' explicitly constructed. ' 964 WRITE(LUPRI,*) ' Dimension is: ',NDIM 965 WRITE(LUPRI,*) 966 ENDIF 967 968 IF ((IPRINT.GT.15) .OR. (LOCDEB)) THEN 969 WRITE(LUPRI,*)'Matrix to be inverted: ' 970 DO I = 1, NDIM*(NDIM+1)/2 971 WRITE(LUPRI,*) INVMAT(I) 972 END DO 973 END IF 974 975 IF (IPRINT.GT.1) CALL TIMER('START ',TIMSTR,TIMEND) 976 977C Construct the classical response matrix 978 CALL DSPTRF('L', NDIM, INVMAT, IPVT, INFO) 979 IF (INFO .NE. 0) THEN 980 CALL QUIT('ERROR: construction of the classical'// 981 & ' response matrix failed!') 982 END IF 983 CALL DSPTRI('L', NDIM, INVMAT, IPVT, WRKV, INFO) 984 IF (INFO .NE. 0) THEN 985 CALL QUIT('ERROR: construction of the classical response'// 986 & ' matrix failed!') 987 END IF 988 IF(IPRINT.GT.1) CALL TIMER('MATINV',TIMSTR,TIMEND) 989 990 IF ( (IPRINT.GT.15) .OR. (LOCDEB) ) THEN 991 WRITE(LUPRI,*)'Classical response matrix: ' 992 DO I = 1, NDIM*(NDIM+1)/2 993 WRITE(LUPRI,*) INVMAT(I) 994 END DO 995 END IF 996 997C We write the classical response matrix to file 998 999 LUQMMM = -1 1000 IF (LUQMMM .LT. 0) THEN 1001 CALL GPOPEN(LUQMMM,'QMMMIM','UNKNOWN','SEQUENTIAL', 1002 $ 'UNFORMATTED',IDUMMY,.FALSE.) 1003 ENDIF 1004 1005 REWIND(LUQMMM) 1006 CALL WRTIEF(INVMAT,NDIM*(NDIM+1)/2,'QQMMMMAT',LUQMMM) 1007 CALL GPCLOSE(LUQMMM,'KEEP') 1008 1009 IF (RELMAT) THEN 1010 WRITE(LUPRI,*) 1011 WRITE(LUPRI,*) 'The classical response matrix saved in QMMMIM.' 1012 WRITE(LUPRI,*) 1013 CALL QUIT('The classical response matrix saved in QMMMIM.') 1014 ENDIF 1015 1016 CONMAT = .FALSE. 1017 1018 ELSE ! read the inverted matrix from the file 1019 1020 IF (IPRINT .GT. 5) THEN 1021 WRITE(LUPRI,*) 1022 WRITE(LUPRI,*) ' The classical response matrix is'// 1023 & ' read from the file. ' 1024 WRITE(LUPRI,*) 1025 ENDIF 1026 1027 LUQMMM = -1 1028 IF (LUQMMM .LT. 0) THEN 1029 CALL GPOPEN(LUQMMM,'QMMMIM','UNKNOWN','SEQUENTIAL', 1030 & 'UNFORMATTED',IDUMMY,.FALSE.) 1031 ENDIF 1032 REWIND(LUQMMM) 1033 1034 CALL DZERO(INVMAT, NDIM*(NDIM+1)/2) 1035 1036 IF (FNDLAB('QQMMMMAT',LUQMMM)) THEN 1037 CALL READT(LUQMMM,NDIM*(NDIM+1)/2,INVMAT) 1038 ELSE 1039 CALL QUIT('Problem reading the classical response matrix'// 1040 & ' from QMMMIM file') 1041 ENDIF 1042 1043 CALL GPCLOSE(LUQMMM,'KEEP') 1044 1045 IF ( (IPRINT.GT.15) .OR. (LOCDEB) ) THEN 1046 WRITE(LUPRI,*) ' The classical response matrix is'// 1047 & ' read from the QMMMIM file: ' 1048 DO I = 1, NDIM*(NDIM+1)/2 1049 WRITE(LUPRI,*) INVMAT(I) 1050 END DO 1051 ENDIF 1052 1053 ENDIF 1054 1055 IF (IPRINT .GT. 1) THEN 1056 WRITE(LUPRI,*) 1057 WRITE(LUPRI,1051) 1058 WRITE(LUPRI,1050) 1059 WRITE(LUPRI,1051) 1060 WRITE(LUPRI,*) 1061 ENDIF 1062 1063 IF (LOCDEB) THEN 1064 WRITE(LUPRI,*) 'F-Vector' 1065 DO 899 I=1,NDIM 1066 WRITE(LUPRI,*) WRK(KELF+I-1) 1067 899 CONTINUE 1068 1069 ENDIF 1070 1071 IF (SPLDIP) THEN 1072 CALL DSPMV('L', NDIM, D1, INVMAT, WRK(KELF), 1, D0, 1073 & WRK(KIMMUL), 1) 1074 CALL DSPMV('L', NDIM, D1, INVMAT, WRK(KELFNU), 1, D0, 1075 & WRK(KIMNUC), 1) 1076 CALL DSPMV('L', NDIM, D1, INVMAT, WRK(KELFEL), 1, D0, 1077 & WRK(KIMELD), 1) 1078 ELSE 1079 CALL DSPMV('L', NDIM, D1, INVMAT, WRK(KELF), 1, D0, INDMOM, 1) 1080 ENDIF 1081 1082C Write the nonzero induced dipoles to files. Only if not fixdip. 1083 IF ( (.NOT. FIXDIP) .AND. (SPLDIP) ) THEN 1084 CALL PUT_TO_FILE_1('INDUCED_DIPOLES_MUL',POLDIM,WRK(KIMMUL)) 1085 CALL PUT_TO_FILE_1('INDUCED_DIPOLES_NUC',POLDIM,WRK(KIMNUC)) 1086 CALL PUT_TO_FILE_1('INDUCED_DIPOLES_ELE',POLDIM,WRK(KIMELD)) 1087 ENDIF 1088 1089 1090 IF (SPLDIP) THEN 1091 1092 DO 420 I=1,NDIM 1093 INDMOM(I) = WRK(KIMMUL+I-1) + WRK(KIMNUC+I-1) + 1094 & WRK(KIMELD+I-1) 1095 420 CONTINUE 1096 1097 IIMIEL = 1 1098 IIMINU = 1 1099 IIMIMU = 1 1100 1101 WRITE(LUPRI,*) 1102 WRITE(LUPRI,1040) 1103 WRITE(LUPRI,*) 1104 WRITE(LUPRI,1000) 1105 WRITE(LUPRI,1010) 1106 WRITE(LUPRI,1000) 1107 DO 421 I=1,MMCENT 1108 IF (ZEROAL(I) .EQ. -1) THEN 1109 DIPX = 0.0D0 1110 DIPY = 0.0D0 1111 DIPZ = 0.0D0 1112 ELSE 1113 DIPX = WRK(KIMELD+IIMIEL-1+0) 1114 DIPY = WRK(KIMELD+IIMIEL-1+1) 1115 DIPZ = WRK(KIMELD+IIMIEL-1+2) 1116 IIMIEL = IIMIEL + 3 1117 ENDIF 1118 WRITE(LUPRI,1020) I,DIPX,DIPY,DIPZ 1119 421 CONTINUE 1120 WRITE(LUPRI,1000) 1121 WRITE(LUPRI,*) 1122 1123 WRITE(LUPRI,*) 1124 WRITE(LUPRI,1041) 1125 WRITE(LUPRI,*) 1126 WRITE(LUPRI,1000) 1127 WRITE(LUPRI,1010) 1128 WRITE(LUPRI,1000) 1129 DO 422 I=1,MMCENT 1130 IF (ZEROAL(I) .EQ. -1) THEN 1131 DIPX = 0.0D0 1132 DIPY = 0.0D0 1133 DIPZ = 0.0D0 1134 ELSE 1135 DIPX = WRK(KIMNUC+IIMINU-1+0) 1136 DIPY = WRK(KIMNUC+IIMINU-1+1) 1137 DIPZ = WRK(KIMNUC+IIMINU-1+2) 1138 IIMINU = IIMINU + 3 1139 ENDIF 1140 WRITE(LUPRI,1020) I,DIPX,DIPY,DIPZ 1141 422 CONTINUE 1142 WRITE(LUPRI,1000) 1143 WRITE(LUPRI,*) 1144 1145 WRITE(LUPRI,*) 1146 WRITE(LUPRI,1042) 1147 WRITE(LUPRI,*) 1148 WRITE(LUPRI,1000) 1149 WRITE(LUPRI,1010) 1150 WRITE(LUPRI,1000) 1151 DO 423 I=1,MMCENT 1152 IF (ZEROAL(I) .EQ. -1) THEN 1153 DIPX = 0.0D0 1154 DIPY = 0.0D0 1155 DIPZ = 0.0D0 1156 ELSE 1157 DIPX = WRK(KIMMUL+IIMIMU-1+0) 1158 DIPY = WRK(KIMMUL+IIMIMU-1+1) 1159 DIPZ = WRK(KIMMUL+IIMIMU-1+2) 1160 IIMIMU = IIMIMU + 3 1161 ENDIF 1162 WRITE(LUPRI,1020) I,DIPX,DIPY,DIPZ 1163 423 CONTINUE 1164 WRITE(LUPRI,1000) 1165 WRITE(LUPRI,*) 1166 1167 ENDIF 1168 1169 IF (IPRINT .GT. 1) THEN 1170 WRITE(LUPRI,*) 1171 WRITE(LUPRI,1030) 1172 WRITE(LUPRI,*) 1173 WRITE(LUPRI,1000) 1174 WRITE(LUPRI,1010) 1175 WRITE(LUPRI,1000) 1176 ENDIF 1177 1178 IINIM = 1 1179 1180 DO 500 I=1,MMCENT 1181 IF (ZEROAL(I) .EQ. -1) THEN 1182 DIPX = 0.0D0 1183 DIPY = 0.0D0 1184 DIPZ = 0.0D0 1185 ELSE 1186 DIPX = INDMOM(IINIM+0) 1187 DIPY = INDMOM(IINIM+1) 1188 DIPZ = INDMOM(IINIM+2) 1189 IINIM = IINIM + 3 1190 ENDIF 1191 IF (IPRINT .GT. 1) WRITE(LUPRI,1020) I,DIPX,DIPY,DIPZ 1192 500 CONTINUE 1193 1194 IF (IPRINT .GT. 1) THEN 1195 WRITE(LUPRI,1000) 1196 WRITE(LUPRI,*) 1197 ENDIF 1198 1199C Finally, write the nonzero induced dipoles to file 1200 IF (.NOT. FIXDIP) THEN 1201 CALL PUT_TO_FILE_1('INDUCED_DIPOLES',POLDIM,INDMOM) 1202 ENDIF 1203 1204 1205 1040 FORMAT(' Due to electronic density: ') 1206 1041 FORMAT(' Due to nuclei: ') 1207 1042 FORMAT(' Due to permanent multipoles: ') 1208 1050 FORMAT(' Induced dipole moments ') 1209 1051 FORMAT(2X,'=',22('-'),'=',2X) 1210 1030 FORMAT(' Total induced dipole moments: ') 1211 1000 FORMAT(1X,51('=')) 1212 1010 FORMAT(' | Site | X | Y | Z |') 1213 1020 FORMAT(1X,I6,3(4X,F10.6)) 1214 1215 CALL QEXIT('GET_IND_DIPOLES_1') 1216 RETURN 1217 END 1218C****************************************************************************** 1219C /* Deck GET_CHARGE_ELFLD */ 1220 SUBROUTINE GET_CHARGE_ELFLD(Q,XORI,YORI,ZORI, 1221 & XTAR,YTAR,ZTAR, 1222 & EFX,EFY,EFZ) 1223C 1224C Calculates the electric field strength due to electric point 1225C charge. 1226C 1227C INPUT: 1228C 1229C Q - the magnitude of the point charge 1230C XORI,YORI,ZORI - position of the point charge 1231C XTAR,YTAR,ZTAR - position of the point where electric field is to be calculated 1232C 1233C OUTPUT: 1234C 1235C EFX,EFY,EFZ - components of the electric field strength vector 1236C 1237C KA, 2008 Oct. 22 1238C 1239#include "implicit.h" 1240#include "priunit.h" 1241#include "dummy.h" 1242#include "mxcent.h" 1243#include "qmmm.h" 1244#include "qm3.h" 1245#include "iratdef.h" 1246#include "maxash.h" 1247#include "maxorb.h" 1248#include "inforb.h" 1249#include "inftap.h" 1250#include "infpri.h" 1251#include "scbrhf.h" 1252#include "maxaqn.h" 1253#include "symmet.h" 1254#include "orgcom.h" 1255#include "infinp.h" 1256#include "nuclei.h" 1257#include "codata.h" 1258C 1259 1260 DOUBLE PRECISION Q,XORI,YORI,ZORI 1261 DOUBLE PRECISION XTAR,YTAR,ZTAR 1262 DOUBLE PRECISION EFX,EFY,EFZ 1263 1264 CALL QENTER('GET_CHARGE_ELFLD') 1265 1266 EFX = 0.0D0 1267 EFY = 0.0D0 1268 EFZ = 0.0D0 1269 1270 DIST2 = 0.0D0 1271 DIST2 = DIST2 + (XTAR - XORI)**2 1272 DIST2 = DIST2 + (YTAR - YORI)**2 1273 DIST2 = DIST2 + (ZTAR - ZORI)**2 1274 DIST = SQRT(DIST2) 1275 DIST3 = DIST**3 1276 1277 EFX = Q*(XTAR - XORI)/DIST3 1278 EFY = Q*(YTAR - YORI)/DIST3 1279 EFZ = Q*(ZTAR - ZORI)/DIST3 1280 1281 CALL QEXIT('GET_CHARGE_ELFLD') 1282 1283 RETURN 1284 END 1285C****************************************************************************** 1286C /* Deck GET_DIPOLE_ELFLD */ 1287 SUBROUTINE GET_DIPOLE_ELFLD(MJUX,MJUY,MJUZ, 1288 & XORI,YORI,ZORI, 1289 & XTAR,YTAR,ZTAR, 1290 & EFX,EFY,EFZ) 1291C 1292C Calculates the electric field strength due to electric dipole 1293C moment. 1294C 1295C INPUT: 1296C 1297C MJUX,MJUY,MJUZ - the components of the dipole moment 1298C XORI,YORI,ZORI - position of the dipole moment 1299C XTAR,YTAR,ZTAR - position of the point where electric field is 1300C to be calculated 1301C 1302C OUTPUT: 1303C 1304C EFX,EFY,EFZ - components of the electric field strength 1305C vector 1306C 1307C KA, 2008 Oct. 22 1308C 1309#include "implicit.h" 1310#include "priunit.h" 1311#include "dummy.h" 1312#include "mxcent.h" 1313#include "qmmm.h" 1314#include "qm3.h" 1315#include "iratdef.h" 1316#include "maxash.h" 1317#include "maxorb.h" 1318#include "inforb.h" 1319#include "inftap.h" 1320#include "infpri.h" 1321#include "scbrhf.h" 1322#include "maxaqn.h" 1323#include "symmet.h" 1324#include "orgcom.h" 1325#include "infinp.h" 1326#include "nuclei.h" 1327#include "codata.h" 1328C 1329 DOUBLE PRECISION MJUX,MJUY,MJUZ 1330 DOUBLE PRECISION XORI,YORI,ZORI 1331 DOUBLE PRECISION XTAR,YTAR,ZTAR 1332 DOUBLE PRECISION EFX,EFY,EFZ 1333 1334 CALL QENTER('GET_DIPOLE_ELFLD') 1335 1336 EFX = 0.0D0 1337 EFY = 0.0D0 1338 EFZ = 0.0D0 1339 1340 DIST2 = 0.0D0 1341 DIST2 = DIST2 + (XTAR - XORI)**2 1342 DIST2 = DIST2 + (YTAR - YORI)**2 1343 DIST2 = DIST2 + (ZTAR - ZORI)**2 1344 DIST = SQRT(DIST2) 1345 DIST3 = DIST**3 1346 DIST5 = DIST**5 1347 1348 EFX = EFX + MJUX*((3*(XTAR - XORI)*(XTAR - XORI))/DIST5 - 1349 & (1.0/DIST3)) 1350 EFX = EFX + MJUY* (3*(XTAR - XORI)*(YTAR - YORI))/DIST5 1351 EFX = EFX + MJUZ* (3*(XTAR - XORI)*(ZTAR - ZORI))/DIST5 1352 1353 EFY = EFY + MJUX* (3*(YTAR - YORI)*(XTAR - XORI))/DIST5 1354 EFY = EFY + MJUY*((3*(YTAR - YORI)*(YTAR - YORI))/DIST5 - 1355 & (1.0/DIST3)) 1356 EFY = EFY + MJUZ* (3*(YTAR - YORI)*(ZTAR - ZORI))/DIST5 1357 1358 EFZ = EFZ + MJUX* (3*(ZTAR - ZORI)*(XTAR - XORI))/DIST5 1359 EFZ = EFZ + MJUY* (3*(ZTAR - ZORI)*(YTAR - YORI))/DIST5 1360 EFZ = EFZ + MJUZ*((3*(ZTAR - ZORI)*(ZTAR - ZORI))/DIST5 - 1361 & (1.0/DIST3)) 1362 1363 CALL QEXIT('GET_DIPOLE_ELFLD') 1364 1365 RETURN 1366 END 1367C****************************************************************************** 1368C /* Deck GET_QUADRUPOLE_ELFLD */ 1369 SUBROUTINE GET_QUADRUPOLE_ELFLD(QXX,QXY,QXZ, 1370 & QYY,QYZ,QZZ, 1371 & XORI,YORI,ZORI, 1372 & XTAR,YTAR,ZTAR, 1373 & EFX,EFY,EFZ) 1374C 1375C Calculates the electric field strength due to electric quadrupole 1376C moment. 1377C 1378C INPUT: 1379C 1380C QXX,QXY,QXZ,QYY,QYZ,QZZ - the components of the symmetric 1381C quadrupole moment tensor 1382C XORI,YORI,ZORI - position of the quadrupole moment 1383C XTAR,YTAR,ZTAR - position of the point where electric field is 1384C to be calculated 1385C 1386C OUTPUT: 1387C 1388C EFX,EFY,EFZ - components of the electric field strength 1389C vector 1390C 1391C KA, 2008 Oct. 22 1392C 1393#include "implicit.h" 1394#include "priunit.h" 1395#include "dummy.h" 1396#include "mxcent.h" 1397#include "qmmm.h" 1398#include "qm3.h" 1399#include "iratdef.h" 1400#include "maxash.h" 1401#include "maxorb.h" 1402#include "inforb.h" 1403#include "inftap.h" 1404#include "infpri.h" 1405#include "scbrhf.h" 1406#include "maxaqn.h" 1407#include "symmet.h" 1408#include "orgcom.h" 1409#include "infinp.h" 1410#include "nuclei.h" 1411#include "codata.h" 1412C 1413 DOUBLE PRECISION QXX,QXY,QXZ,QYY,QYZ,QZZ 1414 DOUBLE PRECISION XORI,YORI,ZORI 1415 DOUBLE PRECISION XTAR,YTAR,ZTAR 1416 DOUBLE PRECISION EFX,EFY,EFZ 1417 1418 DOUBLE PRECISION QTENS,ELFVEC,CORDO,CORDT 1419 DIMENSION QTENS(3,3),ELFVEC(3),CORDO(3),CORDT(3) 1420 1421 CALL QENTER('GET_QUADRUPOLE_ELFLD') 1422 1423 EFX = 0.0D0 1424 EFY = 0.0D0 1425 EFZ = 0.0D0 1426 1427 DIST2 = 0.0D0 1428 DIST2 = DIST2 + (XTAR - XORI)**2 1429 DIST2 = DIST2 + (YTAR - YORI)**2 1430 DIST2 = DIST2 + (ZTAR - ZORI)**2 1431 DIST = SQRT(DIST2) 1432 DIST5 = DIST**5 1433 DIST7 = DIST**7 1434 1435 QTENS(1,1) = QXX 1436 QTENS(1,2) = QXY 1437 QTENS(1,3) = QXZ 1438 QTENS(2,1) = QXY 1439 QTENS(2,2) = QYY 1440 QTENS(2,3) = QYZ 1441 QTENS(3,1) = QXZ 1442 QTENS(3,2) = QYZ 1443 QTENS(3,3) = QZZ 1444 1445 CORDO(1) = XORI 1446 CORDO(2) = YORI 1447 CORDO(3) = ZORI 1448 1449 CORDT(1) = XTAR 1450 CORDT(2) = YTAR 1451 CORDT(3) = ZTAR 1452 1453 ELFVEC(1) = 0.0D0 1454 ELFVEC(2) = 0.0D0 1455 ELFVEC(3) = 0.0D0 1456 1457 DO 100 I=1,3 1458 DO 110 J=1,3 1459 DO 120 K=1,3 1460 1461 ELEM = 0.0D0 1462 ELEM = (15*(CORDT(K) - CORDO(K))* 1463 & (CORDT(J) - CORDO(J))* 1464 & (CORDT(I) - CORDO(I)))/ 1465 & DIST7 1466 IF (K .EQ. J) THEN 1467 ELEM = ELEM - (3*(CORDT(I) - CORDO(I))/DIST5) 1468 ENDIF 1469 IF (I .EQ. K) THEN 1470 ELEM = ELEM - (3*(CORDT(J) - CORDO(J))/DIST5) 1471 ENDIF 1472 IF (I .EQ. J) THEN 1473 ELEM = ELEM - (3*(CORDT(K) - CORDO(K))/DIST5) 1474 ENDIF 1475 ELEM = ELEM*QTENS(K,J) 1476 1477 ELFVEC(I) = ELFVEC(I) + ELEM 1478 1479 120 CONTINUE 1480 110 CONTINUE 1481 ELFVEC(I) = ELFVEC(I)/2.0 1482 100 CONTINUE 1483 1484 EFX = ELFVEC(1) 1485 EFY = ELFVEC(2) 1486 EFZ = ELFVEC(3) 1487 1488 CALL QEXIT('GET_QUADRUPOLE_ELFLD') 1489 1490 RETURN 1491 END 1492C****************************************************************************** 1493C /* Deck Put_To_File_1 */ 1494 SUBROUTINE PUT_TO_FILE_1(FLNAME,NULOOP,DDATA) 1495C 1496#include "implicit.h" 1497#include "dummy.h" 1498C 1499 CHARACTER*(*) FLNAME 1500 INTEGER NMBU,NULOOP 1501 DIMENSION DDATA(*) 1502C 1503 NMBU = -1 1504 CALL GPOPEN(NMBU,FLNAME,'UNKNOWN',' ','FORMATTED',IDUMMY,.FALSE.) 1505C 1506 REWIND (NMBU) 1507 LM = 1 1508 DO 820 L = 1,NULOOP 1509 WRITE(NMBU,'(I5,3E25.15)') L,DDATA(LM),DDATA(LM+1),DDATA(LM+2) 1510 LM = LM + 3 1511 820 CONTINUE 1512C 1513 CALL GPCLOSE(NMBU,'KEEP') 1514C 1515 END 1516C 1517C****************************************************************************** 1518C************************************************************** 1519C /* Deck Get_From_File_1 */ 1520 SUBROUTINE GET_FROM_FILE_1(FLNAME,NULOOP,DDATA) 1521C************************************************************** 1522C 1523#include "implicit.h" 1524#include "dummy.h" 1525C 1526 CHARACTER*(*) FLNAME 1527 INTEGER NMBU,NULOOP 1528 DIMENSION DDATA(*) 1529C 1530 NMBU = -1 1531 CALL GPOPEN(NMBU,FLNAME,'UNKNOWN',' ','FORMATTED',IDUMMY,.FALSE.) 1532C 1533 REWIND (NMBU) 1534 LM = 1 1535 DO 820 L = 1,NULOOP 1536 READ(NMBU,'(I5,3E25.15)') LK,DDATA(LM),DDATA(LM+1),DDATA(LM+2) 1537 LM = LM + 3 1538 820 CONTINUE 1539C 1540 IF (LK.NE.NULOOP) THEN 1541 CALL QUIT('Problem in dimension in GET_FROM_FILE_1') 1542 ENDIF 1543 1544 CALL GPCLOSE(NMBU,'KEEP') 1545C 1546 END 1547C 1548C****************************************************************************** 1549C /* Deck MM_PROPS */ 1550 SUBROUTINE MM_PROPS(WRK,LWRK,IPRINT) 1551C 1552C Calculates properties of the MM region. 1553C 1554#include "implicit.h" 1555#include "priunit.h" 1556#include "mxcent.h" 1557#include "qm3.h" 1558#include "qmmm.h" 1559#include "infpri.h" 1560 1561 PARAMETER ( D2 = 2.0D0, D0 = 0.0D0, D1 = 1.0D0 ) 1562 PARAMETER ( D3I = 1.0D0/3.0D0, D6I = 1.0D0/6.0D0) 1563 1564 DIMENSION WRK(LWRK) 1565 1566 LOGICAL LOCDEB,FNDLAB 1567 1568 CALL QENTER('MM_PROPS') 1569 1570 LOCDEB = .FALSE. 1571 1572 WRITE(LUPRI,*) ' -------------------------------------- ' 1573 WRITE(LUPRI,*) ' Output from MM property module ' 1574 WRITE(LUPRI,*) ' ---------------------------------------' 1575 WRITE(LUPRI,*) 1576 1577 KINVMAT = 1 1578 KFULLMAT = KINVMAT + 3*NNZAL*(3*NNZAL+1)/2 1579 KBMATS = KFULLMAT + (3*NNZAL)*(3*NNZAL) 1580 KPOLMAT = KBMATS + (3*NNZAL)*3 1581 KPOLCORD = KPOLMAT + 3*3 1582 KEND = KPOLCORD + 3*NNZAL 1583 LWRK1 = LWRK - KEND 1584 1585 IF (LWRK1 .LT. 0) CALL ERRWRK('MM_PROPS',-KEND,LWRK) 1586 1587 CALL DZERO(WRK(KINVMAT),3*NNZAL*(3*NNZAL+1)/2) 1588 CALL DZERO(WRK(KFULLMAT),(3*NNZAL)*(3*NNZAL)) 1589 CALL DZERO(WRK(KBMATS),(3*NNZAL)*3) 1590 CALL DZERO(WRK(KPOLMAT),(3*3)) 1591 1592 CALL MM_DIPANDCHARGE(WRK(KEND),LWRK1,IPRINT) 1593 1594 IF (MMMAT) THEN 1595 CALL MM_POLARIZABILITY(WRK(KINVMAT),WRK(KFULLMAT),WRK(KBMATS), 1596 & WRK(KPOLMAT),IPRINT) 1597 1598 CALL MM_OPTROT(WRK(KINVMAT),WRK(KFULLMAT),WRK(KPOLCORD),IPRINT) 1599 ELSE 1600 WRITE(LUPRI,*) 'MM properties skipped since MMITER' 1601 ENDIF 1602 1603 WRITE(LUPRI,*) ' ---------------------------------------' 1604 WRITE(LUPRI,*) 1605 1606 CALL QEXIT('MM_PROPS') 1607 RETURN 1608 END 1609C****************************************************************************** 1610C /* Deck MM_POLARIZABILITY */ 1611 SUBROUTINE MM_POLARIZABILITY(INVMAT,FULLMAT,BMATS,POLMAT,IPRINT) 1612C 1613C Contracts the Relay matrix to the group and molecular 1614C polarizabilities 1615C 1616#include "implicit.h" 1617#include "priunit.h" 1618#include "infpri.h" 1619#include "mxcent.h" 1620#include "qmmm.h" 1621#include "qm3.h" 1622 1623 LOGICAL FNDLAB,LOCDEB 1624 DOUBLE PRECISION INVMAT,FULLMAT,BMATS,POLMAT 1625 DIMENSION INVMAT(3*NNZAL*(3*NNZAL+1)/2) 1626 DIMENSION FULLMAT(3*NNZAL,3*NNZAL) 1627 DIMENSION BMATS(3*NNZAL,3) 1628 DIMENSION POLMAT(3,3) 1629 1630 PARAMETER ( D2 = 2.0D0, D0 = 0.0D0, D1 = 1.0D0 ) 1631 PARAMETER ( D3I = 1.0D0/3.0D0, D6I = 1.0D0/6.0D0) 1632 1633 CALL QENTER('MM_POLARIZABILITY') 1634 1635 LOCDEB = .FALSE. 1636 1637C Read the relay matrix from file 1638 1639 LUQMMM = -1 1640 IF (LUQMMM .LT. 0) THEN 1641 CALL GPOPEN(LUQMMM,'QMMMIM','UNKNOWN','SEQUENTIAL', 1642 & 'UNFORMATTED',IDUMMY,.FALSE.) 1643 ENDIF 1644 REWIND(LUQMMM) 1645 1646 N = 3*NNZAL 1647 IF (FNDLAB('QQMMMMAT',LUQMMM)) THEN 1648 CALL READT(LUQMMM,N*(N+1)/2,INVMAT) 1649 ELSE 1650 CALL QUIT('Problem reading the matrix from the QMMMIM file.') 1651 ENDIF 1652 1653 CALL GPCLOSE(LUQMMM,'KEEP') 1654 1655 L = 1 1656 DO J = 1, N 1657 K = J*(J-1)/2 1658 DO I = J, N 1659 FULLMAT(I,J) = INVMAT(L) 1660 L = L + 1 1661 END DO 1662 M = J*N-K 1663 L = 1 + M 1664 END DO 1665 1666 DO I = 2, N 1667 DO J = 1, I-1 1668 FULLMAT(J,I) = FULLMAT(I,J) 1669 ENDDO 1670 ENDDO 1671 1672 IF ( (IPRINT .GE. 15) .OR. (LOCDEB) ) THEN 1673 WRITE(LUPRI,*) 'Relay mat. is read from file MM_POLARIZABILITY' 1674 CALL OUTPUT(FULLMAT,1,N,1,N,N,N,1,LUPRI) 1675 ENDIF 1676 1677C Contract the Relay matrix 1678 1679 K1=1 1680 DO 100 K = 1,NNZAL 1681 J1 = 1 1682 DO 101 J = 1,NNZAL 1683 BMATS(K1,1) = BMATS(K1,1) + FULLMAT(K1,J1) 1684 BMATS(K1,2) = BMATS(K1,2) + FULLMAT(K1,J1+1) 1685 BMATS(K1,3) = BMATS(K1,3) + FULLMAT(K1,J1+2) 1686 BMATS(K1+1,1) = BMATS(K1+1,1) + FULLMAT(K1+1,J1) 1687 BMATS(K1+1,2) = BMATS(K1+1,2) + FULLMAT(K1+1,J1+1) 1688 BMATS(K1+1,3) = BMATS(K1+1,3) + FULLMAT(K1+1,J1+2) 1689 BMATS(K1+2,1) = BMATS(K1+2,1) + FULLMAT(K1+2,J1) 1690 BMATS(K1+2,2) = BMATS(K1+2,2) + FULLMAT(K1+2,J1+1) 1691 BMATS(K1+2,3) = BMATS(K1+2,3) + FULLMAT(K1+2,J1+2) 1692 J1 = J1 + 3 1693 101 CONTINUE 1694 1695 IF (LOCDEB) THEN 1696 WRITE(LUPRI,*) 1697 WRITE(LUPRI,*) 'Polarizability for group ', K 1698 WRITE(LUPRI,*) BMATS(K1,1),BMATS(K1,2),BMATS(K1,3) 1699 WRITE(LUPRI,*) BMATS(K1+1,1), BMATS(K1+1,2), BMATS(K1+1,3) 1700 WRITE(LUPRI,*) BMATS(K1+2,1), BMATS(K1+2,2), BMATS(K1+2,3) 1701 WRITE(LUPRI,*) 1702 WRITE(LUPRI,*) 'Isotropic polarizability ' 1703 TEMP = BMATS(K1,1)+BMATS(K1+1,2)+BMATS(K1+2,3) 1704 WRITE(LUPRI,*) 1.0D0/3.0D0*TEMP 1705 WRITE(LUPRI,*) 1706 ENDIF 1707 1708 K1 = K1 +3 1709 1710 100 CONTINUE 1711 1712C Contract to molecular polarizability 1713 1714 K1=1 1715 DO 102 J = 1,NNZAL 1716 POLMAT(1,1) = POLMAT(1,1) + BMATS(K1,1) 1717 POLMAT(1,2) = POLMAT(1,2) + BMATS(K1,2) 1718 POLMAT(1,3) = POLMAT(1,3) + BMATS(K1,3) 1719 POLMAT(2,1) = POLMAT(2,1) + BMATS(K1+1,1) 1720 POLMAT(2,2) = POLMAT(2,2) + BMATS(K1+1,2) 1721 POLMAT(2,3) = POLMAT(2,3) + BMATS(K1+1,3) 1722 POLMAT(3,1) = POLMAT(3,1) + BMATS(K1+2,1) 1723 POLMAT(3,2) = POLMAT(3,2) + BMATS(K1+2,2) 1724 POLMAT(3,3) = POLMAT(3,3) + BMATS(K1+2,3) 1725 K1 = K1 + 3 1726 102 CONTINUE 1727 1728 N=3 1729 WRITE(LUPRI,*) 1730 WRITE(LUPRI,*) 'Molecular polarizability of the MM region' 1731 CALL OUTPUT(POLMAT,1,N,1,N,N,N,1,LUPRI) 1732 WRITE(LUPRI,*) 1733 WRITE(LUPRI,*) 'Isotropic polarizability ' 1734 TEMP = POLMAT(1,1)+POLMAT(2,2)+POLMAT(3,3) 1735 WRITE(LUPRI,*) 1.0D0/3.0D0*TEMP 1736 WRITE(LUPRI,*) 1737 1738 XI = FLOAT(NNZAL) 1739 XXI = DBLE(XI) 1740 TEMP = 1.0D0/3.0D0*TEMP/XXI 1741 WRITE(LUPRI,*) 'Isotropic polarizability pr. pol. site' 1742 WRITE(LUPRI,*) TEMP 1743 WRITE(LUPRI,*) 1744 1745 CALL QEXIT('MM_POLARIZABILITY') 1746 RETURN 1747 END 1748C****************************************************************************** 1749C /* Deck MM_DIPANDCHARGE */ 1750 SUBROUTINE MM_DIPANDCHARGE(WRK,LWRK,IPRINT) 1751C 1752C Calculates the MM total charge and dipole moment 1753C 1754#include "implicit.h" 1755#include "priunit.h" 1756#include "infpri.h" 1757#include "mxcent.h" 1758#include "qmmm.h" 1759#include "qm3.h" 1760 1761 PARAMETER ( D2 = 2.0D0, D0 = 0.0D0, D1 = 1.0D0 ) 1762 PARAMETER ( D3I = 1.0D0/3.0D0, D6I = 1.0D0/6.0D0) 1763 DIMENSION WRK(LWRK) 1764 LOGICAL LOCDEB 1765 1766 CALL QENTER('MM_DIPANDCHARGE') 1767 1768 LOCDEB = .FALSE. 1769 1770 KINDMOM = 1 1771 KLAST = KINDMOM + 3*NNZAL 1772 LWRK1 = LWRK - KLAST 1773 1774 IF (LWRK1 .LT. 0) CALL ERRWRK('MM_DIPANDCHARGE',-KLAST,LWRK) 1775 1776 CALL DZERO(WRK(KINDMOM),3*NNZAL) 1777 1778 XDIPIND = 0.0D0 1779 YDIPIND = 0.0D0 1780 ZDIPIND = 0.0D0 1781 1782 IF (IPOLTP .GT. 0) THEN 1783 1784 IF (LOCDEB) THEN 1785 WRITE(LUPRI,*) 1786 WRITE(LUPRI,*) 'Ind. dips read from file in MM_DIPANDCHARGE' 1787 WRITE(LUPRI,*) 1788 ENDIF 1789 1790 CALL GET_FROM_FILE_1('INDUCED_DIPOLES',NNZAL,WRK(KINDMOM)) 1791 1792C Add induced dipoles 1793 1794 IJ = 0 1795 DO 100 I=1,NNZAL 1796 XDIPIND = XDIPIND + WRK(KINDMOM+IJ+0) 1797 YDIPIND = YDIPIND + WRK(KINDMOM+IJ+1) 1798 ZDIPIND = ZDIPIND + WRK(KINDMOM+IJ+2) 1799 IJ = IJ +3 1800 100 CONTINUE 1801 1802 ENDIF 1803 1804C Add permanent dipoles 1805 1806 XDIPP = 0.0D0 1807 YDIPP = 0.0D0 1808 ZDIPP = 0.0D0 1809 1810 IF (NMULT .GE. 1) THEN 1811 1812 DO 101 I=1,MMCENT 1813 XDIPP = XDIPP + MUL1MM(1,I) 1814 YDIPP = YDIPP + MUL1MM(2,I) 1815 ZDIPP = ZDIPP + MUL1MM(3,I) 1816 101 CONTINUE 1817 1818 ENDIF 1819 1820C Add charges 1821 1822 QMMT = 0.0D0 1823 XQ = 0.0D0 1824 YQ = 0.0D0 1825 ZQ = 0.0D0 1826 1827 IF (NMULT .GE. 0) THEN 1828 1829 DO 102 I=1,MMCENT 1830 QMMT = QMMT + MUL0MM(I) 1831 XQ = XQ + MMCORD(1,I)*MUL0MM(I) 1832 YQ = YQ + MMCORD(2,I)*MUL0MM(I) 1833 ZQ = ZQ + MMCORD(3,I)*MUL0MM(I) 1834 102 CONTINUE 1835 1836 ENDIF 1837 1838 IF (NMULT .GE. 0) THEN 1839 WRITE(LUPRI,*) 1840 WRITE(LUPRI,*) ' MM total charge: ', QMMT 1841 IF (ABS(QMMT) .GT. THRMM) THEN 1842 WRITE(LUPRI,*) ' The MM region is charged ' 1843 ENDIF 1844 WRITE(LUPRI,*) 1845 WRITE(LUPRI,*) ' MM total charge dipole moment (x,y,z): ' 1846 WRITE(LUPRI,*) XQ,YQ,ZQ 1847 WRITE(LUPRI,*) 1848 ENDIF 1849 1850 IF (NMULT .GE. 1) THEN 1851 WRITE(LUPRI,*) ' MM total permanent dipole moment (x,y,z): ' 1852 WRITE(LUPRI,*) XDIPP,YDIPP,ZDIPP 1853 WRITE(LUPRI,*) 1854 ENDIF 1855 1856 IF (IPOLTP .GT. 0) THEN 1857 WRITE(LUPRI,*) ' MM total induced dipole moment (x,y,z): ' 1858 WRITE(LUPRI,*) XDIPIND,YDIPIND,ZDIPIND 1859 WRITE(LUPRI,*) 1860 ENDIF 1861 1862C Add all contributions to the dipule moment 1863 1864 XDIP = XQ+XDIPP+XDIPIND 1865 YDIP = YQ+YDIPP+YDIPIND 1866 ZDIP = ZQ+ZDIPP+ZDIPIND 1867 1868 IF ( (NMULT .GE. 0) .OR. (IPOLTP .GT. 0) ) THEN 1869 WRITE(LUPRI,*) ' MM total dipole moment (x,y,z): ' 1870 WRITE(LUPRI,*) XDIP,YDIP,ZDIP 1871 WRITE(LUPRI,*) 1872 ENDIF 1873 1874 CALL QEXIT('MM_DIPANDCHARGE') 1875 RETURN 1876 END 1877C****************************************************************************** 1878C /* Deck MM_OPTROT */ 1879 SUBROUTINE MM_OPTROT(INVMAT,FULLMAT,POLCORD,IPRINT) 1880C 1881C Contracts the Relay matrix to the molecular optical rotation (beta) 1882C 1883#include "implicit.h" 1884#include "priunit.h" 1885#include "infpri.h" 1886#include "mxcent.h" 1887#include "qmmm.h" 1888#include "qm3.h" 1889 1890 LOGICAL FNDLAB,LOCDEB 1891 DOUBLE PRECISION INVMAT,FULLMAT,BMAT,TEMP 1892 DIMENSION FULLMAT(3*NNZAL,3*NNZAL) 1893 DIMENSION POLCORD(3,NNZAL),BMAT(3,3) 1894 DIMENSION INVMAT(3*NNZAL*(3*NNZAL+1)/2) 1895 1896 PARAMETER ( D2 = 2.0D0, D0 = 0.0D0, D1 = 1.0D0 ) 1897 PARAMETER ( D3I = 1.0D0/3.0D0, D6I = 1.0D0/6.0D0) 1898 1899 CALL QENTER('MM_OPTROT') 1900 1901 LOCDEB = .FALSE. 1902 1903C Read the relay matrix from file 1904 1905 LUQMMM = -1 1906 IF (LUQMMM .LT. 0) THEN 1907 CALL GPOPEN(LUQMMM,'QMMMIM','UNKNOWN','SEQUENTIAL', 1908 & 'UNFORMATTED',IDUMMY,.FALSE.) 1909 ENDIF 1910 REWIND(LUQMMM) 1911 1912 N = 3*NNZAL 1913 IF (FNDLAB('QQMMMMAT',LUQMMM)) THEN 1914 CALL READT(LUQMMM,N*(N+1)/2,INVMAT) 1915 ELSE 1916 CALL QUIT('Problem reading the matrix from the QMMMIM file.') 1917 ENDIF 1918 1919 CALL GPCLOSE(LUQMMM,'KEEP') 1920 1921 L = 1 1922 DO J = 1, N 1923 K = J*(J-1)/2 1924 DO I = J, N 1925 FULLMAT(I,J) = INVMAT(L) 1926 L = L + 1 1927 END DO 1928 M = J*N-K 1929 L = 1 + M 1930 END DO 1931 1932 DO I = 2, N 1933 DO J = 1, I-1 1934 FULLMAT(J,I) = FULLMAT(I,J) 1935 ENDDO 1936 ENDDO 1937 1938 IF ( (IPRINT .GE. 15) .OR. (LOCDEB) )THEN 1939 WRITE(LUPRI,*) 'Response mat. is read from file MM_OPTROT' 1940 CALL OUTPUT(FULLMAT,1,N,1,N,N,N,1,LUPRI) 1941 ENDIF 1942 1943C Construct an array of coordinates having polarizabilities 1944 1945 IL = 1 1946 DO 100 I=1,MMCENT 1947 1948 IF (ZEROAL(I) .EQ. -1) GOTO 100 1949 1950 POLCORD(1,IL) = MMCORD(1,I) 1951 POLCORD(2,IL) = MMCORD(2,I) 1952 POLCORD(3,IL) = MMCORD(3,I) 1953 1954 IL = IL + 1 1955 1956 100 CONTINUE 1957 1958 IF ( (IL-1) .NE. NNZAL) THEN 1959 CALL QUIT('Problem in coordinate dimension in MM_OPTROT.') 1960 ENDIF 1961 1962 BETA = 0.0D0 1963 DO 101 I=1,NNZAL-1 1964 DO 102 J=I+1,NNZAL 1965 1966 K=(I-1)*3+1 1967 L=(J-1)*3+1 1968 BMAT(1,1) = FULLMAT(K,L) 1969 BMAT(1,2) = FULLMAT(K,L+1) 1970 BMAT(1,3) = FULLMAT(K,L+2) 1971 BMAT(2,1) = FULLMAT(K+1,L) 1972 BMAT(2,2) = FULLMAT(K+1,L+1) 1973 BMAT(2,3) = FULLMAT(K+1,L+2) 1974 BMAT(3,1) = FULLMAT(K+2,L) 1975 BMAT(3,2) = FULLMAT(K+2,L+1) 1976 BMAT(3,3) = FULLMAT(K+2,L+2) 1977 XDIST = POLCORD(1,J) - POLCORD(1,I) 1978 YDIST = POLCORD(2,J) - POLCORD(2,I) 1979 ZDIST = POLCORD(3,J) - POLCORD(3,I) 1980 1981 BETA = BETA + XDIST*(BMAT(3,2)-BMAT(2,3)) 1982 * + YDIST*(BMAT(1,3)-BMAT(3,1)) 1983 * + ZDIST*(BMAT(2,1)-BMAT(1,2)) 1984 1985 102 CONTINUE 1986 101 CONTINUE 1987 1988 BETA = D6I*BETA 1989 1990 WRITE(LUPRI,*) 'Isotropic OPTROT (beta)' 1991 WRITE(LUPRI,*) BETA 1992 WRITE(LUPRI,*) 1993c 1994 CALL QEXIT('MM_OPTROT') 1995 RETURN 1996 END 1997C****************************************************************************** 1998C /* Deck GET_IND_DIPOLES_2 */ 1999 SUBROUTINE GET_IND_DIPOLES_2(DCAO,POLDIM,INDMOM, 2000 & WRK,LWRK,IPRINT) 2001C 2002C A subroutine to calculate induced dipole moments by simple Jacobi iteration 2003C 2004C Input: 2005C 2006C DCAO - density matrix in AO basis 2007C POLDIM - the number of polarizable MM centers. 2008C (Actually in common as NNZAL....) 2009C 2010C Output: 2011C 2012C INDMOM - a vector containing induced dipole moments 2013C 2014C From Common 2015C 2016C ZEROAL - a vector containing +1 for polarizable MM centers and -1 2017C for non-polarizable 2018C 2019C Sep 2010 - JMO & KS: 2020C Started sharing of DFT/MM and CC/MM field routines 2021C 2022#include "implicit.h" 2023#include "priunit.h" 2024#include "dummy.h" 2025#include "mxcent.h" 2026#include "iratdef.h" 2027#include "maxash.h" 2028#include "maxorb.h" 2029 2030#include "qmmm.h" 2031#include "mmtimes.h" 2032#include "qm3.h" 2033#include "inforb.h" 2034#include "inftap.h" 2035#include "infpri.h" 2036#include "scbrhf.h" 2037#include "maxaqn.h" 2038#include "symmet.h" 2039#include "orgcom.h" 2040#include "infinp.h" 2041#include "nuclei.h" 2042#include "codata.h" 2043#include "infpar.h" 2044 2045 LOGICAL EXCENT,LOCDEB,DIPCON, LSKIP 2046 LOGICAL TOFILE,TRIMAT,EXP1VL 2047 INTEGER POLDIM 2048 DOUBLE PRECISION INDMOM 2049 DIMENSION INDMOM(3*POLDIM),WRK(LWRK), DCAO(*) 2050 2051 DOUBLE PRECISION EVEC,TTENS,ATMAT,DIP 2052 DIMENSION EVEC(3),TTENS(3,3) 2053 DIMENSION ATMAT(3,3),DIP(3) 2054 DIMENSION INTREP(9*MXCENT), INTADR(9*MXCENT) 2055 2056 CHARACTER*8 LABINT(9*MXCENT) 2057 2058 PARAMETER ( D2 = 2.0D0, D0 = 0.0D0, D1 = 1.0D0 ) 2059 PARAMETER ( D3I = 1.0D0/3.0D0, D6I = 1.0D0/6.0D0) 2060 2061 CALL QENTER('GET_IND_DIPOLES_2') 2062 2063 LOCDEB = .FALSE. 2064 2065 IF (POLDIM .NE. NNZAL) THEN 2066 WRITE(LUPRI,*) 'ERROR in no. of polarizabilities' 2067 CALL QUIT('ERROR in GET_IND_DIPOLES_2') 2068 ENDIF 2069 2070 IF (SPLDIP) THEN 2071 WRITE(LUPRI,*) 'Split not implemented for iterative QMMM' 2072 ENDIF 2073 2074C Allocate memory for electric field integrals and electric fields 2075 KMAT = 1 ! For electric field integrals 2076 KELF = KMAT + 3*NNBASX ! For total electric field 2077 KEND = KELF + 3*POLDIM 2078 LWRK1 = LWRK - KEND 2079 IF (LWRK1 .LT. 0) CALL ERRWRK('GET_IND_DIPOLES_2',-KEND,LWRK) 2080 2081 CALL DZERO(WRK(KMAT),3*NNBASX) 2082 CALL DZERO(WRK(KELF),3*POLDIM) 2083 2084C 1. Form F vector due to permanent MM moments 2085 2086 IF (MMTIME) DTIME = SECOND() 2087#if defined(VAR_MPI) 2088 IF (NODTOT .GE. 1) THEN 2089 CALL MM_FIELD_M2(DCAO(1),WRK(KELF),POLDIM, 2090 & WRK(KEND),LWRK1,IPRINT) 2091 ELSE 2092#endif 2093 LRI = 1 2094 2095 DO 200 I=1,MMCENT 2096 2097 IF (ZEROAL(I) .EQ. -1) GOTO 200 2098 2099 CALL GET_FIELD(I,LRI,WRK(KELF),WRK(KEND),WRK(KEND), 2100 * DCAO,LOCDEB,WRK(KEND),LWRK1) 2101 LRI = LRI + 3 2102 2103 200 CONTINUE 2104 2105#if defined(VAR_MPI) 2106 ENDIF 2107#endif 2108 IF (MMTIME) THEN 2109 DTIME = SECOND() - DTIME 2110 TMMPOL2 = TMMPOL2 + DTIME 2111 ENDIF 2112 2113 NDIM = 3*POLDIM 2114 2115 IF (LOCDEB) THEN 2116 WRITE(LUPRI,*) 'F-Vector' 2117 DO 899 I=1,NDIM 2118 WRITE(LUPRI,*) WRK(KELF+I-1) 2119 899 CONTINUE 2120 ENDIF 2121 2122C Convert the F-vector into induced dipole moments 2123 2124 IOPT = 1 ! read file with ind. momens from previous SCF iteration. 2125 IF (MMTIME) DTIME = SECOND() 2126 CALL F2QMMM(WRK(KELF),POLDIM,INDMOM,WRK(KEND),LWRK1, 2127 * IOPT,IPRINT) 2128 2129 IF (MMTIME) THEN 2130 DTIME = SECOND() - DTIME 2131 TMMF2 = TMMF2 + DTIME 2132 ENDIF 2133 IF (IPRINT .GT. 1) THEN 2134C Write induced moments at each MM site to the DAL.OUT file 2135 WRITE(LUPRI,*) 2136 WRITE(LUPRI,1030) 2137 WRITE(LUPRI,*) 2138 WRITE(LUPRI,1000) 2139 WRITE(LUPRI,1010) 2140 WRITE(LUPRI,1000) 2141 ENDIF 2142 2143 IINIM = 1 2144 2145 DO 500 I=1,MMCENT 2146 IF (ZEROAL(I) .EQ. -1) THEN 2147 DIPX = 0.0D0 2148 DIPY = 0.0D0 2149 DIPZ = 0.0D0 2150 ELSE 2151 DIPX = INDMOM(IINIM+0) 2152 DIPY = INDMOM(IINIM+1) 2153 DIPZ = INDMOM(IINIM+2) 2154 IINIM = IINIM + 3 2155 ENDIF 2156 IF (IPRINT .GT. 1) WRITE(LUPRI,1020) I,DIPX,DIPY,DIPZ 2157 500 CONTINUE 2158 2159 IF (IPRINT .GT. 1) THEN 2160 WRITE(LUPRI,1000) 2161 WRITE(LUPRI,*) 2162 ENDIF 2163 2164C Write the nonzero induced dipoles to file 2165 IF (.NOT. FIXDIP) THEN 2166 CALL PUT_TO_FILE_1('INDUCED_DIPOLES',POLDIM,INDMOM) 2167 ENDIF 2168 2169 1050 FORMAT(' Induced dipole moments ') 2170 1051 FORMAT(2X,'=',22('-'),'=',2X) 2171 1030 FORMAT(' Total induced dipole moments: ') 2172 1000 FORMAT(1X,51('=')) 2173 1010 FORMAT(' | Site | X | Y | Z |') 2174 1020 FORMAT(1X,I6,3(4X,F10.6)) 2175 2176 CALL QEXIT('GET_IND_DIPOLES_2') 2177 RETURN 2178 END 2179C****************************************************************************** 2180C /* Deck F2QMMM */ 2181 SUBROUTINE F2QMMM(ELF,POLDIM,INDMOM,WRK,LWRK,IOPT,IPRINT) 2182C 2183C Converts a field vector into induced dipoles using iterative procedures. 2184C 2185C Input: ELF 2186C Output: INDMOM 2187C 2188C INDMOM is the induced dipole moments 2189C INDDIA is the diagonal part of the induced dipole moments, 2190C i.e. the part corresponding directly to the F ELF vector. 2191C JK 2192 2193#include "implicit.h" 2194#include "priunit.h" 2195#include "dummy.h" 2196#include "mxcent.h" 2197#include "qmmm.h" 2198#include "mmtimes.h" 2199#include "qm3.h" 2200#include "iratdef.h" 2201#include "maxash.h" 2202#include "maxorb.h" 2203#include "inforb.h" 2204#include "inftap.h" 2205#include "infpri.h" 2206#include "infpar.h" 2207#include "scbrhf.h" 2208#include "maxaqn.h" 2209#include "symmet.h" 2210#include "orgcom.h" 2211#include "infinp.h" 2212#include "nuclei.h" 2213#include "codata.h" 2214 2215 2216 LOGICAL EXCENT,LOCDEB,DIPCON 2217 INTEGER POLDIM 2218 DOUBLE PRECISION INDMOM,ELF 2219 DIMENSION INDMOM(3*POLDIM),ELF(3*POLDIM) 2220 DIMENSION WRK(LWRK) 2221 2222 DOUBLE PRECISION AMAT,EVEC,MY0,TTENS,ATMAT,DIP 2223 DOUBLE PRECISION MY 2224 DIMENSION AMAT(3,3),EVEC(3),MY0(3),TTENS(3,3) 2225 DIMENSION ATMAT(3,3),DIP(3),MY(3) 2226 2227 PARAMETER ( D2 = 2.0D0, D0 = 0.0D0, D1 = 1.0D0 ) 2228 PARAMETER ( D3I = 1.0D0/3.0D0, D6I = 1.0D0/6.0D0) 2229 2230 LOGICAL FIRST 2231 SAVE FIRST 2232 DATA FIRST /.TRUE./ 2233 2234 CALL QENTER('F2QMMM') 2235 2236 BTIME = SECOND() 2237 2238 LOCDEB = .FALSE. 2239 2240c IF (IOPT .EQ. 1) THRESL = THMMIT 2241c IF (IOPT .EQ. 2) THRESL = SQRT(THMMIT)/10.0D0 2242 2243 THRESL = THMMIT 2244 2245 IF (FIRST) NMMAC = 0 2246 2247 NDIM = 3*POLDIM 2248 2249 KINDP = 1 ! For the previos induced dipole (super) vector 2250 KINDDIA = KINDP + 3*POLDIM ! For the diagonal part of the induced moments 2251 KEND = KINDDIA + 3*POLDIM 2252 LWRK1 = LWRK - KEND 2253 IF (LWRK1 .LT. 0) CALL ERRWRK('F2QMMM 1',-KEND,LWRK) 2254 2255 CALL DZERO(WRK(KINDP),3*POLDIM) 2256 CALL DZERO(WRK(KINDDIA),3*POLDIM) 2257 2258 KVEC = KEND 2259 IF (MMDIIS) THEN 2260 KEND = KVEC + (MXMMIT+1)*NDIM 2261 LWRK1 = LWRK - KEND + 1 2262 IF (LWRK1 .LT. 0) CALL ERRWRK('F2QMMM 2',-KEND,LWRK) 2263 2264 CALL DZERO(WRK(KVEC),(MXMMIT+1)*NDIM) 2265 ENDIF 2266 2267C Convert the F-vector into induced dipole moments 2268C by neglecting the off diagonal elements (the T tensor) 2269C These moments are used as the initial guess. 2270 2271 LRI = 1 2272 2273 DO 400 I=1,MMCENT 2274 2275 IF (ZEROAL(I) .EQ. -1) GOTO 400 2276 2277C Get the polarizability tensor for this site 2278 DO 401 K=1,3 2279 DO 402 J=1,3 2280 AMAT(K,J) = 0.0D0 2281 402 CONTINUE 2282 401 CONTINUE 2283 2284 IF (IPOLTP .EQ. 1) THEN 2285 DO 403 J=1,3 2286 AMAT(J,J) = POLIMM(I) 2287 403 CONTINUE 2288 ELSE IF (IPOLTP .EQ. 2) THEN 2289 AMAT(1,1) = POLMM(1,I) 2290 AMAT(1,2) = POLMM(2,I) 2291 AMAT(1,3) = POLMM(3,I) 2292 AMAT(2,1) = POLMM(2,I) 2293 AMAT(2,2) = POLMM(4,I) 2294 AMAT(2,3) = POLMM(5,I) 2295 AMAT(3,1) = POLMM(3,I) 2296 AMAT(3,2) = POLMM(5,I) 2297 AMAT(3,3) = POLMM(6,I) 2298 ENDIF 2299 2300C Now get the F-vector for this site 2301 EVEC(1) = ELF(LRI+0) 2302 EVEC(2) = ELF(LRI+1) 2303 EVEC(3) = ELF(LRI+2) 2304 2305C Calculate the induced dipole moment 2306 NLDIM = 3 2307 NTOTI = MAX(NLDIM,1) 2308 CALL DGEMV('N',NLDIM,NLDIM,D1,AMAT,NTOTI,EVEC,1,D0,MY0,1) 2309 2310 WRK(KINDDIA-1+LRI+0) = MY0(1) 2311 WRK(KINDDIA-1+LRI+1) = MY0(2) 2312 WRK(KINDDIA-1+LRI+2) = MY0(3) 2313 2314 LRI = LRI + 3 2315 400 CONTINUE 2316 2317 IF (LOCDEB) THEN 2318 WRITE(LUPRI,*) 'My-Vector: Diagonal contribution' 2319 DO 404 I=1,NDIM 2320 WRITE(LUPRI,*) WRK(KINDDIA+I-1) 2321 404 CONTINUE 2322 ENDIF 2323 2324 CALL DCOPY(NDIM,WRK(KINDDIA),1,INDMOM,1) 2325 2326 IF (IOPT .EQ. 1) THEN 2327 IF (.NOT. FIRST) THEN 2328 CALL GET_FROM_FILE_1('INDUCED_DIPOLES',POLDIM,WRK(KINDP)) 2329 ELSE 2330 CALL DCOPY(NDIM,WRK(KINDDIA),1,WRK(KINDP),1) 2331 ENDIF 2332 ENDIF 2333 2334 IF (IOPT .EQ. 2) CALL DCOPY(NDIM,WRK(KINDDIA),1,WRK(KINDP),1) 2335 2336 IF (MMDIIS) THEN 2337 CALL DCOPY(NDIM,WRK(KINDP),1,WRK(KVEC),1) 2338 ENDIF 2339 2340 IF (LOCDEB) WRITE(LUPRI,*) 'Done generating the F-Vector' 2341 2342C Now iterate... ! 2343 2344 IF (MMTIME) DTIME = SECOND() 2345 2346 LM = 0 2347 DIPCON = .FALSE. 2348#if defined(VAR_MPI) 2349 IF (NODTOT .GE. 1) THEN 2350 CALL MMITER_INDDIP_M(POLDIM,WRK(KINDP),INDMOM,WRK(KVEC), 2351 * WRK(KINDDIA),WRK(KEND),LWRK1,LOCDEB,DIPCON,LM) 2352 ELSE 2353#endif 2354 DO 999 ITER = 1, MXMMIT 2355 LM = LM + 1 2356 2357 LRI = 1 2358 DO 405 I=1,MMCENT 2359 IF (ZEROAL(I) .EQ. -1) GOTO 405 2360 2361 LCI = 1 2362 DO 409 J=1,MMCENT 2363 2364 IF (ZEROAL(J) .EQ. -1) GOTO 409 2365 2366 CALL GET_MY(I,J,WRK(KINDP+LCI-1),MY) 2367 INDMOM(LRI+0) = INDMOM(LRI+0) + MY(1) 2368 INDMOM(LRI+1) = INDMOM(LRI+1) + MY(2) 2369 INDMOM(LRI+2) = INDMOM(LRI+2) + MY(3) 2370 LCI = LCI + 3 2371 409 CONTINUE 2372 2373 LRI = LRI + 3 2374 405 CONTINUE 2375 2376 TERROR=0.0D0 2377 DO 414 I=1,NDIM 2378 TERROR = TERROR + (INDMOM(I)-WRK(KINDP+I-1))* 2379 & (INDMOM(I)-WRK(KINDP+I-1)) 2380 414 CONTINUE 2381 2382 IF ( (LOCDEB) .OR. (IPRINT .GE. 15) ) THEN 2383 LMAX = 0 2384 TMAX = 0.0D0 2385 DO 413 I=1,NDIM 2386 TDIFF = ABS(INDMOM(I) - WRK(KINDP-1+I)) 2387 IF (TDIFF .GT. TMAX) THEN 2388 TMAX = TDIFF 2389 LMAX = I 2390 ENDIF 2391 413 CONTINUE 2392 IF (LMAX .NE. 0) THEN 2393 WRITE(LUPRI,*) 'Maximum deviation (element) is ', 2394 * TMAX, LMAX 2395 ENDIF 2396 ENDIF 2397 2398 IF (ABS(TERROR) .LT. THRESL) THEN 2399 DIPCON = .TRUE. 2400 GOTO 9000 2401 ELSE 2402 DIPCON = .FALSE. 2403 IF (LOCDEB )WRITE(LUPRI,*) 'TERROR ',TERROR 2404 IF (MMDIIS) THEN 2405 CALL DCOPY(NDIM,INDMOM,1,WRK(KVEC+ITER*NDIM),1) 2406 CALL MM_DIIS_EXTRAPOLATION(WRK(KVEC),ITER,NDIM,WRK(KINDP), 2407 * WRK(KEND),LWRK1,IPRINT) 2408 ELSE 2409 CALL DCOPY(NDIM,INDMOM,1,WRK(KINDP),1) 2410 ENDIF 2411C If no convergence in last iteration keep the values for the 2412C induced dipoles, i.e. not only the diagonal part 2413 IF (ITER .NE. MXMMIT) CALL DCOPY(NDIM,WRK(KINDDIA),1, 2414 * INDMOM,1) 2415 ENDIF 2416 2417 999 CONTINUE 2418 2419 9000 CONTINUE !Done 2420 2421#if defined(VAR_MPI) 2422 ENDIF !parallel mmiter 2423#endif 2424 IF (MMTIME) THEN 2425 DTIME = SECOND() - DTIME 2426 TMMITER = TMMITER + DTIME 2427 ENDIF 2428 2429 LM = LM - 1 2430 IF (DIPCON) THEN 2431 IF (IPRINT .GT. 1) THEN 2432 WRITE(LUPRI,*) 2433 WRITE(LUPRI,*) 'Done with induced dipoles in ',LM,' iterations' 2434 WRITE(LUPRI,*) 2435 ENDIF 2436 ELSE 2437 WRITE(LUPRI,*) 2438 WRITE(LUPRI,*) 'WARNING: Induced dipoles NOT converged' 2439 WRITE(LUPRI,*) 2440 ENDIF 2441 2442 NMMAC = NMMAC + LM 2443 IF (IPRINT .GT. 1) THEN 2444 WRITE(LUPRI,*) 'Acc. iterations:', NMMAC 2445 ENDIF 2446 2447 IF (FIRST) FIRST = .FALSE. 2448 2449 BTIME = SECOND() - BTIME 2450 TF2QMMM = TF2QMMM + BTIME 2451 2452 CALL QEXIT('F2QMMM') 2453 RETURN 2454 END 2455C****************************************************************************** 2456C /* Deck MM_DIIS_EXTRAPOLATION */ 2457 SUBROUTINE MM_DIIS_EXTRAPOLATION(VEC,ITER,NDIM,RESVEC,WRK,LWRK, 2458 * IPRINT) 2459C 2460C Find the optimal DIIS vector of previously iterated induced dipoles. 2461C 2462C Input: VEC, ITER, NDIM 2463C Output: RESVEC 2464C 2465C VEC is the collection of previos induced dipole vectors 2466C RESVEC is the result vector 2467C NDIM is 3*(the number of polarizable sites) 2468C ITER is the iteration number 2469C JK 2470 2471#include "implicit.h" 2472#include "priunit.h" 2473#include "dummy.h" 2474#include "mxcent.h" 2475#include "qmmm.h" 2476#include "qm3.h" 2477#include "iratdef.h" 2478#include "maxash.h" 2479#include "maxorb.h" 2480#include "inforb.h" 2481#include "inftap.h" 2482#include "infpri.h" 2483#include "scbrhf.h" 2484#include "maxaqn.h" 2485#include "symmet.h" 2486#include "orgcom.h" 2487#include "infinp.h" 2488#include "nuclei.h" 2489#include "codata.h" 2490 2491 LOGICAL LOCDEB 2492 2493 INTEGER NDIM,ITER 2494 2495 DOUBLE PRECISION VEC,RESVEC 2496 2497 DIMENSION VEC(NDIM,(MXMMIT+1)) 2498 DIMENSION RESVEC(NDIM) 2499 DIMENSION WRK(LWRK) 2500 2501 PARAMETER ( D2 = 2.0D0, D0 = 0.0D0, D1 = 1.0D0 ) 2502 2503 CALL QENTER('MM_DIIS_EXTRAPOLATION') 2504 2505 LOCDEB = .FALSE. 2506 2507 IF (ITER .LE. MXMMDI) THEN 2508 NDIIS= ITER+1 2509 IOFF = 0 2510 ELSE 2511 NDIIS = MXMMDI+1 2512 IOFF = ITER-MXMMDI 2513 ENDIF 2514 2515 KDIIS = 1 2516 KVECA = KDIIS + NDIIS*NDIIS 2517 KPVT = KVECA + NDIIS 2518 KEND = KPVT + NDIIS 2519 LWRK1 = LWRK - KEND 2520 IF (LWRK1 .LT. 0) CALL ERRWRK('MM_DIIS_EXTRAPOLATION',-KEND,LWRK) 2521 2522 CALL DZERO(WRK(KDIIS),NDIIS*NDIIS) 2523 CALL DZERO(WRK(KVECA),NDIIS) 2524 CALL DZERO(WRK(KPVT),NDIIS) 2525 2526 WRK(KDIIS) = D0 2527 WRK(KVECA) = -1.0D0 2528 2529 DO 100 I=1,NDIIS-1 2530 WRK(KDIIS+I) = -1.0D0 2531 WRK(KVECA+I) = D0 2532 100 CONTINUE 2533 2534 DO 101 I=2,NDIIS 2535 DO 102 J=1,NDIIS 2536 IF (J .EQ. 1) THEN 2537 WRK(KDIIS+(I-1)*NDIIS+(J-1)) = -1.0D0 2538 ELSE 2539 TEMP=0.0D0 2540 DO 103 K=1,NDIM 2541 TEMP = TEMP + (VEC(K,I+IOFF)-VEC(K,I-1+IOFF))* 2542 * (VEC(K,J+IOFF)-VEC(K,J-1+IOFF)) 2543 103 CONTINUE 2544 WRK(KDIIS+(I-1)*NDIIS+(J-1)) = TEMP 2545 ENDIF 2546 102 CONTINUE 2547 101 CONTINUE 2548 2549 IF (LOCDEB) THEN 2550 N=NDIIS 2551 WRITE(LUPRI,*) 'DIIS matrix in iteration ',ITER 2552 CALL OUTPUT(WRK(KDIIS),1,N,1,N,N,N,1,LUPRI) 2553 2554 WRITE(LUPRI,*) 'B-DIIS Vector',ITER 2555 DO 104 I=1,NDIIS 2556 WRITE(LUPRI,*) WRK(KVECA+I-1) 2557 104 CONTINUE 2558 ENDIF 2559 2560 CALL DGESV(NDIIS,1,WRK(KDIIS),NDIIS,WRK(KPVT),WRK(KVECA), 2561 * NDIIS,INFO) 2562 IF (INFO .NE. 0) THEN 2563 CALL QUIT('Error in MM_DIIS_EXTRAPOLATION') 2564 END IF 2565 2566 IF (LOCDEB) THEN 2567 WRITE(LUPRI,*) 'A-DIIS Vector',ITER 2568 DO 105 I=1,NDIIS 2569 WRITE(LUPRI,*) WRK(KVECA+I-1) 2570 105 CONTINUE 2571 ENDIF 2572 2573 TEMP = D0 2574 DO 106 I=2,NDIIS 2575 TEMP = TEMP + WRK(KVECA+I-1) 2576 106 CONTINUE 2577 2578 IF (ABS(TEMP-D1) .GT. 1.0D-08) THEN 2579 WRITE(LUPRI,*) 'WARNING: Sum of lambdas in MM_DIIS is ', TEMP 2580 ENDIF 2581 2582 CALL DZERO(RESVEC,NDIM) 2583 2584 DO 107 I=2,NDIIS 2585 CALL DAXPY(NDIM,WRK(KVECA+I-1),VEC(1,I+IOFF),1,RESVEC,1) 2586 107 CONTINUE 2587 2588 IF (LOCDEB .OR. (IPRINT .GE. 15)) THEN 2589 WRITE(LUPRI,*) 'Guess induced dipole vector from MM_DIIS',ITER 2590 DO 108 I=1,NDIM 2591 WRITE(LUPRI,*) RESVEC(I) 2592 108 CONTINUE 2593 ENDIF 2594 2595 CALL DCOPY(NDIM,RESVEC,1,VEC(1,NDIIS+IOFF),1) 2596 2597 IF (.FALSE.) THEN ! Damp procedure 2598 IF (ITER .GE. 2) THEN 2599 TEMP1 = 0.0D0 2600 TEMP2 = 0.0D0 2601 DO 200 I=1,NDIM 2602 TEMP1 = TEMP1 + (VEC(I,NDIIS)-VEC(I,NDIIS-1))**2 2603 TEMP2 = TEMP2 + (VEC(I,NDIIS)-VEC(I,NDIIS-2))**2 2604 200 CONTINUE 2605 TLAM1 = 1.0D0/TEMP1 2606 TLAM2 = 1.0D0/TEMP2 2607 TLAM = TLAM1/(TLAM1+TLAM2) 2608 TLAMM = 1.0D0-TLAM 2609 CALL DAXPY(NDIM,TLAM,VEC(1,NDIIS),1,RESVEC,1) 2610 CALL DAXPY(NDIM,TLAMM,VEC(1,NDIIS-1),1,RESVEC,1) 2611 CALL DCOPY(NDIM,RESVEC,1,VEC(1,NDIIS),1) 2612 ELSE 2613 CALL DAXPY(NDIM,1.0D0,VEC(1,NDIIS),1,RESVEC,1) 2614 ENDIF 2615 ENDIF 2616 2617 CALL QEXIT('MM_DIIS_EXTRAPOLATION') 2618 RETURN 2619 END 2620C****************************************************************************** 2621C /* Deck MAKE_QMMM_INVERSE_RESPONSE_MATRIX */ 2622 SUBROUTINE MAKE_QMMM_INVERSE_RESPONSE_MATRIX(INVMAT,POLDIM) ! Construct inverse response matrix 2623C 2624#include "implicit.h" 2625#include "priunit.h" 2626#include "dummy.h" 2627#include "mxcent.h" 2628#include "qmmm.h" 2629#include "qm3.h" 2630#include "iratdef.h" 2631#include "maxash.h" 2632#include "maxorb.h" 2633#include "inforb.h" 2634#include "inftap.h" 2635#include "infpri.h" 2636#include "scbrhf.h" 2637#include "maxaqn.h" 2638#include "symmet.h" 2639#include "orgcom.h" 2640#include "infinp.h" 2641#include "nuclei.h" 2642#include "codata.h" 2643C 2644 DOUBLE PRECISION AMATS 2645 DIMENSION AMATS(6) 2646 LOGICAL EXCENT 2647 INTEGER POLDIM, IPVT 2648 DOUBLE PRECISION INVMAT, WRKV 2649 DIMENSION INVMAT(3*POLDIM*(3*POLDIM+1)/2) 2650 DIMENSION IPVT(3) 2651 DIMENSION WRKV(3) 2652 2653 PARAMETER (D3I = 1.0D0/3.0D0, D6I = 1.0D0/6.0D0) 2654 2655 CALL QENTER('MAKE_QMMM_INV_RESP_MATRIX') 2656 2657 DO I=1,6 2658 AMATS(I) = 0.0D0 2659 END DO 2660 2661C Construct packed inverse response matrix 2662 2663 M = 0 2664 2665 DO I = 1, MMCENT 2666 2667 IF (ZEROAL(I) .EQ. -1) CYCLE 2668 2669C Isotropic polarizability is easy to invert 2670 IF ((IPOLTP .EQ. 1) .AND. (CONMAT)) THEN 2671 AMATS(1) = 1.0D0/POLIMM(I) 2672 AMATS(4) = 1.0D0/POLIMM(I) 2673 AMATS(6) = 1.0D0/POLIMM(I) 2674 ENDIF 2675 2676C Anisotropic polarizability inversion 2677 IF ((IPOLTP .EQ. 2) .AND. (CONMAT)) THEN 2678 AMATS(1) = POLMM(1,I) 2679 AMATS(2) = POLMM(2,I) 2680 AMATS(3) = POLMM(3,I) 2681 AMATS(4) = POLMM(4,I) 2682 AMATS(5) = POLMM(5,I) 2683 AMATS(6) = POLMM(6,I) 2684 2685C Factorization 2686 CALL DSPTRF('L', 3, AMATS, IPVT, INFO) 2687 IF (INFO .NE. 0) THEN 2688 DIST1 = 1.0D50 2689 DO K = 1, NUCIND 2690 DIST2 = SQRT((CORD(1,K)-MMCORD(1,I))**2 + 2691 * (CORD(2,K)-MMCORD(2,I))**2 + 2692 * (CORD(3,K)-MMCORD(3,I))**2) 2693 IF (DIST2 .LT. DIST1) THEN 2694 CLDIST = DIST2 2695 DIST1 = DIST2 2696 END IF 2697 END DO 2698 CLDIST = CLDIST*0.5291772108 2699 WRITE(LUPRI,*) ' ' 2700 WRITE(LUPRI,*) 'WARNING: problems with 2701 & polarizability at site:', I 2702 WRITE(LUPRI,*) 'Distance to closest QM nucleus is (Å):', 2703 & CLDIST 2704 WRITE(LUPRI,*) 'Polarizability (xx, xy, xz, yy, yz, zz):' 2705 DO K = 1, 6 2706 WRITE(LUPRI,*) POLMM(K,I) 2707 END DO 2708 CALL QUIT('Error during factorization of polarizability!') 2709 END IF 2710 2711C Inversion 2712 CALL DSPTRI('L', 3, AMATS, IPVT, WRKV, INFO) 2713 IF (INFO .NE. 0) THEN 2714 CALL QUIT('Error during inversion of local polarizability') 2715 END IF 2716 ENDIF 2717 2718 DO L = 3, 1, -1 2719 DO J = I, MMCENT 2720 IF (ZEROAL(J) .EQ. -1) CYCLE 2721 IF (J .EQ. I) THEN 2722 IF (L .EQ. 3) THEN 2723 DO K = 1, L 2724 INVMAT(M+K) = AMATS(K) 2725 END DO 2726 ELSE IF (L .EQ. 2) THEN 2727 DO K = 1, L 2728 INVMAT(M+K) = AMATS(3+K) 2729 END DO 2730 ELSE IF (L .EQ. 1) THEN 2731 INVMAT(M+1) = AMATS(5+1) 2732 END IF 2733 M = M + L 2734 ELSE 2735 IF (NOMB) THEN 2736 DO K = 1, 3 2737 INVMAT(M+K) = 0.0D0 2738 END DO 2739 M = M + 3 2740 CYCLE 2741 END IF 2742 2743 R = 0.0D0; R2 = 0.0D0 2744 R2 = (MMCORD(1,I)-MMCORD(1,J))**2 + 2745 & (MMCORD(2,I)-MMCORD(2,J))**2 + 2746 & (MMCORD(3,I)-MMCORD(3,J))**2 2747 R = SQRT(R2) 2748 R3 = R**3 2749 R5 = R**5 2750 2751 IF (R .GT. RCUTMM) THEN 2752 M = M + 3 2753 CYCLE 2754 ENDIF 2755 2756 EXCENT = .FALSE. 2757 IF (NEWEXC) THEN 2758 DO N = 1, NEXLST 2759 IF (EXLIST(1,I) .EQ. EXLIST(N,J)) EXCENT = .TRUE. 2760 ENDDO 2761 ELSE 2762 DO N = 1, NEXLST 2763 IF (EXLIST(N,I) .EQ. EXLIST(1,J)) EXCENT = .TRUE. 2764 END DO 2765 ENDIF 2766 2767 IF (EXCENT) THEN 2768 DO K = 1, 3 2769 INVMAT(M+K) = 0.0D0 2770 END DO 2771 M = M + 3 2772 ELSE 2773 2774C Include damping in the exponential form 2775C JPC A 102 (1998) 2399 & Mol. Sim. 32 (2006) 471 2776 IF (MMDAMP) THEN 2777 IF (IPOLTP .EQ. 1) THEN 2778 TEMPI = POLIMM(I) 2779 TEMPJ = POLIMM(J) 2780 ELSE IF (IPOLTP .EQ. 2) THEN 2781 TEMPI = (POLMM(1,I)+POLMM(4,I) 2782 & +POLMM(6,I))*D3I 2783 TEMPJ = (POLMM(1,J)+POLMM(4,J) 2784 & +POLMM(6,J))*D3I 2785 ENDIF 2786 TEMP = (TEMPI*TEMPJ)**D6I 2787 SCREEN = 2.1304*R/TEMP 2788 FE = 1.0D0-(1.0D0 + SCREEN + 0.5D0*SCREEN**2) 2789 & *EXP(-SCREEN) 2790 FT = FE - (D6I*SCREEN**3)*EXP(-SCREEN) 2791 ELSE 2792 FE = 1.0D0 2793 FT = 1.0D0 2794 ENDIF 2795 2796 IF (L .EQ. 3) THEN 2797 2798 DO K = 1, 3 2799 T = FT*3.0D0*(MMCORD(1,I) - MMCORD(1,J))* 2800 & (MMCORD(K,I) - MMCORD(K,J)) 2801 T = T/R5 2802 IF (K .EQ. 1) T = T - FE*1.0D0/R3 2803 INVMAT(M+K) = -1.0D0*T 2804 END DO 2805 2806 ELSE IF (L .EQ. 2) THEN 2807 DO K = 1, 3 2808 T = FT*3.0D0*(MMCORD(2,I) - MMCORD(2,J))* 2809 & (MMCORD(K,I) - MMCORD(K,J)) 2810 T = T/R5 2811 IF (K .EQ. 2) T = T - FE*1.0D0/R3 2812 INVMAT(M+K) = -1.0D0*T 2813 END DO 2814 ELSE IF (L .EQ. 1) THEN 2815 DO K = 1, 3 2816 T = FT*3.0D0*(MMCORD(3,I) - MMCORD(3,J))* 2817 & (MMCORD(K,I) - MMCORD(K,J)) 2818 T = T/R5 2819 IF (K .EQ. 3) T = T - FE*1.0D0/R3 2820 INVMAT(M+K) = -1.0D0*T 2821 END DO 2822 END IF 2823 M = M + 3 2824 END IF 2825 END IF 2826 END DO 2827 END DO 2828 END DO 2829 2830 CALL QEXIT('MAKE_QMMM_INV_RESP_MATRIX') 2831 2832 RETURN 2833 END 2834C****************************************************************************** 2835C 'Inside loops' routines (can be used both by parallel and sequential code) 2836C Arnfinn Oct. 2010 2837C****************************************************************************** 2838C /* Deck charge_iter */ 2839 SUBROUTINE CHARGE_ITER(I,DCAO,ENSEL,ENSNUC,LOCDEB, 2840 & TAO,WRK,LWRK,IPRTMP) 2841C 2842C Calculate the energy contribution due to the charge on a MM cite 2843C 2844C Input: 2845C I - MM cite I 2846C DCAO - density matrix 2847C LOCDEB - local debugging 2848C 2849C Output: 2850C ENSEL - Energy due to QM electrons 2851C ENSNUC - Energy due to QM nuclear 2852C TAO - Integrals 2853C 2854#include "implicit.h" 2855#include "mxcent.h" 2856#include "inforb.h" 2857#include "nuclei.h" 2858#include "qm3.h" 2859#include "qmmm.h" 2860#include "gnrinf.h" 2861#include "orgcom.h" 2862#include "priunit.h" 2863 2864 DIMENSION WRK(LWRK), DCAO(NNBASX), TAO(NNBASX) 2865 CHARACTER*8 LABINT(9*MXCENT) 2866 LOGICAL TOFILE, TRIMAT, EXP1VL, LOCDEB 2867 DIMENSION INTREP(9*MXCENT), INTADR(9*MXCENT) 2868 2869 CALL QENTER('CHARGE_ITER') 2870 2871 IF (ABS(MUL0MM(I)) .LE. THRMM) THEN 2872 ENSEL = 0.0D0 2873 ENSNUC = 0.0D0 2874 CALL QEXIT('CHARGE_ITER') 2875 RETURN 2876 ENDIF 2877 2878 FAC1 = 1.0D0 2879 2880 KMAT = 1 2881 KLAST = KMAT + NNBASX 2882 LWRK2 = LWRK - KLAST + 1 2883 IF (LWRK2 .LT. 0) CALL ERRWRK('CHARGE_ITER',-KLAST,LWRK) 2884 2885 CALL DZERO(WRK(KMAT),NNBASX) 2886 2887 KPATOM = 0 2888 NOSIM = 1 2889 TOFILE = .FALSE. 2890 TRIMAT = .TRUE. 2891 EXP1VL = .FALSE. 2892 DIPORG(1) = MMCORD(1,I) 2893 DIPORG(2) = MMCORD(2,I) 2894 DIPORG(3) = MMCORD(3,I) 2895 2896 IF (LOCDEB) THEN 2897C Test for numerical int. 2898 CORZSAVE = DIPORG(3) 2899 KMAT1 = KLAST 2900 KMAT2 = KMAT1 + NNBASX 2901 KMAT3 = KMAT2 + NNBASX 2902 KLAST1 = KMAT3 + NNBASX 2903 LWRK3 = LWRK - KLAST1 + 1 2904 2905 IF (LWRK3 .LT. 0) CALL ERRWRK('CHARGE_ITER 2',-KLAST1,LWRK) 2906 2907 CALL DZERO(WRK(KMAT1),3*NNBASX) 2908 2909 DIPORG(3) = DIPORG(3) + 0.01 2910 RUNQM3=.TRUE. 2911 CALL GET1IN(WRK(KMAT1),'NPETES ',NOSIM,WRK(KLAST1), 2912 & LWRK3,LABINT,INTREP,INTADR,I,TOFILE, 2913 & KPATOM,TRIMAT,DUMMY,EXP1VL,DUMMY,IPRTMP) 2914 DIPORG(3) = DIPORG(3) - 0.02 2915 CALL GET1IN(WRK(KMAT2),'NPETES ',NOSIM,WRK(KLAST1), 2916 & LWRK3,LABINT,INTREP,INTADR,I,TOFILE, 2917 & KPATOM,TRIMAT,DUMMY,EXP1VL,DUMMY,IPRTMP) 2918 DIPORG(3) = CORZSAVE 2919 CALL GET1IN(WRK(KMAT3),'NPETES ',NOSIM,WRK(KLAST1), 2920 & LWRK3,LABINT,INTREP,INTADR,I,TOFILE, 2921 & KPATOM,TRIMAT,DUMMY,EXP1VL,DUMMY,IPRTMP) 2922 RUNQM3=.FALSE. 2923C Gradient 2924 FM1 = -1.0D0 2925 FSCAL = 1.0D0/0.02 2926 CALL DAXPY(NNBASX,FM1,WRK(KMAT2),1,WRK(KMAT1),1) 2927 CALL DSCAL(NNBASX,FSCAL,WRK(KMAT1),1) 2928 FSCAL = -1.0D0 2929 CALL DSCAL(NNBASX,FSCAL,WRK(KMAT1),1) 2930 WRITE (LUPRI,'(/A)') 'E_z num matrix in QMMM_FCK_AO' 2931 CALL OUTPAK(WRK(KMAT1),NBAST,1,LUPRI) 2932 DIPORG(3) = CORZSAVE 2933 ENDIF 2934 2935 RUNQM3=.TRUE. 2936 CALL GET1IN(WRK(KMAT),'NPETES ',NOSIM,WRK(KLAST), 2937 & LWRK2,LABINT,INTREP,INTADR,I,TOFILE, 2938 & KPATOM,TRIMAT,DUMMY,EXP1VL,DUMMY,IPRTMP) 2939 RUNQM3=.FALSE. 2940 2941 IF ( (IPRTMP.GT.15) .OR. (LOCDEB) ) THEN 2942 WRITE (LUPRI,'(/A)') 'Pot. energy matrix in QMMM_CHARGE' 2943 CALL OUTPAK(WRK(KMAT),NBAST,1,LUPRI) 2944 ENDIF 2945 2946 CALL DSCAL(NNBASX,MUL0MM(I),WRK(KMAT),1) 2947 EXPNS=DDOT(NNBASX,DCAO,1,WRK(KMAT),1) 2948 ENSEL = EXPNS 2949 2950 CALL DAXPY(NNBASX,FAC1,WRK(KMAT),1,TAO,1) 2951 2952C Now the QM nuclear contribution 2953 2954 ECHCHL = 0.0D0 2955 DO 101 J = 1,NUCIND 2956 XDIS = CORD(1,J) - MMCORD(1,I) 2957 YDIS = CORD(2,J) - MMCORD(2,I) 2958 ZDIS = CORD(3,J) - MMCORD(3,I) 2959 DIST2 = XDIS**2+YDIS**2+ZDIS**2 2960 DIST = SQRT(DIST2) 2961 ECHCHL = ECHCHL + CHARGE(J)*MUL0MM(I)/DIST 2962 101 CONTINUE 2963 2964 ENSNUC = ECHCHL 2965 2966 CALL QEXIT('CHARGE_ITER') 2967 2968 RETURN 2969 END 2970C 2971C****************************************************************************** 2972C /* Deck dipole_iter */ 2973 SUBROUTINE DIPOLE_ITER(I,DCAO,ENSEL,ENSNUC,LOCDEB, 2974 * TAO,WRK,LWRK,IPRTMP) 2975 2976#include "implicit.h" 2977#include "mxcent.h" 2978#include "inforb.h" 2979#include "nuclei.h" 2980#include "qm3.h" 2981#include "qmmm.h" 2982#include "gnrinf.h" 2983#include "orgcom.h" 2984#include "priunit.h" 2985 2986 DIMENSION WRK(LWRK), DCAO(NNBASX), TAO(NNBASX) 2987 CHARACTER*8 LABINT(9*MXCENT) 2988 LOGICAL TOFILE, TRIMAT, EXP1VL, LOCDEB 2989 DIMENSION INTREP(9*MXCENT), INTADR(9*MXCENT) 2990 PARAMETER (D3I = 1.0D0/3.0D0, D6I = 1.0D0/6.0D0) 2991 2992 CALL QENTER('DIPOLE_ITER') 2993 2994C See if the dipole moment at this site is zero 2995 DNORM2 = MUL1MM(1,I)**2+MUL1MM(2,I)**2+MUL1MM(3,I)**2 2996 DNORM = SQRT(DNORM2) 2997 IF (ABS(DNORM) .LE. THRMM) THEN 2998 ENSEL = 0.0D0 2999 ENSNUC = 0.0D0 3000 CALL QEXIT('DIPOLE_ITER') 3001 RETURN 3002 ENDIF 3003 3004 FAC1 = 1.0D0 3005 FACM1 = -1.0D0 3006 3007 KMAT = 1 3008 KLAST = KMAT + 3*NNBASX 3009 LWRK2 = LWRK - KLAST + 1 3010 IF (LWRK2 .LT. 0) CALL ERRWRK('DIPOLE_ITER',-KLAST,LWRK) 3011 3012 CALL DZERO(WRK(KMAT),3*NNBASX) 3013 3014 KPATOM = 0 3015 NOSIM = 3 3016 TOFILE = .FALSE. 3017 TRIMAT = .TRUE. 3018 EXP1VL = .FALSE. 3019 DIPORG(1) = MMCORD(1,I) 3020 DIPORG(2) = MMCORD(2,I) 3021 DIPORG(3) = MMCORD(3,I) 3022 3023 IF (LOCDEB) THEN 3024C TEST for numerical int. 3025 CORZSAVE = DIPORG(3) 3026 3027 KMAT1 = KLAST 3028 KMAT2 = KMAT1 + 3*NNBASX 3029 KMAT3 = KMAT2 + 3*NNBASX 3030 KLAST1 = KMAT3 + 3*NNBASX 3031 LWRK3 = LWRK - KLAST1 + 1 3032 3033 IF (LWRK3 .LT. 0) CALL ERRWRK('QMMM_DIPOLE 2',-KLAST1,LWRK) 3034 3035 CALL DZERO(WRK(KMAT1),9*NNBASX) 3036 3037 DIPORG(3) = DIPORG(3) + 0.01 3038 RUNQM3=.TRUE. 3039 CALL GET1IN(WRK(KMAT1),'NEFIELD',NOSIM,WRK(KLAST1), 3040 & LWRK3,LABINT,INTREP,INTADR,I,TOFILE, 3041 & KPATOM,TRIMAT,DUMMY,EXP1VL,DUMMY,IPRTMP) 3042 DIPORG(3) = DIPORG(3) - 0.02 3043 CALL GET1IN(WRK(KMAT2),'NEFIELD',NOSIM,WRK(KLAST1), 3044 & LWRK3,LABINT,INTREP,INTADR,I,TOFILE, 3045 & KPATOM,TRIMAT,DUMMY,EXP1VL,DUMMY,IPRTMP) 3046 DIPORG(3) = CORZSAVE 3047 CALL GET1IN(WRK(KMAT3),'NEFIELD',NOSIM,WRK(KLAST1), 3048 & LWRK3,LABINT,INTREP,INTADR,I,TOFILE, 3049 & KPATOM,TRIMAT,DUMMY,EXP1VL,DUMMY,IPRTMP) 3050 RUNQM3=.FALSE. 3051C Gradient 3052 FM1 = -1.0D0 3053 FSCAL = 1.0D0/0.02 3054 CALL DAXPY(3*NNBASX,FM1,WRK(KMAT2),1,WRK(KMAT1),1) 3055 CALL DSCAL(3*NNBASX,FSCAL,WRK(KMAT1),1) 3056 FSCAL = -1.0D0 3057 CALL DSCAL(3*NNBASX,FSCAL,WRK(KMAT1),1) 3058 WRITE (LUPRI,'(/A)') 'E_xz num matrix in QMMM_FCK_AO' 3059 CALL OUTPAK(WRK(KMAT1),NBAST,1,LUPRI) 3060 WRITE (LUPRI,'(/A)') 'E_zz num matrix in QMMM_FCK_AO' 3061 CALL OUTPAK(WRK(KMAT1+2*NNBASX),NBAST,1,LUPRI) 3062 3063 DIPORG(3) = CORZSAVE 3064 ENDIF 3065 3066 RUNQM3=.TRUE. 3067 CALL GET1IN(WRK(KMAT),'NEFIELD',NOSIM,WRK(KLAST), 3068 & LWRK2,LABINT,INTREP,INTADR,I,TOFILE, 3069 & KPATOM,TRIMAT,DUMMY,EXP1VL,DUMMY,IPRTMP) 3070 RUNQM3=.FALSE. 3071 3072 IF (QMDAMP) THEN 3073 IF ( (IDAMP .EQ. 3) .AND. (NQMNUC .NE. NUCIND) ) THEN 3074 CALL QUIT('ERROR in no. of assigned QM polarizabilities') 3075 ENDIF 3076 IF ( (IDAMP .EQ. 1) .OR. (IDAMP .EQ. 3) ) THEN 3077 DIST = 9.99D+99 3078 MHIT = 0 3079 DO 123 M=1,NUCIND 3080 DISTC = (DIPORG(1)-CORD(1,M))**2 + 3081 & (DIPORG(2)-CORD(2,M))**2 + 3082 & (DIPORG(3)-CORD(3,M))**2 3083 IF (DISTC .LE. DIST) THEN 3084 DIST = DISTC 3085 MHIT = M 3086 ENDIF 3087 123 CONTINUE 3088 ELSE IF (IDAMP .EQ. 2) THEN 3089 DIST = (DIPORG(1)-QMCOM(1))**2 + 3090 & (DIPORG(2)-QMCOM(2))**2 + 3091 & (DIPORG(3)-QMCOM(3))**2 3092 ENDIF 3093 DIST = SQRT(DIST) 3094 3095 IF (IDAMP .EQ. 3) THEN 3096 IF (IPOLTP .EQ. 2) THEN 3097 TEMPI = D3I*(POLMM(1,I)+POLMM(4,I)+POLMM(6,I)) 3098 ELSE IF (IPOLTP .EQ. 1) THEN 3099 IF (IPOLTP .EQ. 1) TEMPI = POLIMM(I) 3100 ENDIF 3101 TEMP = (TEMPI*QMPOL(MHIT))**(D6I) 3102 SIJ = 2.1304*DIST/TEMP 3103 DFACT = 1.0D0 - (1.0D0+SIJ+0.50D0*SIJ*SIJ)*exp(-SIJ) 3104 ELSE 3105 DFACT = (1-exp(-ADAMP*DIST))**3 3106 ENDIF 3107 CALL DSCAL(3*NNBASX,DFACT,WRK(KMAT),1) 3108 ENDIF 3109 3110 IF ( (IPRTMP.GT.15) .OR. (LOCDEB) ) THEN 3111 WRITE (LUPRI,'(/A)') ' E_x_matrix in QMMM_FCK:' 3112 CALL OUTPAK(WRK(KMAT),NBAST,1,LUPRI) 3113 3114 WRITE (LUPRI,'(/A)') ' E_y matrix in QMMM_FCK:' 3115 CALL OUTPAK(WRK(KMAT+NNBASX),NBAST,1,LUPRI) 3116 3117 WRITE (LUPRI,'(/A)') ' E_z matrix in QMMM_FCK:' 3118 CALL OUTPAK(WRK(KMAT+2*NNBASX),NBAST,1,LUPRI) 3119 END IF 3120 3121 CALL DSCAL(NNBASX,MUL1MM(1,I),WRK(KMAT),1) 3122 CALL DSCAL(NNBASX,MUL1MM(2,I),WRK(KMAT+NNBASX),1) 3123 CALL DSCAL(NNBASX,MUL1MM(3,I),WRK(KMAT+2*NNBASX),1) 3124 3125 CALL DAXPY(NNBASX,FACM1,WRK(KMAT),1,TAO,1) 3126 CALL DAXPY(NNBASX,FACM1,WRK(KMAT+NNBASX),1,TAO,1) 3127 CALL DAXPY(NNBASX,FACM1,WRK(KMAT+2*NNBASX),1,TAO,1) 3128 3129 EXCOMP = -DDOT(NNBASX,DCAO,1,WRK(KMAT),1) 3130 EYCOMP = -DDOT(NNBASX,DCAO,1,WRK(KMAT+NNBASX),1) 3131 EZCOMP = -DDOT(NNBASX,DCAO,1,WRK(KMAT+2*NNBASX),1) 3132 3133 ENSEL = EXCOMP + EYCOMP + EZCOMP 3134 3135C Now the QM nuclear contribution. Note that we switch the sign here 3136C by writing CORD(1,J) - MMCORD(1,I) 3137 3138 ELOC = 0.0D0 3139 DO 201 J = 1,NUCIND 3140 XDIS = CORD(1,J) - MMCORD(1,I) 3141 YDIS = CORD(2,J) - MMCORD(2,I) 3142 ZDIS = CORD(3,J) - MMCORD(3,I) 3143 DIST2 = XDIS**2+YDIS**2+ZDIS**2 3144 DIST = SQRT(DIST2) 3145 DIST3 = DIST2*DIST 3146 ELOC = ELOC 3147 * + CHARGE(J)*MUL1MM(1,I)*XDIS/DIST3 3148 * + CHARGE(J)*MUL1MM(2,I)*YDIS/DIST3 3149 * + CHARGE(J)*MUL1MM(3,I)*ZDIS/DIST3 3150 201 CONTINUE 3151 ENSNUC = ELOC 3152 3153 CALL QEXIT('DIPOLE_ITER') 3154 3155 RETURN 3156 END 3157C****************************************************************************** 3158C /* Deck quadpole_iter */ 3159 SUBROUTINE QUADPOLE_ITER(I,DCAO,ENSEL,ENSNUC,LOCDEB, 3160 & TAO,WRK,LWRK,IPRTMP) 3161 3162#include "implicit.h" 3163#include "mxcent.h" 3164#include "inforb.h" 3165#include "nuclei.h" 3166#include "qm3.h" 3167#include "qmmm.h" 3168#include "gnrinf.h" 3169#include "orgcom.h" 3170#include "priunit.h" 3171 3172 DIMENSION WRK(LWRK), DCAO(NNBASX), TAO(NNBASX) 3173 CHARACTER*8 LABINT(9*MXCENT) 3174 LOGICAL TOFILE, TRIMAT, EXP1VL, LOCDEB 3175 DIMENSION INTREP(9*MXCENT), INTADR(9*MXCENT) 3176 PARAMETER ( D2 = 2.0D0 ) 3177 3178 CALL QENTER('QUADPOLE_ITER') 3179 3180 FAC1 = 1.0D0 3181 FACM1 = -1.0D0 3182 3183 KMAT = 1 3184 KLAST = KMAT + 6*NNBASX 3185 LWRK2 = LWRK - KLAST + 1 3186 IF (LWRK2 .LT. 0) CALL ERRWRK('QUADPOLE_ITER',-KLAST,LWRK) 3187 3188C See if the quadrupole moment at this site is zero 3189 DNORM2 = MUL2MM(1,I)**2+MUL2MM(2,I)**2+MUL2MM(3,I)**2 3190 * + MUL2MM(4,I)**2+MUL2MM(5,I)**2+MUL2MM(6,I)**2 3191 DNORM = SQRT(DNORM2) 3192 IF (ABS(DNORM) .LE. THRMM) THEN 3193 ENSEL = 0.0D0 3194 ENSNUC = 0.0D0 3195 CALL QEXIT('QUADPOLE_ITER') 3196 RETURN 3197 ENDIF 3198 3199 CALL DZERO(WRK(KMAT),6*NNBASX) 3200 3201 KPATOM = 0 3202 NOSIM = 6 3203 TOFILE = .FALSE. 3204 TRIMAT = .TRUE. 3205 EXP1VL = .FALSE. 3206 DIPORG(1) = MMCORD(1,I) 3207 DIPORG(2) = MMCORD(2,I) 3208 DIPORG(3) = MMCORD(3,I) 3209 3210 RUNQM3=.TRUE. 3211 CALL GET1IN(WRK(KMAT),'ELFGRDC',NOSIM,WRK(KLAST), 3212 & LWRK2,LABINT,INTREP,INTADR,I,TOFILE, 3213 & KPATOM,TRIMAT,DUMMY,EXP1VL,DUMMY,IPRTMP) 3214 RUNQM3=.FALSE. 3215 3216 IF ( (IPRTMP.GT.15) .OR. (LOCDEB) ) THEN 3217 WRITE (LUPRI,'(/A)') ' E_xx_matrix in QMMM_FCK:' 3218 CALL OUTPAK(WRK(KMAT),NBAST,1,LUPRI) 3219 3220 WRITE (LUPRI,'(/A)') ' E_xy matrix in QMMM_FCK:' 3221 CALL OUTPAK(WRK(KMAT+NNBASX),NBAST,1,LUPRI) 3222 3223 WRITE (LUPRI,'(/A)') ' E_xz matrix in QMMM_FCK:' 3224 CALL OUTPAK(WRK(KMAT+2*NNBASX),NBAST,1,LUPRI) 3225 3226 WRITE (LUPRI,'(/A)') ' E_yy_matrix in QMMM_FCK:' 3227 CALL OUTPAK(WRK(KMAT+3*NNBASX),NBAST,1,LUPRI) 3228 3229 WRITE (LUPRI,'(/A)') ' E_yz_matrix in QMMM_FCK:' 3230 CALL OUTPAK(WRK(KMAT+4*NNBASX),NBAST,1,LUPRI) 3231 3232 WRITE (LUPRI,'(/A)') ' E_zz_matrix in QMMM_FCK:' 3233 CALL OUTPAK(WRK(KMAT+5*NNBASX),NBAST,1,LUPRI) 3234 END IF 3235 3236 CALL DSCAL(NNBASX,MUL2MM(1,I),WRK(KMAT),1) 3237 CALL DSCAL(NNBASX,D2*MUL2MM(2,I),WRK(KMAT+NNBASX),1) 3238 CALL DSCAL(NNBASX,D2*MUL2MM(3,I),WRK(KMAT+2*NNBASX),1) 3239 CALL DSCAL(NNBASX,MUL2MM(4,I),WRK(KMAT+3*NNBASX),1) 3240 CALL DSCAL(NNBASX,D2*MUL2MM(5,I),WRK(KMAT+4*NNBASX),1) 3241 CALL DSCAL(NNBASX,MUL2MM(6,I),WRK(KMAT+5*NNBASX),1) 3242 3243 FACS = 0.5D0 3244 CALL DSCAL(6*NNBASX,FACS,WRK(KMAT),1) 3245C 3246C The integrals contains a factor of -1. Therefore daxpy with fac1 3247 CALL DAXPY(NNBASX,FAC1,WRK(KMAT),1,TAO(1),1) 3248 CALL DAXPY(NNBASX,FAC1,WRK(KMAT+NNBASX),1,TAO(1),1) 3249 CALL DAXPY(NNBASX,FAC1,WRK(KMAT+2*NNBASX),1,TAO(1),1) 3250 CALL DAXPY(NNBASX,FAC1,WRK(KMAT+3*NNBASX),1,TAO(1),1) 3251 CALL DAXPY(NNBASX,FAC1,WRK(KMAT+4*NNBASX),1,TAO(1),1) 3252 CALL DAXPY(NNBASX,FAC1,WRK(KMAT+5*NNBASX),1,TAO(1),1) 3253 3254C Contract with the density to get the expectation values. The 3255C factor of 1/2 in the Taylor expansion has been included. Also, 3256C the off-diagonal elements have been scaled by 2 in order to 3257C include all contributions (the off -diagonal parts are related by 3258C symmetry) 3259 3260C Since the integrals contains a factor of -1 no -DDOT here. 3261 3262 EMU2XX=DDOT(NNBASX,DCAO,1,WRK(KMAT),1) 3263 EMU2XY=DDOT(NNBASX,DCAO,1,WRK(KMAT+NNBASX),1) 3264 EMU2XZ=DDOT(NNBASX,DCAO,1,WRK(KMAT+2*NNBASX),1) 3265 EMU2YY=DDOT(NNBASX,DCAO,1,WRK(KMAT+3*NNBASX),1) 3266 EMU2YZ=DDOT(NNBASX,DCAO,1,WRK(KMAT+4*NNBASX),1) 3267 EMU2ZZ=DDOT(NNBASX,DCAO,1,WRK(KMAT+5*NNBASX),1) 3268 3269 EQTOT = EMU2XX + EMU2XY + EMU2XZ + EMU2YY + EMU2YZ + EMU2ZZ 3270 ENSEL = EQTOT 3271 3272C Now the QM nuclear contribution 3273 3274 ELOC = 0.0D0 3275 DO 301 J = 1,NUCIND 3276 XDIS = CORD(1,J) - MMCORD(1,I) 3277 YDIS = CORD(2,J) - MMCORD(2,I) 3278 ZDIS = CORD(3,J) - MMCORD(3,I) 3279 DIST2 = XDIS**2+YDIS**2+ZDIS**2 3280 DIST = SQRT(DIST2) 3281 DIST3 = DIST2*DIST 3282 DIST5 = DIST3*DIST2 3283C 3284 TXX = (3.0D0*XDIS*XDIS - DIST2)/DIST5 3285 TXY = 3.0D0*XDIS*YDIS/DIST5 3286 TXZ = 3.0D0*XDIS*ZDIS/DIST5 3287 TYY = (3.0D0*YDIS*YDIS - DIST2)/DIST5 3288 TYZ = 3.0D0*YDIS*ZDIS/DIST5 3289 TZZ = (3.0D0*ZDIS*ZDIS - DIST2)/DIST5 3290 3291 ELOC = ELOC 3292 * + CHARGE(J)*MUL2MM(1,I)*TXX 3293 * + 2*CHARGE(J)*MUL2MM(2,I)*TXY 3294 * + 2*CHARGE(J)*MUL2MM(3,I)*TXZ 3295 * + CHARGE(J)*MUL2MM(4,I)*TYY 3296 * + 2*CHARGE(J)*MUL2MM(5,I)*TYZ 3297 * + CHARGE(J)*MUL2MM(6,I)*TZZ 3298 301 CONTINUE 3299 3300C Remember the factor of 1/2 from the Taylor expansion 3301 ELOC = 0.5D0*ELOC 3302 3303 ENSNUC = ELOC 3304 3305 CALL QEXIT('QUADPOLE_ITER') 3306 3307 RETURN 3308 END 3309 3310C****************************************************************************** 3311C /* Deck get_field */ 3312 SUBROUTINE GET_FIELD(I,LRI,ELF,ELFEL,ELFNU,DCAO, 3313 & LOCDEB,WRK,LWRK) 3314 3315 IMPLICIT NONE 3316#include "mxcent.h" 3317#include "inforb.h" 3318#include "nuclei.h" 3319#include "qm3.h" 3320#include "qmmm.h" 3321#include "gnrinf.h" 3322#include "orgcom.h" 3323#include "priunit.h" 3324 3325 INTEGER LWRK, I, LRI 3326 DOUBLE PRECISION WRK, DCAO, ELF, ELFEL, ELFNU 3327 DIMENSION WRK(LWRK), DCAO(NNBASX) 3328 DIMENSION ELF(*), ELFEL(*), ELFNU(*) 3329 LOGICAL LSKIP, LOCDEB 3330 3331 INTEGER KMAT, KEND, LWRK1 3332 DOUBLE PRECISION EXELCO, EYELCO, EZELCO, DDOT 3333 3334 CALL QENTER('GET_FIELD') 3335 3336 KMAT = 1 3337 KEND = KMAT + 3*NNBASX 3338 LWRK1 = LWRK - KEND + 1 3339 3340C Calculate field due to MM multipoles 3341 CALL CCMM_FMUL(ELF,LRI,I) 3342 3343C Add QM region contribution to the F vector 3344 3345C A) electronic contribution 3346 3347 CALL DZERO(WRK(KMAT),3*NNBASX) 3348 3349 LSKIP = .FALSE. 3350 3351 CALL CCMM_EPSAO(WRK(KMAT),I,LSKIP,WRK(KEND),LWRK1) 3352 3353 IF (LSKIP) THEN 3354 CALL QEXIT('GET_FIELD') 3355 RETURN 3356 END IF 3357 3358 EXELCO = DDOT(NNBASX,DCAO,1,WRK(KMAT),1) 3359 EYELCO = DDOT(NNBASX,DCAO,1,WRK(KMAT+NNBASX),1) 3360 EZELCO = DDOT(NNBASX,DCAO,1,WRK(KMAT+2*NNBASX),1) 3361 3362 IF (SPLDIP) THEN 3363 ELFEL(LRI+0) = EXELCO 3364 ELFEL(LRI+1) = EYELCO 3365 ELFEL(LRI+2) = EZELCO 3366 ELSE 3367 ELF(LRI+0) = ELF(LRI+0) + EXELCO 3368 ELF(LRI+1) = ELF(LRI+1) + EYELCO 3369 ELF(LRI+2) = ELF(LRI+2) + EZELCO 3370 ENDIF 3371 3372 IF (LOCDEB) THEN 3373 WRITE(LUPRI,*) 'electronic field:',EXELCO,EYELCO,EZELCO 3374 ENDIF 3375 3376C B) nuclear contribution 3377 IF (SPLDIP) THEN 3378 CALL CCMM_FNUC(ELFNU,LRI,I) 3379 ELSE 3380 CALL CCMM_FNUC(ELF,LRI,I) 3381 END IF 3382 3383 CALL QEXIT('GET_FIELD') 3384 3385 RETURN 3386 END 3387C****************************************************************************** 3388C /* Deck get_pol_contr */ 3389 SUBROUTINE GET_POL_CONTR(I,DINDMOM,EDALL,DCAO,TAO, 3390 & WRK,LWRK) 3391 3392#include "implicit.h" 3393#include "mxcent.h" 3394#include "inforb.h" 3395#include "nuclei.h" 3396#include "qm3.h" 3397#include "qmmm.h" 3398#include "gnrinf.h" 3399#include "orgcom.h" 3400#include "priunit.h" 3401 3402 DIMENSION WRK(LWRK), DCAO(NNBASX), TAO(NNBASX) 3403 DIMENSION DINDMOM(3),EDALL(6) 3404 LOGICAL LSKIP, EXCENT 3405 PARAMETER ( DMINV2 = -0.50D0 ) 3406 PARAMETER ( D3I = 1.0D0/3.0D0, D6I = 1.0D0/6.0D0 ) 3407 3408 CALL QENTER('GET_POL_CONTR') 3409 3410 FACM1 = -1.0D0 3411 3412 KMAT = 1 3413 KLAST = KMAT + 3*NNBASX 3414 LWRK2 = LWRK - KLAST + 1 3415 3416 LSKIP = .FALSE. 3417 3418 CALL CCMM_EPSAO(WRK(KMAT),I,LSKIP,WRK(KLAST),LWRK2) 3419 3420 IF (LSKIP) THEN 3421 CALL QEXIT('GET_POL_CONTR') 3422 RETURN 3423 ENDIF 3424 3425 CALL DZERO(EDALL,6) 3426 CALL DSCAL(NNBASX,DINDMOM(1),WRK(KMAT),1) 3427 CALL DSCAL(NNBASX,DINDMOM(2),WRK(KMAT+NNBASX),1) 3428 CALL DSCAL(NNBASX,DINDMOM(3),WRK(KMAT+2*NNBASX),1) 3429 3430 CALL DAXPY(NNBASX,FACM1,WRK(KMAT),1,TAO,1) 3431 CALL DAXPY(NNBASX,FACM1,WRK(KMAT+NNBASX),1,TAO,1) 3432 CALL DAXPY(NNBASX,FACM1,WRK(KMAT+2*NNBASX),1,TAO,1) 3433 3434C Polarization contribution to the total energy 3435 3436C A) Electronic contribution 3437 3438 EXCOMP = DDOT(NNBASX,DCAO,1,WRK(KMAT),1) 3439 EYCOMP = DDOT(NNBASX,DCAO,1,WRK(KMAT+NNBASX),1) 3440 EZCOMP = DDOT(NNBASX,DCAO,1,WRK(KMAT+2*NNBASX),1) 3441 3442 ET = 0.0D0 3443 ET = ET + DMINV2*(EXCOMP + EYCOMP + EZCOMP) 3444 EDALL(1) = ET 3445 3446C B) Nuclear contribution 3447 3448 EFNUCX = 0.0D0 3449 EFNUCY = 0.0D0 3450 EFNUCZ = 0.0D0 3451 3452 DO 510 J=1,NUCIND 3453 CALL GET_CHARGE_ELFLD(CHARGE(J), 3454 & CORD(1,J),CORD(2,J),CORD(3,J), 3455 & MMCORD(1,I),MMCORD(2,I),MMCORD(3,I), 3456 & ELFLDX,ELFLDY,ELFLDZ) 3457 EFNUCX = EFNUCX + ELFLDX 3458 EFNUCY = EFNUCY + ELFLDY 3459 EFNUCZ = EFNUCZ + ELFLDZ 3460 510 CONTINUE 3461 3462 IF (QMDAMP) THEN 3463 IF ( (IDAMP .EQ. 3) .AND. (NQMNUC .NE. NUCIND) ) THEN 3464 CALL QUIT('ERROR in no. of assigned QM polarizabilities') 3465 ENDIF 3466 IF ( (IDAMP .EQ. 1) .OR. (IDAMP .EQ. 3) ) THEN 3467 DIQM = 9.99D+99 3468 MHIT = 0 3469 DO 125 M=1,NUCIND 3470 DIQMC = (MMCORD(1,I)-CORD(1,M))**2 + 3471 & (MMCORD(2,I)-CORD(2,M))**2 + 3472 & (MMCORD(3,I)-CORD(3,M))**2 3473 IF (DIQMC .LE. DIQM) THEN 3474 DIQM = DIQMC 3475 MHIT = M 3476 ENDIF 3477 125 CONTINUE 3478 ELSE IF (IDAMP .EQ. 2) THEN 3479 DIQM = (MMCORD(1,I)-QMCOM(1))**2 + 3480 & (MMCORD(2,I)-QMCOM(2))**2 + 3481 & (MMCORD(3,I)-QMCOM(3))**2 3482 ENDIF 3483 DIQM = SQRT(DIQM) 3484 3485 IF (IDAMP .EQ. 3) THEN 3486 IF (IPOLTP .EQ. 2) THEN 3487 TEMPI = D3I*(POLMM(1,I)+POLMM(4,I)+POLMM(6,I)) 3488 ELSE IF (IPOLTP .EQ. 1) THEN 3489 IF (IPOLTP .EQ. 1) TEMPI = POLIMM(I) 3490 ENDIF 3491 TEMP = (TEMPI*QMPOL(MHIT))**(D6I) 3492 SIJ = 2.1304*DIQM/TEMP 3493 DFACT = 1.0D0 - (1.0D0+SIJ+0.50D0*SIJ*SIJ)*exp(-SIJ) 3494 ELSE 3495 DFACT = (1-exp(-ADAMP*DIQM))**3 3496 ENDIF 3497 3498 EFNUCX = EFNUCX*DFACT 3499 EFNUCY = EFNUCY*DFACT 3500 EFNUCZ = EFNUCZ*DFACT 3501 END IF 3502 3503 EXCOMP = DINDMOM(1)*EFNUCX 3504 EYCOMP = DINDMOM(2)*EFNUCY 3505 EZCOMP = DINDMOM(3)*EFNUCZ 3506 3507 ET = 0.0D0 3508 ET = ET + DMINV2*(EXCOMP + EYCOMP + EZCOMP) 3509 EDALL(2) = ET 3510 3511C C) Multipole contribution 3512 3513 EF0MX = 0.0D0 3514 EF0MY = 0.0D0 3515 EF0MZ = 0.0D0 3516 EF1MX = 0.0D0 3517 EF1MY = 0.0D0 3518 EF1MZ = 0.0D0 3519 EF2MX = 0.0D0 3520 EF2MY = 0.0D0 3521 EF2MZ = 0.0D0 3522 EF3MX = 0.0D0 3523 EF3MY = 0.0D0 3524 EF3MZ = 0.0D0 3525 3526C Get electric fields due to permanent moments 3527 3528 DO 520 J=1,MMCENT 3529 3530 IF (J .EQ. I) GOTO 520 3531 3532 EXCENT = .FALSE. 3533 IF (NEWEXC) THEN 3534 DO L = 1, NEXLST 3535 IF (EXLIST(1,I) .EQ. EXLIST(L,J)) EXCENT = .TRUE. 3536 ENDDO 3537 ELSE 3538 DO L = 1, NEXLST 3539 IF (EXLIST(L,I) .EQ. EXLIST(1,J)) EXCENT = .TRUE. 3540 END DO 3541 ENDIF 3542 3543 IF (.NOT. EXCENT) THEN 3544 3545C C.1 Point-charge contribution 3546 3547 IF ( (NMULT .GE. 0) .AND. 3548 & (ABS(MUL0MM(J)) .GT. THRMM) ) THEN 3549 3550 CALL GET_CHARGE_ELFLD(MUL0MM(J), 3551 & MMCORD(1,J),MMCORD(2,J),MMCORD(3,J), 3552 & MMCORD(1,I),MMCORD(2,I),MMCORD(3,I), 3553 & ELFLDX,ELFLDY,ELFLDZ) 3554 3555 EF0MX = EF0MX + ELFLDX 3556 EF0MY = EF0MY + ELFLDY 3557 EF0MZ = EF0MZ + ELFLDZ 3558 ENDIF 3559 3560C C.2 Dipole contribution 3561 3562 IF (NMULT .GE. 1) THEN 3563 3564 CALL GET_DIPOLE_ELFLD(MUL1MM(1,J),MUL1MM(2,J), 3565 & MUL1MM(3,J), 3566 & MMCORD(1,J),MMCORD(2,J),MMCORD(3,J), 3567 & MMCORD(1,I),MMCORD(2,I),MMCORD(3,I), 3568 & ELFLDX,ELFLDY,ELFLDZ) 3569 3570 EF1MX = EF1MX + ELFLDX 3571 EF1MY = EF1MY + ELFLDY 3572 EF1MZ = EF1MZ + ELFLDZ 3573 3574 ENDIF 3575 3576C C.3 Quadrupole contribution 3577 3578 IF (NMULT .GE. 2) THEN 3579 3580 CALL GET_QUADRUPOLE_ELFLD( 3581 & MUL2MM(1,J),MUL2MM(2,J),MUL2MM(3,J), 3582 & MUL2MM(4,J),MUL2MM(5,J),MUL2MM(6,J), 3583 & MMCORD(1,J),MMCORD(2,J),MMCORD(3,J), 3584 & MMCORD(1,I),MMCORD(2,I),MMCORD(3,I), 3585 & ELFLDX,ELFLDY,ELFLDZ) 3586 3587 EF2MX = EF2MX + ELFLDX 3588 EF2MY = EF2MY + ELFLDY 3589 EF2MZ = EF2MZ + ELFLDZ 3590 3591 ENDIF 3592 3593 ENDIF 3594 3595 520 CONTINUE 3596 3597C Point-charge contribution 3598 3599 IF (NMULT .GE. 0) THEN 3600 3601 EXCOMP = DINDMOM(1)*EF0MX 3602 EYCOMP = DINDMOM(2)*EF0MY 3603 EZCOMP = DINDMOM(3)*EF0MZ 3604 3605 ET = 0.0D0 3606 ET = ET + DMINV2*(EXCOMP + EYCOMP + EZCOMP) 3607 EDALL(3) = ET 3608 3609 ENDIF 3610 3611C Dipole contribution 3612 3613 IF (NMULT .GE. 1) THEN 3614 3615 EXCOMP = DINDMOM(1)*EF1MX 3616 EYCOMP = DINDMOM(2)*EF1MY 3617 EZCOMP = DINDMOM(3)*EF1MZ 3618 3619 ET = 0.0D0 3620 ET = ET + DMINV2*(EXCOMP + EYCOMP + EZCOMP) 3621 EDALL(4) = ET 3622 3623 ENDIF 3624 3625C Quadrupole contribution 3626 3627 IF (NMULT .GE. 2) THEN 3628 3629 EXCOMP = DINDMOM(1)*EF2MX 3630 EYCOMP = DINDMOM(2)*EF2MY 3631 EZCOMP = DINDMOM(3)*EF2MZ 3632 3633 ET = 0.0D0 3634 ET = ET + DMINV2*(EXCOMP + EYCOMP + EZCOMP) 3635 EDALL(5) = ET 3636 3637 ENDIF 3638 3639 CALL QEXIT('GET_POL_CONTR') 3640 3641 RETURN 3642 END 3643C****************************************************************************** 3644C /* Deck get_my */ 3645 SUBROUTINE GET_MY(I,J,DIP,MY) 3646 3647C Input: I,J,DIP 3648C Output: MY 3649C Get the polarizability tensor MY at site I due to polarizability 3650C tensor DIP at site J. 3651 IMPLICIT NONE 3652#include "mxcent.h" 3653#include "qmmm.h" 3654 3655 LOGICAL EXCENT 3656 INTEGER I, J, K, L, NLDIM, NTOTI 3657 DOUBLE PRECISION AMAT,TTENS,ATMAT,DIP,MY 3658 DOUBLE PRECISION TEMPJ, TEMP, SCREEN, TEMPI,DIST,DIST2,DIST3,DIST5 3659 DOUBLE PRECISION ELEM,FEIJ,FTIJ, D0, D1, D3I, D6I 3660 DIMENSION AMAT(3,3),TTENS(3,3),ATMAT(3,3),DIP(3),MY(3) 3661 PARAMETER ( D0 = 0.0D0, D1 = 1.0D0 ) 3662 PARAMETER (D3I = 1.0D0/3.0D0, D6I = 1.0D0/6.0D0) 3663 3664 CALL QENTER('GET_MY') 3665 3666 CALL DZERO(MY,3) 3667 IF (J .NE. I) THEN 3668 EXCENT = .FALSE. 3669 IF (NEWEXC) THEN 3670 DO L = 1, NEXLST 3671 IF (EXLIST(1,I) .EQ. EXLIST(L,J)) EXCENT = .TRUE. 3672 ENDDO 3673 ELSE 3674 DO L = 1, NEXLST 3675 IF (EXLIST(L,I) .EQ. EXLIST(1,J)) EXCENT = .TRUE. 3676 END DO 3677 ENDIF 3678 3679 IF (.NOT. EXCENT) THEN 3680C Get the polarizability tensor for this site 3681 DO K=1,3 3682 DO L=1,3 3683 AMAT(K,L) = 0.0D0 3684 ENDDO 3685 ENDDO 3686 3687 IF (IPOLTP .EQ. 1) THEN 3688 DO L=1,3 3689 AMAT(L,L) = POLIMM(I) 3690 ENDDO 3691 ELSE IF (IPOLTP .EQ. 2) THEN 3692 AMAT(1,1) = POLMM(1,I) 3693 AMAT(1,2) = POLMM(2,I) 3694 AMAT(1,3) = POLMM(3,I) 3695 AMAT(2,1) = POLMM(2,I) 3696 AMAT(2,2) = POLMM(4,I) 3697 AMAT(2,3) = POLMM(5,I) 3698 AMAT(3,1) = POLMM(3,I) 3699 AMAT(3,2) = POLMM(5,I) 3700 AMAT(3,3) = POLMM(6,I) 3701 ENDIF 3702 3703C Now calculate the T tensor for these sites 3704 DIST2 = 0.0D0 3705 DO K=1,3 3706 DIST2 = DIST2 + (MMCORD(K,I) - MMCORD(K,J))**2 3707 ENDDO 3708 DIST = SQRT(DIST2) 3709 DIST3 = DIST**3 3710 DIST5 = DIST**5 3711 3712 DO K=1,3 3713 DO L=1,3 3714 3715C Include damping in the exponential form 3716C JPC A 102 (1998) 2399 3717 IF (MMDAMP) THEN 3718 IF (IPOLTP .EQ. 1) THEN 3719 TEMPI = POLIMM(I) 3720 TEMPJ = POLIMM(J) 3721 ELSE IF (IPOLTP .EQ. 2) THEN 3722 TEMPI = D3I*(POLMM(1,I)+POLMM(4,I)+POLMM(6,I)) 3723 TEMPJ = D3I*(POLMM(1,J)+POLMM(4,J)+POLMM(6,J)) 3724 ENDIF 3725 TEMP = (TEMPI*TEMPJ)**(D6I) 3726 SCREEN = 2.1304*DIST/TEMP 3727 FEIJ = 1.0D0-(1.0D0+SCREEN+0.5D0*SCREEN**2) 3728 & *EXP(-SCREEN) 3729 FTIJ = FEIJ - (1.0D0/6.0D0*SCREEN**3) 3730 & *EXP(-SCREEN) 3731 ELSE 3732 FEIJ = D1 3733 FTIJ = D1 3734 ENDIF 3735 3736 ELEM = FTIJ*3*(MMCORD(K,I) - MMCORD(K,J))* 3737 & (MMCORD(L,I) - MMCORD(L,J)) 3738 ELEM = ELEM/DIST5 3739 IF (K .EQ. L) ELEM = ELEM - (FEIJ*1.0/DIST3) 3740 TTENS(K,L) = ELEM 3741 ENDDO 3742 ENDDO 3743 3744C calculate alpha*T 3745 CALL DGEMM('N','N',3,3,3,1.D0,AMAT,3, 3746 & TTENS,3,0.D0,ATMAT,3) 3747 3748 NLDIM = 3 3749 NTOTI = MAX(NLDIM,1) 3750 CALL DGEMV('N',NLDIM,NLDIM,D1,ATMAT,NTOTI,DIP,1,D0,MY,1) 3751 ENDIF 3752 ENDIF 3753 3754 CALL QEXIT('GET_MY') 3755 3756 RETURN 3757 END 3758C****************************************************************************** 3759C /* Deck qmmmtimes */ 3760 SUBROUTINE QMMMTIMES(WORD) 3761 3762 IMPLICIT NONE 3763 3764#include "priunit.h" 3765#include "mxcent.h" 3766#include "qmmm.h" 3767#include "mmtimes.h" 3768 CHARACTER*(*) WORD 3769 DOUBLE PRECISION ZERO 3770 PARAMETER(ZERO = 0.0D0) 3771 CALL QENTER('QMMMTIMES') 3772 3773 IF (.NOT. MMTIME) THEN 3774 CALL QEXIT('QMMMTIMES') 3775 RETURN 3776 ENDIF 3777 3778 WRITE(LUPRI,*) ' - QM/MM times:' 3779 IF (WORD .EQ. 'SIRIUS') THEN 3780 WRITE(LUPRI,1) 'QMMMFCK ',TMMFCK 3781 WRITE(LUPRI,1) 'QMMM MULPOLES',TMMMULPOL 3782 WRITE(LUPRI,1) 'QMMM_POLARI ',TMMPOL 3783 IF (MMITER) THEN 3784 WRITE(LUPRI,*) ' - MMITER times:' 3785 WRITE(LUPRI,2) 'GET_IND_DIPOLES_2',TMMGID2 3786 WRITE(LUPRI,2) 'GET_FIELD ',TMMPOL2 3787 WRITE(LUPRI,2) 'F2QMMM ',TF2QMMM 3788 WRITE(LUPRI,2) 'the iteration ',TMMITER 3789 TMMGID2 = ZERO 3790 TMMPOL2 = ZERO 3791 TF2QMMM = ZERO 3792 TMMITER = ZERO 3793 ENDIF 3794 ELSEIF (WORD .EQ. 'RESPONSE') THEN 3795 WRITE(LUPRI,1) 'QMMMRSP',TMMRSP 3796 WRITE(LUPRI,2) 'QMMMLNO ',TMMLNO 3797 WRITE(LUPRI,3) 'QMMMLNO0 ',TMMLNO0 3798 WRITE(LUPRI,3) 'QMMMLNO1 ',TMMLNO1 3799 WRITE(LUPRI,3) 'QMMMLNO2 ',TMMLNO2 3800 WRITE(LUPRI,3) 'QMMMLNO3 ',TMMLNO3 3801 WRITE(LUPRI,3) 'QMMMLNO4 ',TMMLNO4 3802 WRITE(LUPRI,2) 'QMMMQRO ',TMMQRO 3803 WRITE(LUPRI,3) 'QMMMQRO0 ',TMMQRO0 3804 WRITE(LUPRI,3) 'QMMMQRO1 ',TMMQRO1 3805 WRITE(LUPRI,3) 'QMMMQRO2 ',TMMQRO2 3806 WRITE(LUPRI,3) 'QMMMQRO3 ',TMMQRO3 3807 WRITE(LUPRI,3) 'QMMMQRO4 ',TMMQRO4 3808 WRITE(LUPRI,2) 'QMMMCRO ',TMMCRO 3809 IF (MMITER) THEN 3810 WRITE(LUPRI,2) 'F2QMMM ',TF2QMMM 3811 WRITE(LUPRI,2) 'the iteration',TMMITER 3812 ENDIF 3813 ELSEIF (WORD .EQ. 'ABACUS') THEN 3814 WRITE(LUPRI,1) 'QMMMFIRST',TMMFIRST 3815 WRITE(LUPRI,1) 'QMMMB2 ',TMMB2 3816 ENDIF 3817 3818 1 FORMAT( ' - total time used in ',A,': ',F10.2,' seconds') 3819 2 FORMAT( ' - total time used in ',A,': ',F10.2,' seconds') 3820 3 FORMAT( ' - total time used in ',A,': ',F10.2,' seconds') 3821 3822 CALL QEXIT('QMMMTIMES') 3823 3824 RETURN 3825 END 3826C 3827#if defined(VAR_MPI) 3828C***************************************************** 3829C Parallel routines for QM/MM SIRIUS 3830C Arnfinn, Odense/Tromso Oct. 2009 - Oct. 2010 3831C As little as possible of calculations are done here; 3832C Mostly calling routines shared by the serial code. 3833C***************************************************** 3834C /* Deck parqmmm_m */ 3835 SUBROUTINE PARQMMM_M(DCAO,TAO,ESOLT,LOCDEB,WRK,LWRK, 3836 & IPRINT) 3837 3838#include "implicit.h" 3839! mxcoor in nuclei.h 3840#include "mxcent.h" 3841! nnbasx, icmo, nbast, 3842#include "inforb.h" 3843! nctot, cord, charge, nucind, nucdep 3844#include "nuclei.h" 3845! luprop 3846#include "inftap.h" 3847! npatom, ipatom 3848#include "cbiher.h" 3849! qmcom, isytp, qmdamp 3850#include "qm3.h" 3851! mmcent, mul0mm, mul1mm etc, rcutmm, delfld, nmult, nexlst, exlist 3852! nnzal (updates), spldip, zeroal (updates?), idamp, ipoltp, 3853! From potfile: mmcent, nmult, ipoltp, nexlst, neleme 3854! exlist 3855#include "qmmm.h" 3856C ---- 3857#include "maxorb.h" 3858! MXSHEL 3859#include "infpar.h" 3860#include "mtags.h" 3861#if defined(VAR_MPI) 3862#include "mpif.h" 3863#endif 3864C#include "cbiher.h" 3865C defined parallel calculation types 3866#include "iprtyp.h" 3867 3868 DIMENSION WRK(LWRK), TAO(NNBASX), DCAO(NNBASX) 3869 LOGICAL LOCDEB 3870 3871 CALL QENTER('PARQMMM_M') 3872 3873 KNSNUC = 1 3874 KNSNUC2 = KNSNUC + MMCENT 3875 KNSEL = KNSNUC2 + MMCENT 3876 KNSEL2 = KNSEL + MMCENT 3877 KTAO = KNSEL2 + MMCENT 3878 KTAO2 = KTAO + NNBASX 3879 KLAST = KTAO2 + NNBASX 3880 LWRK2 = LWRK - KLAST + 1 3881 3882 IF (LWRK2 .LT. 0) CALL ERRWRK('PARQMMM_M',-KLAST,LWRK) 3883 3884 CALL DZERO(WRK(KNSNUC),MMCENT) 3885 CALL DZERO(WRK(KNSNUC2),MMCENT) 3886 CALL DZERO(WRK(KNSEL),MMCENT) 3887 CALL DZERO(WRK(KNSEL2),MMCENT) 3888 CALL DZERO(WRK(KTAO),NNBASX) 3889 CALL DZERO(WRK(KTAO2),NNBASX) 3890 ECHTMP = 0.0D0 3891 EDITMP = 0.0D0 3892 EQUTMP = 0.0D0 3893 3894C Wake up slaves (Rock and roll all nite) 3895 3896 IPRTYP = PARQMMM__WORK 3897 CALL MPIXBCAST(IPRTYP,1,'INTEGER',MASTER) 3898 CALL MPIXBCAST(IPQMMM,1,'INTEGER',MASTER) 3899 3900C Send data to slaves (Lick it up) 3901 3902 CALL MPIXBCAST(MMCENT,1,'INTEGER',MASTER) 3903 3904 CALL MPIXBCAST(NMULT,1,'INTEGER',MASTER) 3905 IF (NMULT .GE. 0) CALL MPIXBCAST(MUL0MM,MMCENT,'DOUBLE',MASTER) 3906 IF (NMULT .GE. 1) CALL MPIXBCAST(MUL1MM,3*MMCENT,'DOUBLE',MASTER) 3907 IF (NMULT .GE. 2) CALL MPIXBCAST(MUL2MM,6*MMCENT,'DOUBLE',MASTER) 3908 3909 CALL MPIXBCAST(MMCORD,3*MMCENT,'DOUBLE',MASTER) 3910 CALL MPIXBCAST(QMCOM,3,'DOUBLE',MASTER) 3911 CALL MPIXBCAST(RCUTMM,1,'DOUBLE',MASTER) 3912 CALL MPIXBCAST(ICMO,8,'INTEGER',MASTER) 3913 3914 CALL MPIXBCAST(NBAST,1,'INTEGER',MASTER) 3915 CALL MPIXBCAST(ISYTP,1,'INTEGER',MASTER) 3916 CALL MPIXBCAST(NCTOT,1,'INTEGER',MASTER) 3917 3918 CALL MPIXBCAST(DCAO,NNBASX,'DOUBLE',MASTER) 3919 3920 CALL MPIXBCAST(NUCIND,1,'INTEGER',MASTER) 3921 CALL MPIXBCAST(NUCDEP,1,'INTEGER',MASTER) 3922 3923 CALL MPIXBCAST(MMITER,1,'LOGICAL',MASTER) 3924 CALL MPIXBCAST(MMPROP,1,'LOGICAL',MASTER) 3925 CALL MPIXBCAST(MMDIIS,1,'LOGICAL',MASTER) 3926 CALL MPIXBCAST(LOCDEB,1,'LOGICAL',MASTER) 3927 CALL MPIXBCAST(MMDAMP,1,'LOGICAL',MASTER) 3928 3929C The loop (Shock me) 3930 LNUM = 0 3931 DO L = 1,MMCENT 3932 LNUM = LNUM + 1 3933 IWHO = -1 3934 CALL MPIXRECV(NWHO,1,'INTEGER',IWHO,MPTAG1) 3935 CALL MPIXSEND(LNUM,1,'INTEGER',NWHO,MPTAG2) 3936 END DO 3937 3938C Send end message to all slaves (Rock bottom) 3939 LEND = -1 3940 DO ISLAVE = 1,NODTOT 3941 IWHO = -1 3942 CALL MPIXRECV(NWHO,1,'INTEGER',IWHO,MPTAG1) 3943 CALL MPIXSEND(LEND,1,'INTEGER',NWHO,MPTAG2) 3944 END DO 3945 3946C Collect data from all slaves (Great expectations) 3947 3948 CALL MPI_REDUCE(WRK(KNSNUC2),WRK(KNSNUC),MMCENT, 3949 & MPI_DOUBLE_PRECISION,MPI_SUM,0,MPI_COMM_WORLD, 3950 & IERR) 3951 CALL MPI_REDUCE(WRK(KNSEL2),WRK(KNSEL),MMCENT, 3952 & MPI_DOUBLE_PRECISION,MPI_SUM,0,MPI_COMM_WORLD, 3953 & IERR) 3954 CALL MPI_REDUCE(WRK(KTAO2),WRK(KTAO),NNBASX, 3955 & MPI_DOUBLE_PRECISION,MPI_SUM,0,MPI_COMM_WORLD, 3956 & IERR) 3957 3958 IF (NMULT .GE. 0) CALL MPI_REDUCE(ECHTMP,ECHART,1, 3959 & MPI_DOUBLE_PRECISION,MPI_SUM,0,MPI_COMM_WORLD, 3960 & IERR) 3961 IF (NMULT .GE. 1) CALL MPI_REDUCE(EDITMP,EDIPT,1, 3962 & MPI_DOUBLE_PRECISION,MPI_SUM,0,MPI_COMM_WORLD, 3963 & IERR) 3964 IF (NMULT .GE. 2) CALL MPI_REDUCE(EQUTMP,EQUADT,1, 3965 & MPI_DOUBLE_PRECISION,MPI_SUM,0,MPI_COMM_WORLD, 3966 & IERR) 3967 3968 CALL DAXPY(NNBASX,1.0D0,WRK(KTAO),1,TAO(1),1) 3969 3970 ECHCH = 0.0D0 3971 EXPNST = 0.0D0 3972 3973 DO I = 1, MMCENT 3974 ECHCH = ECHCH + WRK(KNSNUC + I - 1) 3975 EXPNST = EXPNST + WRK(KNSEL + I - 1) 3976 END DO 3977 3978 ENUMUL = ECHCH 3979 ESOLT = ECHART + EDIPT + EQUADT 3980 3981 CALL QEXIT('PARQMMM_M') 3982 3983 RETURN 3984 END 3985C****************************************************************************** 3986C /* Deck parqmmm_s */ 3987 SUBROUTINE PARQMMM_S(WRK,LWRK,IPRTMP) 3988 3989#include "implicit.h" 3990! mxcoor in nuclei.h 3991#include "mxcent.h" 3992! nnbasx, icmo, nbast, 3993#include "inforb.h" 3994! nctot, cord, charge, nucind, nucdep 3995#include "nuclei.h" 3996! luprop 3997#include "inftap.h" 3998! npatom, ipatom 3999#include "cbiher.h" 4000! qmcom, isytp, qmdamp 4001#include "qm3.h" 4002! mmcent, mul0mm, mul1mm etc, rcutmm, delfld, nmult, nexlst, exlist 4003! nnzal (updates), spldip, zeroal (updates?), idamp, ipoltp, 4004! From potfile: mmcent, nmult, ipoltp, nexlst, neleme 4005! exlist 4006#include "qmmm.h" 4007#include "maxorb.h" 4008! MXSHEL 4009#include "infpar.h" 4010#include "mtags.h" 4011#if defined(VAR_MPI) 4012#include "mpif.h" 4013#endif 4014! qmmm 4015#include "gnrinf.h" 4016! diporg 4017#include "orgcom.h" 4018#include "priunit.h" 4019 4020 DIMENSION WRK(LWRK) 4021 LOGICAL LOCDEB 4022 4023 CALL QENTER('PARQMMM_S') 4024 4025 QMMM = .TRUE. 4026 4027C Receiving data from master (I was made for lovin' you) 4028 CALL MPIXBCAST(MMCENT,1,'INTEGER',MASTER) 4029 4030 CALL MPIXBCAST(NMULT,1,'INTEGER',MASTER) 4031 IF (NMULT .GE. 0) CALL MPIXBCAST(MUL0MM,MMCENT,'DOUBLE',MASTER) 4032 IF (NMULT .GE. 1) CALL MPIXBCAST(MUL1MM,3*MMCENT,'DOUBLE',MASTER) 4033 IF (NMULT .GE. 2) CALL MPIXBCAST(MUL2MM,6*MMCENT,'DOUBLE',MASTER) 4034 4035 KNSNUC = 1 4036 KNSEL = KNSNUC + MMCENT 4037 KTAO = KNSEL + MMCENT 4038 KDCAO = KTAO + NNBASX 4039 KLAST = KDCAO + NNBASX 4040 LWRK2 = LWRK - KLAST + 1 4041 4042 IF (LWRK2 .LT. 0) CALL ERRWRK('PARQMMM_S',-KLAST,LWRK) 4043 4044 OBKPX = DIPORG(1) 4045 OBKPY = DIPORG(2) 4046 OBKPZ = DIPORG(3) 4047 4048 CALL MPIXBCAST(MMCORD,3*MMCENT,'DOUBLE',MASTER) 4049 CALL MPIXBCAST(QMCOM,3,'DOUBLE',MASTER) 4050 CALL MPIXBCAST(RCUTMM,1,'DOUBLE',MASTER) 4051 CALL MPIXBCAST(ICMO,8,'INTEGER',MASTER) 4052 4053 CALL MPIXBCAST(NBAST,1,'INTEGER',MASTER) 4054 CALL MPIXBCAST(ISYTP,1,'INTEGER',MASTER) 4055 CALL MPIXBCAST(NCTOT,1,'INTEGER',MASTER) 4056 4057 CALL MPIXBCAST(WRK(KDCAO),NNBASX,'DOUBLE',MASTER) 4058 4059 CALL MPIXBCAST(NUCIND,1,'INTEGER',MASTER) 4060 CALL MPIXBCAST(NUCDEP,1,'INTEGER',MASTER) 4061 4062 CALL MPIXBCAST(MMITER,1,'LOGICAL',MASTER) 4063 CALL MPIXBCAST(MMPROP,1,'LOGICAL',MASTER) 4064 CALL MPIXBCAST(MMDIIS,1,'LOGICAL',MASTER) 4065 CALL MPIXBCAST(LOCDEB,1,'LOGICAL',MASTER) 4066 CALL MPIXBCAST(MMDAMP,1,'LOGICAL',MASTER) 4067 4068C Do the work (I love it load) 4069 4070 CALL DZERO(WRK(KNSEL),MMCENT) 4071 CALL DZERO(WRK(KNSNUC),MMCENT) 4072 CALL DZERO(WRK(KTAO),NNBASX) 4073 4074 ECHART = 0.0D0 4075 EDIPT = 0.0D0 4076 EQUADT = 0.0D0 4077 4078 1 CONTINUE 4079 4080 CALL MPIXSEND(MYNUM,1,'INTEGER',MASTER,MPTAG1) 4081 CALL MPIXRECV(I,1,'INTEGER',MASTER,MPTAG2) 4082 4083 IF (I.GT.0) THEN 4084 4085 DIST2 = (MMCORD(1,I)-QMCOM(1))**2 + 4086 * (MMCORD(2,I)-QMCOM(2))**2 + 4087 * (MMCORD(3,I)-QMCOM(3))**2 4088 DIST = SQRT(DIST2) 4089 4090 IF (DIST .GT. RCUTMM) THEN 4091 GOTO 1 4092 ENDIF 4093 4094C------------------------------------------------- 4095C Charge contributions: 4096C------------------------------------------------- 4097 CALL CHARGE_ITER(I,WRK(KDCAO),ENSEL,ENSNUC,LOCDEB, 4098 * WRK(KTAO),WRK(KLAST),LWRK2,IPRTMP) 4099 WRK(KNSEL+I-1) = WRK(KNSEL+I-1) + ENSEL 4100 WRK(KNSNUC+I-1) = WRK(KNSNUC+I-1) + ENSNUC 4101 ECHART = ECHART + ENSEL + ENSNUC 4102 IF (NMULT .LT. 1) GOTO 1 4103 4104C------------------------------------------------- 4105C Dipole contributions: 4106C------------------------------------------------- 4107 CALL DIPOLE_ITER(I,WRK(KDCAO),ENSEL,ENSNUC,LOCDEB, 4108 * WRK(KTAO),WRK(KLAST),LWRK2,IPRTMP) 4109 WRK(KNSEL+I-1) = WRK(KNSEL+I-1) + ENSEL 4110 WRK(KNSNUC+I-1) = WRK(KNSNUC+I-1) + ENSNUC 4111 EDIPT = EDIPT + ENSEL + ENSNUC 4112 IF (NMULT .LT. 2) GOTO 1 4113 4114C------------------------------------------------- 4115C Quadrupole contributions: 4116C------------------------------------------------- 4117 CALL QUADPOLE_ITER(I,WRK(KDCAO),ENSEL,ENSNUC,LOCDEB, 4118 * WRK(KTAO),WRK(KLAST),LWRK2,IPRTMP) 4119 WRK(KNSEL+I-1) = WRK(KNSEL+I-1) + ENSEL 4120 WRK(KNSNUC+I-1) = WRK(KNSNUC+I-1) + ENSNUC 4121 EQUADT = EQUADT + ENSEL + ENSNUC 4122 GOTO 1 4123 ENDIF 4124 4125C Send data to master (Do you love me?) 4126 CALL MPI_REDUCE(WRK(KNSNUC),MPI_IN_PLACE,MMCENT, 4127 & MPI_DOUBLE_PRECISION,MPI_SUM,0,MPI_COMM_WORLD, 4128 & IERR) 4129 CALL MPI_REDUCE(WRK(KNSEL),MPI_IN_PLACE,MMCENT, 4130 & MPI_DOUBLE_PRECISION,MPI_SUM,0,MPI_COMM_WORLD, 4131 & IERR) 4132 CALL MPI_REDUCE(WRK(KTAO),MPI_IN_PLACE,NNBASX, 4133 & MPI_DOUBLE_PRECISION,MPI_SUM,0,MPI_COMM_WORLD, 4134 & IERR) 4135 4136 IF (NMULT .GE. 0) CALL MPI_REDUCE(ECHART,MPI_IN_PLACE,1, 4137 & MPI_DOUBLE_PRECISION,MPI_SUM,0,MPI_COMM_WORLD, 4138 & IERR) 4139 IF (NMULT .GE. 1) CALL MPI_REDUCE(EDIPT,MPI_IN_PLACE,1, 4140 & MPI_DOUBLE_PRECISION,MPI_SUM,0,MPI_COMM_WORLD, 4141 & IERR) 4142 IF (NMULT .GE. 2) CALL MPI_REDUCE(EQUADT,MPI_IN_PLACE,1, 4143 & MPI_DOUBLE_PRECISION,MPI_SUM,0,MPI_COMM_WORLD, 4144 & IERR) 4145 4146 DIPORG(1) = OBKPX 4147 DIPORG(2) = OBKPY 4148 DIPORG(3) = OBKPZ 4149 4150 CALL QEXIT('PARQMMM_S') 4151 RETURN 4152 END 4153C****************************************************************************** 4154C /* Deck mm_field_m1 */ 4155 SUBROUTINE MM_FIELD_M1(DCAO,ELF,POLDIM,WRK,LWRK,IPRINT) 4156 4157#include "implicit.h" 4158#include "priunit.h" 4159#include "dummy.h" 4160#include "mxcent.h" 4161#include "iratdef.h" 4162#include "maxash.h" 4163#include "maxorb.h" 4164 4165#include "qmmm.h" 4166#include "qm3.h" 4167#include "inforb.h" 4168#include "inftap.h" 4169#include "infpri.h" 4170#include "scbrhf.h" 4171#include "maxaqn.h" 4172#include "symmet.h" 4173#include "orgcom.h" 4174#include "infinp.h" 4175#include "nuclei.h" 4176#include "codata.h" 4177C ---- 4178#include "infpar.h" 4179#include "mtags.h" 4180#if defined(VAR_MPI) 4181#include "mpif.h" 4182#endif 4183#include "cbiher.h" 4184#include "gnrinf.h" 4185C defined parallel calculation types 4186#include "iprtyp.h" 4187 4188 INTEGER POLDIM 4189 DIMENSION WRK(LWRK), ELF(*) 4190 4191 CALL QENTER('MM_FIELD_M1') 4192 4193 KELF = 1 4194 KEND = KELF + 3*POLDIM 4195 IF (SPLDIP) THEN 4196 KELFEL = KEND 4197 KELFNU = KELFEL + 3*POLDIM 4198 KEND = KELFNU + 3*POLDIM 4199 ENDIF 4200 LWRK1 = LWRK - KEND 4201 IF (LWRK1 .LT. 0) CALL ERRWRK('MM_FIELD_M1',-KEND,LWRK) 4202 4203C Beginning of parallel section 4204 4205 IPRTYP = MM_FIELD_1_WORK 4206 4207C Wake up slaves 4208 4209 CALL MPIXBCAST(IPRTYP,1,'INTEGER',MASTER) 4210 CALL MPIXBCAST(IPQMMM,1,'INTEGER',MASTER) 4211 4212C Send data to slaves 4213 4214 CALL MPIXBCAST(NNZAL,1,'INTEGER',MASTER) 4215 CALL MPIXBCAST(POLDIM,1,'INTEGER',MASTER) 4216 CALL MPIXBCAST(SPLDIP,1,'LOGICAL',MASTER) 4217 CALL MPIXBCAST(CONMAT,1,'LOGICAL',MASTER) 4218 4219 CALL MPIXBCAST(NMULT,1,'INTEGER',MASTER) 4220 4221 CALL MPIXBCAST(NEXLST,1,'INTEGER',MASTER) 4222 DO N=1, NEXLST 4223 CALL MPIXBCAST(EXLIST(N,1:MMCENT),MMCENT,'INTEGER',MASTER) 4224 ENDDO 4225C CALL MPIXBCAST(EXLIST,NEXLST*MMCENT,'INTEGER',MASTER) 4226 4227C Damping 4228 CALL MPIXBCAST(QMDAMP,1,'LOGICAL',MASTER) 4229 IF (QMDAMP) THEN 4230 CALL MPIXBCAST(IDAMP,1,'INTEGER',MASTER) 4231 CALL MPIXBCAST(IPOLTP,1,'INTEGER',MASTER) 4232 CALL MPIXBCAST(NQMNUC,1,'INTEGER',MASTER) 4233 CALL MPIXBCAST(QMPOL,MXCENT,'DOUBLE',MASTER) 4234 CALL MPIXBCAST(ADAMP,1,'DOUBLE',MASTER) 4235 CALL MPIXBCAST(POLMM,6*MMCENT,'DOUBLE',MASTER) 4236 ENDIF 4237 4238C CALL MPIXBCAST(RCUTMM,1,'DOUBLE',MASTER) 4239 CALL MPIXBCAST(DELFLD,1,'DOUBLE',MASTER) 4240 CALL MPIXBCAST(DCAO,NNBASX,'DOUBLE',MASTER) 4241 CALL MPIXBCAST(ZEROAL,MMCENT,'INTEGER',MASTER) 4242 4243C Start parallelized loop 4244 LRI = 1 4245 DO 100 L = 1,MMCENT 4246 IWHO = -1 4247 IF (ZEROAL(L) .EQ. -1) GOTO 100 4248 CALL MPIXRECV(NWHO,1,'INTEGER',IWHO,MPTAG1) 4249 CALL MPIXSEND(L,1,'INTEGER',NWHO,MPTAG2) 4250 CALL MPIXSEND(LRI,1,'INTEGER',NWHO,MPTAG2) 4251 LRI = LRI + 3 4252 100 CONTINUE 4253 4254C Send end message to all slaves 4255 4256 LEND = -1 4257 DO ISLAVE = 1,NODTOT 4258 IWHO = -1 4259 CALL MPIXRECV(NWHO,1,'INTEGER',IWHO,MPTAG1) 4260 CALL MPIXSEND(LEND,1,'INTEGER',NWHO,MPTAG2) 4261 CALL MPIXSEND(LRI,1,'INTEGER',NWHO,MPTAG2) 4262 END DO 4263 4264C Collect data from all slaves 4265 4266 CALL DZERO(WRK(KELF),3*POLDIM) 4267 CALL MPI_REDUCE(WRK(KELF),ELF,3*POLDIM, 4268 & MPI_DOUBLE_PRECISION,MPI_SUM,0,MPI_COMM_WORLD, 4269 & IERR) 4270 4271 IF (SPLDIP) THEN 4272 CALL DZERO(WRK(KELFEL),3*POLDIM) 4273 CALL MPI_REDUCE(WRK(KELFEL),ELF(3*POLDIM+1),3*POLDIM, 4274 & MPI_DOUBLE_PRECISION,MPI_SUM,0,MPI_COMM_WORLD, 4275 & IERR) 4276 4277 CALL DZERO(WRK(KELFNU),3*POLDIM) 4278 CALL MPI_REDUCE(WRK(KELFNU),ELF(6*POLDIM+1),3*POLDIM, 4279 & MPI_DOUBLE_PRECISION,MPI_SUM,0,MPI_COMM_WORLD, 4280 & IERR) 4281 ENDIF 4282 4283 CALL QEXIT('MM_FIELD_M1') 4284 4285 RETURN 4286 END 4287C****************************************************************************** 4288C /* Deck mm_field_s1 */ 4289 SUBROUTINE MM_FIELD_S1(WRK,LWRK,IPRTMP) 4290 4291#include "implicit.h" 4292#include "priunit.h" 4293#include "dummy.h" 4294#include "mxcent.h" 4295#include "iratdef.h" 4296#include "maxash.h" 4297#include "maxorb.h" 4298 4299#include "qmmm.h" 4300#include "qm3.h" 4301#include "inforb.h" 4302#include "inftap.h" 4303#include "infpri.h" 4304#include "scbrhf.h" 4305#include "maxaqn.h" 4306#include "symmet.h" 4307#include "orgcom.h" 4308#include "infinp.h" 4309#include "nuclei.h" 4310#include "codata.h" 4311C ---- 4312#include "infpar.h" 4313#include "mtags.h" 4314#if defined(VAR_MPI) 4315#include "mpif.h" 4316#endif 4317#include "cbiher.h" 4318#include "gnrinf.h" 4319 4320 DIMENSION WRK(LWRK) 4321 INTEGER POLDIM 4322 4323 CALL QENTER('MM_FIELD_S1') 4324 4325 QMMM = .TRUE. 4326 IPQMMM = IPRTMP 4327 4328C Receiving data from master 4329 4330 CALL MPIXBCAST(NNZAL,1,'INTEGER',MASTER) 4331 CALL MPIXBCAST(POLDIM,1,'INTEGER',MASTER) 4332 CALL MPIXBCAST(SPLDIP,1,'LOGICAL',MASTER) 4333 CALL MPIXBCAST(CONMAT,1,'LOGICAL',MASTER) 4334 4335 KELF = 1 4336 IF (SPLDIP) THEN 4337 KELFEL = KELF + 3*POLDIM 4338 KELFNU = KELFEL + 3*POLDIM 4339 KDCAO = KELFNU + 3*POLDIM 4340 ELSE 4341 KDCAO = KELF + 3*POLDIM 4342 ENDIF 4343 KMAT = KDCAO + NNBASX 4344 KLAST = KMAT + 3*NNBASX 4345 LWRK2 = LWRK - KLAST + 1 4346 4347 IF (LWRK2 .LT. 0) CALL ERRWRK('MM_FIELD_S1',-KLAST,LWRK) 4348 4349 OBKPX = DIPORG(1) 4350 OBKPY = DIPORG(2) 4351 OBKPZ = DIPORG(3) 4352C 4353 CALL MPIXBCAST(NMULT,1,'INTEGER',MASTER) 4354 4355 CALL MPIXBCAST(NEXLST,1,'INTEGER',MASTER) 4356 DO N=1, NEXLST 4357 CALL MPIXBCAST(EXLIST(N,1:MMCENT),MMCENT,'INTEGER',MASTER) 4358 ENDDO 4359C Damping 4360 CALL MPIXBCAST(QMDAMP,1,'LOGICAL',MASTER) 4361 IF (QMDAMP) THEN 4362 CALL MPIXBCAST(IDAMP,1,'INTEGER',MASTER) 4363 CALL MPIXBCAST(IPOLTP,1,'INTEGER',MASTER) 4364 CALL MPIXBCAST(NQMNUC,1,'INTEGER',MASTER) 4365 CALL MPIXBCAST(QMPOL,MXCENT,'DOUBLE',MASTER) 4366 CALL MPIXBCAST(ADAMP,1,'DOUBLE',MASTER) 4367 CALL MPIXBCAST(POLMM,6*MMCENT,'DOUBLE',MASTER) 4368 ENDIF 4369 4370 CALL MPIXBCAST(DELFLD,1,'DOUBLE',MASTER) 4371 CALL MPIXBCAST(WRK(KDCAO),NNBASX,'DOUBLE',MASTER) 4372 CALL MPIXBCAST(ZEROAL,MMCENT,'INTEGER',MASTER) 4373 4374C Do the work 4375 4376 CALL DZERO(WRK(KELF),3*POLDIM) 4377 IF (SPLDIP) THEN 4378 CALL DZERO(WRK(KELFEL),3*POLDIM) 4379 CALL DZERO(WRK(KELFNU),3*POLDIM) 4380 ENDIF 4381 4382 200 CONTINUE 4383 4384 CALL MPIXSEND(MYNUM,1,'INTEGER',MASTER,MPTAG1) 4385 CALL MPIXRECV(I,1,'INTEGER',MASTER,MPTAG2) 4386 CALL MPIXRECV(LRI,1,'INTEGER',MASTER,MPTAG2) 4387 4388 IF (I.GT.0) THEN 4389 CALL GET_FIELD(I,LRI,WRK(KELF),WRK(KELFEL),WRK(KELFNU), 4390 & WRK(KDCAO),.FALSE.,WRK(KLAST),LWRK2) 4391 GO TO 200 4392 ENDIF 4393 4394 CALL MPI_REDUCE(WRK(KELF),MPI_IN_PLACE,3*POLDIM, 4395 & MPI_DOUBLE_PRECISION,MPI_SUM,0,MPI_COMM_WORLD, 4396 & IERR) 4397 4398 IF (SPLDIP) THEN 4399 CALL MPI_REDUCE(WRK(KELFEL),MPI_IN_PLACE,3*POLDIM, 4400 & MPI_DOUBLE_PRECISION,MPI_SUM,0,MPI_COMM_WORLD, 4401 & IERR) 4402 CALL MPI_REDUCE(WRK(KELFNU),MPI_IN_PLACE,3*POLDIM, 4403 & MPI_DOUBLE_PRECISION,MPI_SUM,0,MPI_COMM_WORLD, 4404 & IERR) 4405 ENDIF 4406 4407 DIPORG(1) = OBKPX 4408 DIPORG(2) = OBKPY 4409 DIPORG(3) = OBKPZ 4410 4411 CALL QEXIT('MM_FIELD_S1') 4412 4413 RETURN 4414 END 4415C 4416C****************************************************************************** 4417C /* Deck mm_field_m2 */ 4418 SUBROUTINE MM_FIELD_M2(DCAO,ELF,POLDIM,WRK,LWRK,IPRINT) 4419 4420#include "implicit.h" 4421#include "priunit.h" 4422#include "dummy.h" 4423#include "mxcent.h" 4424#include "iratdef.h" 4425#include "maxash.h" 4426#include "maxorb.h" 4427 4428#include "qmmm.h" 4429#include "qm3.h" 4430#include "inforb.h" 4431#include "inftap.h" 4432#include "infpri.h" 4433#include "scbrhf.h" 4434#include "maxaqn.h" 4435#include "symmet.h" 4436#include "orgcom.h" 4437#include "infinp.h" 4438#include "nuclei.h" 4439#include "codata.h" 4440C ---- 4441#include "infpar.h" 4442#include "mtags.h" 4443#if defined(VAR_MPI) 4444#include "mpif.h" 4445#endif 4446#include "cbiher.h" 4447#include "gnrinf.h" 4448C defined parallel calculation types 4449#include "iprtyp.h" 4450 4451 INTEGER POLDIM 4452 DIMENSION WRK(LWRK), ELF(*) 4453 4454 CALL QENTER('MM_FIELD_M2') 4455 4456 KELF = 1 4457 KEND = KELF + 3*POLDIM 4458 LWRK1 = LWRK - KEND 4459 IF (LWRK1 .LT. 0) CALL ERRWRK('MM_FIELD_M2',-KEND,LWRK) 4460 4461C Beginning of parallel section 4462 4463 IPRTYP = MM_FIELD_2_WORK 4464 4465C Wake up slaves 4466 4467 CALL MPIXBCAST(IPRTYP,1,'INTEGER',MASTER) 4468 CALL MPIXBCAST(IPQMMM,1,'INTEGER',MASTER) 4469 4470C Send data to slaves 4471 4472 CALL MPIXBCAST(NNZAL,1,'INTEGER',MASTER) 4473 CALL MPIXBCAST(POLDIM,1,'INTEGER',MASTER) 4474 CALL MPIXBCAST(NMULT,1,'INTEGER',MASTER) 4475 4476 CALL MPIXBCAST(NEXLST,1,'INTEGER',MASTER) 4477 DO N=1, NEXLST 4478 CALL MPIXBCAST(EXLIST(N,1:MMCENT),MMCENT,'INTEGER',MASTER) 4479 ENDDO 4480 4481C Damping 4482 CALL MPIXBCAST(QMDAMP,1,'LOGICAL',MASTER) 4483 IF (QMDAMP) THEN 4484 CALL MPIXBCAST(IDAMP,1,'INTEGER',MASTER) 4485 CALL MPIXBCAST(IPOLTP,1,'INTEGER',MASTER) 4486 CALL MPIXBCAST(NQMNUC,1,'INTEGER',MASTER) 4487 CALL MPIXBCAST(QMPOL,MXCENT,'DOUBLE',MASTER) 4488 CALL MPIXBCAST(ADAMP,1,'DOUBLE',MASTER) 4489 CALL MPIXBCAST(POLMM,6*MMCENT,'DOUBLE',MASTER) 4490 ENDIF 4491C <- 4492 4493 CALL MPIXBCAST(DELFLD,1,'DOUBLE',MASTER) 4494 CALL MPIXBCAST(DCAO,NNBASX,'DOUBLE',MASTER) 4495 4496 LRI = 1 ! important should be one due to the indexing used ! 4497 4498C Start parallelized loop 4499 DO 100 L = 1,MMCENT 4500 IWHO = -1 4501 IF (ZEROAL(L) .EQ. -1) GOTO 100 4502 CALL MPIXRECV(NWHO,1,'INTEGER',IWHO,MPTAG1) 4503 CALL MPIXSEND(L,1,'INTEGER',NWHO,MPTAG2) 4504 CALL MPIXSEND(LRI,1,'INTEGER',NWHO,MPTAG2) 4505 LRI = LRI + 3 4506 100 CONTINUE 4507 4508C Send end message to all slaves 4509 4510 LEND = -1 4511 DO ISLAVE = 1,NODTOT 4512 IWHO = -1 4513 CALL MPIXRECV(NWHO,1,'INTEGER',IWHO,MPTAG1) 4514 CALL MPIXSEND(LEND,1,'INTEGER',NWHO,MPTAG2) 4515 CALL MPIXSEND(LRI,1,'INTEGER',NWHO,MPTAG2) 4516 END DO 4517 4518C Collect data from all slaves 4519 4520 CALL DZERO(WRK(KELF),3*POLDIM) 4521 CALL MPI_REDUCE(WRK(KELF),ELF,3*POLDIM, 4522 & MPI_DOUBLE_PRECISION,MPI_SUM,0,MPI_COMM_WORLD, 4523 & IERR) 4524 4525 CALL QEXIT('MM_FIELD_M2') 4526 4527 RETURN 4528 END 4529C****************************************************************************** 4530C /* Deck mm_field_s2 */ 4531 SUBROUTINE MM_FIELD_S2(WRK,LWRK,IPRTMP) 4532 4533#include "implicit.h" 4534#include "priunit.h" 4535#include "dummy.h" 4536#include "mxcent.h" 4537#include "iratdef.h" 4538#include "maxash.h" 4539#include "maxorb.h" 4540 4541#include "qmmm.h" 4542#include "qm3.h" 4543#include "inforb.h" 4544#include "inftap.h" 4545#include "infpri.h" 4546#include "scbrhf.h" 4547#include "maxaqn.h" 4548#include "symmet.h" 4549#include "orgcom.h" 4550#include "infinp.h" 4551#include "nuclei.h" 4552#include "codata.h" 4553C ---- 4554#include "infpar.h" 4555#include "mtags.h" 4556#if defined(VAR_MPI) 4557#include "mpif.h" 4558#endif 4559#include "cbiher.h" 4560#include "gnrinf.h" 4561 4562 DIMENSION WRK(LWRK) 4563 INTEGER POLDIM 4564 4565 CALL QENTER('MM_FIELD_S2') 4566 4567 QMMM = .TRUE. 4568 SPLDIP = .FALSE. ! Not implemented for iterative QMMM 4569 IPQMMM = IPRTMP 4570 4571C Receiving data from master 4572 4573 CALL MPIXBCAST(NNZAL,1,'INTEGER',MASTER) 4574 CALL MPIXBCAST(POLDIM,1,'INTEGER',MASTER) 4575 4576 KELF = 1 4577 KDCAO = KELF + 3*POLDIM 4578 KMAT = KDCAO + NNBASX 4579 KLAST = KMAT + 3*NNBASX 4580 LWRK2 = LWRK - KLAST + 1 4581 4582 IF (LWRK2 .LT. 0) CALL ERRWRK('MM_FIELD_S2',-KLAST,LWRK) 4583 4584 OBKPX = DIPORG(1) 4585 OBKPY = DIPORG(2) 4586 OBKPZ = DIPORG(3) 4587C 4588 CALL MPIXBCAST(NMULT,1,'INTEGER',MASTER) 4589 CALL MPIXBCAST(NEXLST,1,'INTEGER',MASTER) 4590 DO N=1, NEXLST 4591 CALL MPIXBCAST(EXLIST(N,1:MMCENT),MMCENT,'INTEGER',MASTER) 4592 ENDDO 4593 4594C Damping 4595 CALL MPIXBCAST(QMDAMP,1,'LOGICAL',MASTER) 4596 IF (QMDAMP) THEN 4597 CALL MPIXBCAST(IDAMP,1,'INTEGER',MASTER) 4598 CALL MPIXBCAST(IPOLTP,1,'INTEGER',MASTER) 4599 CALL MPIXBCAST(NQMNUC,1,'INTEGER',MASTER) 4600 CALL MPIXBCAST(QMPOL,MXCENT,'DOUBLE',MASTER) 4601 CALL MPIXBCAST(ADAMP,1,'DOUBLE',MASTER) 4602 CALL MPIXBCAST(POLMM,6*MMCENT,'DOUBLE',MASTER) 4603 ENDIF 4604C <- 4605 4606 CALL MPIXBCAST(DELFLD,1,'DOUBLE',MASTER) 4607 CALL MPIXBCAST(WRK(KDCAO),NNBASX,'DOUBLE',MASTER) 4608 4609C Do the work 4610 4611 CALL DZERO(WRK(KELF),3*POLDIM) 4612 4613 200 CONTINUE 4614 4615 CALL MPIXSEND(MYNUM,1,'INTEGER',MASTER,MPTAG1) 4616 CALL MPIXRECV(I,1,'INTEGER',MASTER,MPTAG2) 4617 CALL MPIXRECV(LRI,1,'INTEGER',MASTER,MPTAG2) 4618 4619 IF (I.GT.0) THEN 4620 CALL GET_FIELD(I,LRI,WRK(KELF),WRK(KLAST),WRK(KLAST), 4621 * WRK(KDCAO),.FALSE.,WRK(KLAST),LWRK2) 4622 GOTO 200 4623 ENDIF 4624 4625 CALL MPI_REDUCE(WRK(KELF),MPI_IN_PLACE,3*POLDIM, 4626 & MPI_DOUBLE_PRECISION,MPI_SUM,0,MPI_COMM_WORLD, 4627 & IERR) 4628 4629 DIPORG(1) = OBKPX 4630 DIPORG(2) = OBKPY 4631 DIPORG(3) = OBKPZ 4632 4633 CALL QEXIT('MM_FIELD_S2') 4634 4635 RETURN 4636 END 4637C****************************************************************************** 4638C /* Deck mm_polar_contr_m */ 4639 SUBROUTINE MM_POLAR_CONTR_M(DCAO,TAO,CINDMOM,WRK,LWRK,IPRINT) 4640 4641#include "implicit.h" 4642#include "priunit.h" 4643#include "dummy.h" 4644#include "mxcent.h" 4645#include "iratdef.h" 4646#include "maxash.h" 4647#include "maxorb.h" 4648 4649#include "qmmm.h" 4650#include "qm3.h" 4651#include "inforb.h" 4652#include "inftap.h" 4653#include "infpri.h" 4654#include "scbrhf.h" 4655#include "maxaqn.h" 4656#include "symmet.h" 4657#include "orgcom.h" 4658#include "infinp.h" 4659#include "nuclei.h" 4660#include "codata.h" 4661C ---- 4662#include "infpar.h" 4663#include "mtags.h" 4664#if defined(VAR_MPI) 4665#include "mpif.h" 4666#endif 4667#include "cbiher.h" 4668#include "gnrinf.h" 4669C defined parallel calculation types 4670#include "iprtyp.h" 4671 4672 DIMENSION WRK(LWRK), TAO(NNBASX), CINDMOM(*) 4673 4674 CALL QENTER('MM_POLAR_CONTR_M') 4675 4676 KTAO = 1 4677 KTAO2 = KTAO + NNBASX 4678 KREC = KTAO2 + NNBASX 4679 KWRK2 = KREC + 6 4680 LWRK2 = LWRK - KWRK2 + 1 4681 4682 IF (LWRK2 .LT. 0) THEN 4683 CALL ERRWRK('MM_POLAR_CONTR_M',-KWRK2,LWRK) 4684 ENDIF 4685 4686 EDELD = 0.0D0 ! For interaction with electronic density 4687 EDNUC = 0.0D0 ! For interaction with QM nuclei 4688 ED0MOM = 0.0D0 ! For interaction with point-charges 4689 ED1MOM = 0.0D0 ! For interaction with permanent dipoles 4690 ED2MOM = 0.0D0 ! For interaction with quadrupoles 4691 EDMULT = 0.0D0 ! For interaction with permanent multipoles 4692 4693C Beginning of parallel section 4694 4695 IPRTYP = MM_POLAR_CONTR_WORK 4696 4697C Wake up slaves 4698 4699 CALL MPIXBCAST(IPRTYP,1,'INTEGER',MASTER) 4700 CALL MPIXBCAST(IPQMMM,1,'INTEGER',MASTER) 4701 4702C Send data to slaves 4703 4704 CALL MPIXBCAST(NNZAL,1,'INTEGER',MASTER) 4705 CALL MPIXBCAST(NMULT,1,'INTEGER',MASTER) 4706 4707 CALL MPIXBCAST(CINDMOM,3*NNZAL,'DOUBLE',MASTER) 4708 4709 CALL MPIXBCAST(NEXLST,1,'INTEGER',MASTER) 4710 DO II = 1,NEXLST 4711 CALL MPIXBCAST(EXLIST(II,1:MMCENT),MMCENT,'INTEGER',MASTER) 4712 ENDDO 4713 4714C Damping 4715 CALL MPIXBCAST(QMDAMP,1,'LOGICAL',MASTER) 4716 IF (QMDAMP) THEN 4717 CALL MPIXBCAST(IDAMP,1,'INTEGER',MASTER) 4718 CALL MPIXBCAST(IPOLTP,1,'INTEGER',MASTER) 4719 CALL MPIXBCAST(NQMNUC,1,'INTEGER',MASTER) 4720 CALL MPIXBCAST(QMPOL,MXCENT,'DOUBLE',MASTER) 4721 CALL MPIXBCAST(ADAMP,1,'DOUBLE',MASTER) 4722 CALL MPIXBCAST(POLMM,6*MMCENT,'DOUBLE',MASTER) 4723 ENDIF 4724 4725 CALL MPIXBCAST(DELFLD,1,'DOUBLE',MASTER) 4726 CALL MPIXBCAST(DCAO,NNBASX,'DOUBLE',MASTER) 4727 4728 IINIM = 0 ! important should be zero due to the indexing used ! 4729 4730C Start parallelized loop 4731 DO 100 L = 1,MMCENT 4732 IWHO = -1 4733 IF (ZEROAL(L) .EQ. -1) GOTO 100 4734 CALL MPIXRECV(NWHO,1,'INTEGER',IWHO,MPTAG1) 4735 CALL MPIXSEND(L,1,'INTEGER',NWHO,MPTAG2) 4736 CALL MPIXSEND(IINIM,1,'INTEGER',NWHO,MPTAG2) 4737 IINIM = IINIM + 3 4738 100 CONTINUE 4739 4740C Send end message to all slaves 4741 4742 LEND = -1 4743 DO ISLAVE = 1,NODTOT 4744 IWHO = -1 4745 CALL MPIXRECV(NWHO,1,'INTEGER',IWHO,MPTAG1) 4746 CALL MPIXSEND(LEND,1,'INTEGER',NWHO,MPTAG2) 4747 CALL MPIXSEND(IINIM,1,'INTEGER',NWHO,MPTAG2) 4748 END DO 4749 4750C Collect data from all slaves 4751 4752 CALL DZERO(WRK(KTAO),NNBASX) 4753 CALL DZERO(WRK(KTAO2),NNBASX) 4754 CALL DZERO(WRK(KREC),6) 4755 CALL MPI_REDUCE(WRK(KTAO2),WRK(KTAO),NNBASX, 4756 & MPI_DOUBLE_PRECISION,MPI_SUM,0,MPI_COMM_WORLD, 4757 & IERR) 4758 4759 CALL DAXPY(NNBASX,1.0D0,WRK(KTAO),1,TAO(1),1) 4760 4761 CALL MPI_REDUCE(WRK(KREC+0),EDELD,1, 4762 & MPI_DOUBLE_PRECISION,MPI_SUM,0,MPI_COMM_WORLD, 4763 & IERR) 4764 CALL MPI_REDUCE(WRK(KREC+1),EDNUC,1, 4765 & MPI_DOUBLE_PRECISION,MPI_SUM,0,MPI_COMM_WORLD, 4766 & IERR) 4767 CALL MPI_REDUCE(WRK(KREC+2),ED0MOM,1, 4768 & MPI_DOUBLE_PRECISION,MPI_SUM,0,MPI_COMM_WORLD, 4769 & IERR) 4770 CALL MPI_REDUCE(WRK(KREC+3),ED1MOM,1, 4771 & MPI_DOUBLE_PRECISION,MPI_SUM,0,MPI_COMM_WORLD, 4772 & IERR) 4773 CALL MPI_REDUCE(WRK(KREC+4),ED2MOM,1, 4774 & MPI_DOUBLE_PRECISION,MPI_SUM,0,MPI_COMM_WORLD, 4775 & IERR) 4776 4777 EDMULT = ED0MOM + ED1MOM + ED2MOM 4778 4779 CALL QEXIT('MM_POLAR_CONTR_M') 4780 4781 RETURN 4782 END 4783C****************************************************************************** 4784C /* Deck mm_polar_contr_s */ 4785 SUBROUTINE MM_POLAR_CONTR_S(WRK,LWRK,IPRTMP) 4786 4787#include "implicit.h" 4788#include "priunit.h" 4789#include "dummy.h" 4790#include "mxcent.h" 4791#include "iratdef.h" 4792#include "maxash.h" 4793#include "maxorb.h" 4794 4795#include "qmmm.h" 4796#include "qm3.h" 4797#include "inforb.h" 4798#include "inftap.h" 4799#include "infpri.h" 4800#include "scbrhf.h" 4801#include "maxaqn.h" 4802#include "symmet.h" 4803#include "orgcom.h" 4804#include "infinp.h" 4805#include "nuclei.h" 4806#include "codata.h" 4807C ---- 4808#include "infpar.h" 4809#include "mtags.h" 4810#if defined(VAR_MPI) 4811#include "mpif.h" 4812#endif 4813#include "cbiher.h" 4814#include "gnrinf.h" 4815 4816 DIMENSION WRK(LWRK) 4817 4818 CALL QENTER('MM_POLAR_CONTR_S') 4819 4820 QMMM = .TRUE. 4821 IPQMMM = IPRTMP 4822 4823C Receiving data from master 4824 4825 CALL MPIXBCAST(NNZAL,1,'INTEGER',MASTER) 4826 4827 KDCAO = 1 4828 KTAO = KDCAO + NNBASX 4829 KMAT = KTAO + NNBASX 4830 KINDMOM = KMAT + 3*NNBASX 4831 KEDALL = KINDMOM + 3*NNZAL 4832 KLAST = KEDALL + 6 4833 LWRK2 = LWRK - KLAST + 1 4834 4835 IF (LWRK2 .LT. 0) CALL ERRWRK('MM_POLAR_CONTR_S',-KLAST,LWRK) 4836 4837 OBKPX = DIPORG(1) 4838 OBKPY = DIPORG(2) 4839 OBKPZ = DIPORG(3) 4840 4841 CALL MPIXBCAST(NMULT,1,'INTEGER',MASTER) 4842 CALL MPIXBCAST(WRK(KINDMOM),3*NNZAL,'DOUBLE',MASTER) 4843 4844 CALL MPIXBCAST(NEXLST,1,'INTEGER',MASTER) 4845 DO II = 1,NEXLST 4846 CALL MPIXBCAST(EXLIST(II,1:MMCENT),MMCENT,'INTEGER',MASTER) 4847 ENDDO 4848 4849C Damping 4850 CALL MPIXBCAST(QMDAMP,1,'LOGICAL',MASTER) 4851 IF (QMDAMP) THEN 4852 CALL MPIXBCAST(IDAMP,1,'INTEGER',MASTER) 4853 CALL MPIXBCAST(IPOLTP,1,'INTEGER',MASTER) 4854 CALL MPIXBCAST(NQMNUC,1,'INTEGER',MASTER) 4855 CALL MPIXBCAST(QMPOL,MXCENT,'DOUBLE',MASTER) 4856 CALL MPIXBCAST(ADAMP,1,'DOUBLE',MASTER) 4857 CALL MPIXBCAST(POLMM,6*MMCENT,'DOUBLE',MASTER) 4858 ENDIF 4859 4860 CALL MPIXBCAST(DELFLD,1,'DOUBLE',MASTER) 4861 CALL MPIXBCAST(WRK(KDCAO),NNBASX,'DOUBLE',MASTER) 4862 4863C Compute polarization contributions to the Fock/KS matrix and 4864C total solvation energy 4865 4866 CALL DZERO(WRK(KTAO),NNBASX) 4867 4868C Compute polarization contributions to the Fock/KS matrix and 4869C total solvation energy 4870 4871 EDELD = 0.0D0 ! For interaction with electronic density 4872 EDNUC = 0.0D0 ! For interaction with QM nuclei 4873 ED0MOM = 0.0D0 ! For interaction with point-charges 4874 ED1MOM = 0.0D0 ! For interaction with permanent dipoles 4875 ED2MOM = 0.0D0 ! For interaction with quadrupoles 4876 4877 20 CONTINUE 4878 4879 CALL MPIXSEND(MYNUM,1,'INTEGER',MASTER,MPTAG1) 4880 CALL MPIXRECV(I,1,'INTEGER',MASTER,MPTAG2) 4881 CALL MPIXRECV(IINIM,1,'INTEGER',MASTER,MPTAG2) 4882 4883 IF (I.GT.0) THEN 4884 CALL GET_POL_CONTR(I,WRK(KINDMOM+IINIM),WRK(KEDALL), 4885 & WRK(KDCAO),WRK(KTAO),WRK(KLAST),LWRK2) 4886 EDELD = EDELD + WRK(KEDALL) 4887 EDNUC = EDNUC + WRK(KEDALL + 1) 4888 ED0MOM = ED0MOM + WRK(KEDALL + 2) 4889 ED1MOM = ED1MOM + WRK(KEDALL + 3) 4890 ED2MOM = ED2MOM + WRK(KEDALL + 4) 4891 GOTO 20 4892 ENDIF 4893 4894 4895 CALL MPI_REDUCE(WRK(KTAO),MPI_IN_PLACE,NNBASX, 4896 & MPI_DOUBLE_PRECISION,MPI_SUM,0,MPI_COMM_WORLD, 4897 & IERR) 4898 4899 CALL MPI_REDUCE(EDELD,MPI_IN_PLACE,1, 4900 & MPI_DOUBLE_PRECISION,MPI_SUM,0,MPI_COMM_WORLD, 4901 & IERR) 4902 CALL MPI_REDUCE(EDNUC,MPI_IN_PLACE,1, 4903 & MPI_DOUBLE_PRECISION,MPI_SUM,0,MPI_COMM_WORLD, 4904 & IERR) 4905 CALL MPI_REDUCE(ED0MOM,MPI_IN_PLACE,1, 4906 & MPI_DOUBLE_PRECISION,MPI_SUM,0,MPI_COMM_WORLD, 4907 & IERR) 4908 CALL MPI_REDUCE(ED1MOM,MPI_IN_PLACE,1, 4909 & MPI_DOUBLE_PRECISION,MPI_SUM,0,MPI_COMM_WORLD, 4910 & IERR) 4911 CALL MPI_REDUCE(ED2MOM,MPI_IN_PLACE,1, 4912 & MPI_DOUBLE_PRECISION,MPI_SUM,0,MPI_COMM_WORLD, 4913 & IERR) 4914 4915 DIPORG(1) = OBKPX 4916 DIPORG(2) = OBKPY 4917 DIPORG(3) = OBKPZ 4918 4919 CALL QEXIT('MM_POLAR_CONTR_S') 4920 4921 RETURN 4922 END 4923C****************************************************************************** 4924C /* Deck mmiter_inddip_m */ 4925 SUBROUTINE MMITER_INDDIP_M(POLDIM,INDP1,INDMOM,VEC,INDDIA, 4926 * WRK,LWRK,LOCDEB,DIPCON,LM) 4927 4928#include "implicit.h" 4929C IMPLICIT NONE 4930 4931#include "priunit.h" 4932#include "mxcent.h" 4933#include "qmmm.h" 4934#include "maxorb.h" 4935#include "infpar.h" 4936#include "mtags.h" 4937#if defined(VAR_MPI) 4938#include "mpif.h" 4939#endif 4940C defined parallel calculation types 4941#include "iprtyp.h" 4942 4943 INTEGER POLDIM, POLARRAY 4944 DIMENSION POLARRAY(POLDIM) 4945 4946 LOGICAL LOCDEB,DIPCON 4947 4948 DOUBLE PRECISION INDMOM,INDDIA,INDP1 4949 DIMENSION INDMOM(3*POLDIM),VEC(MXMMIT+3*POLDIM), INDDIA(3*POLDIM) 4950 DIMENSION WRK(LWRK),INDP1(3*POLDIM) 4951 4952 DOUBLE PRECISION TERROR,TDIFF,TMAX 4953 DOUBLE PRECISION DIP,MY 4954 DIMENSION DIP(3),MY(3) 4955 4956 CALL QENTER('MMITER_INDDIP_M') 4957 4958 DIPCON = .FALSE. 4959 4960 THRESL = THMMIT 4961 NDIM = 3*POLDIM 4962 4963C Make a vector of pol sites 4964 L = 0 4965 DO 1 I=1,MMCENT 4966 IF (ZEROAL(I) .EQ. -1) GOTO 1 4967 L = L + 1 4968 POLARRAY(L) = I 4969 1 CONTINUE 4970 4971C Beginning of parallel section 4972 4973 IPRTYP = MMITER_INDDIP_WORK 4974 4975C Wake up slaves 4976 4977 CALL MPIXBCAST(IPRTYP,1,'INTEGER',MASTER) 4978 CALL MPIXBCAST(IPQMMM,1,'INTEGER',MASTER) 4979 4980 CALL MPIXBCAST(POLDIM,1,'INTEGER',MASTER) 4981 CALL MPIXBCAST(NODTOT,1,'INTEGER',MASTER) 4982 CALL MPIXBCAST(POLARRAY,POLDIM,'INTEGER',MASTER) 4983 CALL MPIXBCAST(IPOLTP,1,'INTEGER',MASTER) 4984 IF (IPOLTP .EQ. 1) THEN 4985 CALL MPIXBCAST(POLIMM,MMCENT,'DOUBLE',MASTER) 4986 ELSE IF (IPOLTP .EQ. 2) THEN 4987 CALL MPIXBCAST(POLMM,6*MMCENT,'DOUBLE',MASTER) 4988 ENDIF 4989 4990 KINDP1 = 1 4991 KINDP2 = KINDP1 + NDIM 4992 KLAST = KINDP2 + NDIM 4993 LWRK2 = LWRK - KLAST + 1 4994 4995 DO 100 ITER = 1, MXMMIT 4996 LM = LM + 1 4997 DO ISLAVE = 1, NODTOT 4998 IWHO = -1 4999 NRUN = 1 5000 CALL MPIXRECV(NWHO, 1, 'INTEGER', IWHO, MPTAG1) 5001 CALL MPIXSEND(NRUN, 1, 'INTEGER', NWHO, MPTAG2) 5002 ENDDO 5003 5004 CALL MPIXBCAST(INDP1,NDIM,'DOUBLE',MASTER) 5005 CALL DZERO(WRK(KINDP1),NDIM) 5006 CALL DZERO(WRK(KINDP2),NDIM) 5007 5008 CALL MPI_REDUCE(WRK(KINDP1),WRK(KINDP2),NDIM, 5009 & MPI_DOUBLE_PRECISION,MPI_SUM,0,MPI_COMM_WORLD, 5010 & IERR) 5011 5012 CALL DAXPY(NDIM,1.0D0,WRK(KINDP2),1,INDMOM,1) 5013 5014 TERROR=0.0D0 5015 DO I=1,NDIM 5016 TERROR = TERROR + (INDMOM(I)-INDP1(I))* 5017 & (INDMOM(I)-INDP1(I)) 5018 ENDDO 5019 5020 IF ( (LOCDEB) .OR. (IPRINT .GE. 15) ) THEN 5021 LMAX = 0 5022 TMAX = 0.0D0 5023 DO I=1,NDIM 5024 TDIFF = ABS(INDMOM(I)-INDP1(I)) 5025 IF (TDIFF .GT. TMAX) THEN 5026 TMAX = TDIFF 5027 LMAX = I 5028 ENDIF 5029 ENDDO 5030 IF (LMAX .NE. 0) THEN 5031 WRITE(LUPRI,*) 'Maximum deviation (element) is ',TMAX, LMAX 5032 ENDIF 5033 ENDIF 5034 5035 5036 IF (ABS(TERROR) .LT. THRESL) THEN 5037 DIPCON = .TRUE. 5038 GOTO 200 5039 ELSE 5040 DIPCON = .FALSE. 5041 IF (LOCDEB )WRITE(LUPRI,*) 'TERROR ',TERROR 5042 IF ( MMDIIS ) THEN 5043 CALL DCOPY(NDIM,INDMOM,1,VEC(ITER*NDIM+1),1) 5044 CALL MM_DIIS_EXTRAPOLATION(VEC,ITER,NDIM,INDP1, 5045 * WRK(KLAST),LWRK2,IPRINT) 5046 ELSE 5047 CALL DCOPY(NDIM,INDMOM,1,INDP1,1) 5048 ENDIF 5049C If no convergence in last iteration keep the values for the 5050C induced dipoles, i.e. not only the diagonal part 5051 IF (ITER .NE. MXMMIT) CALL DCOPY(NDIM,INDDIA,1, 5052 * INDMOM,1) 5053 ENDIF 5054 5055 100 CONTINUE 5056 5057 200 CONTINUE !Done 5058 5059C End message to slaves 5060 NRUN = -1 5061 DO ISLAVE = 1, NODTOT 5062 IWHO = -1 5063 CALL MPIXRECV(NWHO, 1, 'INTEGER', IWHO, MPTAG1) 5064 CALL MPIXSEND(NRUN, 1, 'INTEGER', NWHO, MPTAG2) 5065 ENDDO 5066 5067 CALL QEXIT('MMITER_INDDIP_M') 5068 5069 RETURN 5070 END 5071C****************************************************************************** 5072C /* Deck mmiter_inddip_s */ 5073 SUBROUTINE MMITER_INDDIP_S(WRK,LWRK,IPRINT) 5074 5075#include "implicit.h" 5076#include "maxorb.h" 5077#include "infpar.h" 5078#include "mxcent.h" 5079#include "qmmm.h" 5080#include "mtags.h" 5081#if defined(VAR_MPI) 5082#include "mpif.h" 5083#endif 5084 5085 INTEGER POLDIM, POLARRAY 5086 DIMENSION WRK(LWRK), POLARRAY(:) 5087 ALLOCATABLE POLARRAY 5088 DOUBLE PRECISION DIP,MY 5089 DIMENSION DIP(3),MY(3) 5090 LOGICAL RUN 5091 5092 CALL QENTER('MMITER_INDDIP_S') 5093 5094 CALL MPIXBCAST(POLDIM,1,'INTEGER',MASTER) 5095 CALL MPIXBCAST(NODTOT,1,'INTEGER',MASTER) 5096 5097 ALLOCATE(POLARRAY(POLDIM)) 5098 CALL MPIXBCAST(POLARRAY,POLDIM,'INTEGER',MASTER) 5099 CALL MPIXBCAST(IPOLTP,1,'INTEGER',MASTER) 5100 IF (IPOLTP .EQ. 1) THEN 5101 CALL MPIXBCAST(POLIMM,MMCENT,'DOUBLE',MASTER) 5102 ELSE IF (IPOLTP .EQ. 2) THEN 5103 CALL MPIXBCAST(POLMM,6*MMCENT,'DOUBLE',MASTER) 5104 ENDIF 5105 5106 NSLICE = POLDIM/NODTOT 5107 ISTART = (MYNUM-1)*NSLICE + 1 5108 IEND = ISTART + NSLICE - 1 5109C check if there is leftovers 5110 IF ( (NODTOT*NSLICE) .LT. POLDIM) THEN 5111 LEFT = POLDIM - NODTOT*NSLICE 5112 IF (MYNUM .LE. LEFT) THEN 5113 ISTART = ISTART + MYNUM - 1 5114 IEND = IEND + MYNUM 5115 ELSE 5116 ISTART = ISTART + LEFT 5117 IEND = IEND + LEFT 5118 ENDIF 5119 END IF 5120 5121 NDIM = 3*POLDIM 5122 5123 KINDP1 = 1 5124 KINDP2 = KINDP1 + NDIM 5125 KLAST = KINDP2 + NDIM 5126 5127 LWRK2 = LWRK - KLAST + 1 5128 IF (LWRK2 .LT. 0) CALL ERRWRK('MMITER_INDDIP_S',-KLAST,LWRK) 5129 5130 CALL DZERO(WRK(KINDP2),NDIM) 5131 5132 20 CONTINUE 5133 5134 CALL MPIXSEND(MYNUM,1,'INTEGER',MASTER,MPTAG1) 5135 CALL MPIXRECV(IRUN,1,'INTEGER',MASTER,MPTAG2) 5136 5137 IF (IRUN .EQ. 1) THEN 5138 CALL DZERO(WRK(KINDP2),NDIM) 5139 CALL MPIXBCAST(WRK(KINDP1),NDIM,'DOUBLE',MASTER) 5140 LRI = 1 + 3*(ISTART-1) 5141 DO L = ISTART, IEND 5142 I = POLARRAY(L) 5143 LCI = 1 5144 DO K = 1, POLDIM 5145 J = POLARRAY(K) 5146 CALL GET_MY(I,J,WRK(KINDP1+LCI-1),MY) 5147 WRK(KINDP2+LRI-1+0) = WRK(KINDP2+LRI-1+0) + MY(1) 5148 WRK(KINDP2+LRI-1+1) = WRK(KINDP2+LRI-1+1) + MY(2) 5149 WRK(KINDP2+LRI-1+2) = WRK(KINDP2+LRI-1+2) + MY(3) 5150 LCI = LCI + 3 5151 ENDDO 5152 LRI = LRI + 3 5153 ENDDO 5154 5155 CALL MPI_REDUCE(WRK(KINDP2),MPI_IN_PLACE,NDIM, 5156 & MPI_DOUBLE_PRECISION,MPI_SUM,0,MPI_COMM_WORLD, 5157 & IERR) 5158 5159 GOTO 20 5160 ENDIF 5161 5162 DEALLOCATE(POLARRAY) 5163 5164 CALL QEXIT('MMITER_INDDIP_S') 5165 5166 RETURN 5167 END 5168 5169#endif 5170C 5171C /* Deck pcmgrd */ 5172 SUBROUTINE PEGRD(CREF,CMO,INDXCI,DV,G,EQMMM,WRK,LFREE) 5173C 5174C 5175C Written by Erik Donovan Hedegård (edh) based on PCMGRAD 5176C 5177C Purpose: calculate MCSCF energy and gradient contribution 5178C from a PE medium 5179C 5180C Output: 5181C G MCSCF gradient with solvation contribution added 5182C ESOLT total solvation energy 5183C 5184C Used from common blocks: 5185C INFVAR: NCONF, NWOPT, NVAR, NVARH 5186C INFORB: NNASHX, NNBASX, NNORBX, etc. 5187C INFIND: IROW(*) 5188C INFTAP: LUSOL, LUIT2 5189C INFPRI: IPRSOL 5190C dftcom.h : DFT_SPINDNS 5191C 5192#include "implicit.h" 5193#include "priunit.h" 5194#include "pi.h" 5195#include "maxash.h" 5196#include "maxorb.h" 5197#include "mxcent.h" 5198#include "qmmm.h" 5199#include "nuclei.h" 5200#include "orgcom.h" 5201#include "infvar.h" 5202#include "inforb.h" 5203#include "infind.h" 5204#include "inftap.h" 5205#include "infpri.h" 5206C edh 09/11 2011 5207#include "gnrinf.h" 5208#include "dftcom.h" 5209 5210 DIMENSION CREF(*), CMO(*), INDXCI(*) 5211 DIMENSION DV(*), G(*), WRK(LFREE) 5212 PARAMETER ( D0 = 0.0D0, DP5 = 0.5D0, D1 = 1.0D0, D2 = 2.0D0, 5213 & DCVAL = D2, FPI = 4.0D0 * PI ) 5214 LOGICAL LOCDEB,FNDLAB,FIRST 5215 CHARACTER*8 STAR8,SOLVDI,EODATA 5216 DATA FIRST/.TRUE./, STAR8/'********'/ 5217 DATA SOLVDI/'SOLVDIAG'/, EODATA/'EODATA '/ 5218 5219C 5220C Statement functions; 5221C define automatic arrays (dynamic core allocation) 5222C 5223C 5224 CALL QENTER('PEGRD') 5225C 5226C Core allocation 5227C 5228 LOCDEB = .FALSE. 5229 5230 KDENC = 1 5231 KDENV = KDENC + N2BASX 5232 KDENT = KDENV + N2BASX 5233 KDENTF = KDENT + N2BASX 5234C ------------------------------- 5235 KFPE = KDENTF + NNBASX 5236 KUCMO = KFPE + NNBASX 5237 KFPEMO = KUCMO + NORBT*NBAST 5238 KFPEM = KFPEMO + NNORBX ! extra temporary 5239 KFPEAC = KFPEM + NNORBX 5240C ------------------------------ 5241 KGRDPE = KFPEAC + NNASHX 5242 KDIAPE = KGRDPE + NVARH 5243C ------------------------------ 5244 KWRK1 = KDIAPE + NVAR 5245 LWRK1 = LFREE - KWRK1 5246 5247 IF (LWRK1 .LT. 0) CALL ERRWRK('PEGRD',-KWRK1,LWRK1) 5248 5249C 1. KDENC : Core (inactive) density matrix from fckden routine 5250C 2. KDENV : Valence (active) density matrix 5251C 3. KDENT : Total density matrix (sum DC + DV) 5252C 4. KDENTF : Folded total density matrix 5253C --------------------------------------------------------------- 5254C 6. KFPE : Polarizable Embedded (PE) Tg operator (AO basis) 5255C 7. KUCMO : MO coefficients 5256C 8. KFPEMO : Polarizable Embedded (PE) Tg operator (MO basis) 5257C 9. KFPEAC : - active part 5258C -------------------------------------------------------------- 5259C 10. KGRDPE : Solvent contr. to MCSCF gradient (G) 5260C - Output from SOLGC and SOLGO 5261C 11. KDIAPE : -Output from SOLDIA (what is this??) 5262 5263 5264 CALL DZERO(WRK(KDENC),N2BASX) 5265 CALL DZERO(WRK(KDENV),N2BASX) 5266 CALL DZERO(WRK(KDENT),N2BASX) 5267 CALL DZERO(WRK(KDENTF),NNBASX) 5268 CALL DZERO(WRK(KFPE),NNBASX) 5269 CALL DZERO(WRK(KUCMO),NORBT*NBAST) 5270 CALL DZERO(WRK(KFPEMO),NNORBX) 5271 CALL DZERO(WRK(KFPEM),NNORBX) ! extra temporary 5272 CALL DZERO(WRK(KFPEAC),NNASHX) 5273 CALL DZERO(WRK(KGRDPE),NVARH) 5274 CALL DZERO(WRK(KDIAPE),NVAR) 5275 5276C ************* Write statements for debugging **************** 5277C ************************************************************* 5278 5279 IF ( (IPQMMM .GE. 15) .OR. (LOCDEB) )THEN 5280 WRITE (LUPRI,'(/A/A,2I10)') 5281 * ' --- PEGRD - gtot (input) - non-zero elements', 5282 * ' NCONF, NWOPT =',NCONF,NWOPT 5283 DO 40 I = 1,NCONF 5284 IF (G(I) .NE. D0) WRITE (LUPRI,'(A,I10,3F15.10)') 5285 * ' conf #',I,G(I) 5286 40 CONTINUE 5287 DO 50 I = NCONF+1,NVAR 5288 IF (G(I) .NE. D0) WRITE (LUPRI,'(A,I10,3F15.10)') 5289 * ' orb #',I,G(I) 5290 50 CONTINUE 5291 END IF 5292 5293 IF ( (IPQMMM .GE. 15 .AND. NASHT .GT. 0) .OR. (LOCDEB) ) THEN 5294 WRITE (LUPRI,'(/A)') ' --- PEGRD - DV matrix :' 5295 CALL OUTPAK(DV,NASHT,1,LUPRI) 5296 END IF 5297 5298C ************************************************************* 5299C ************************************************************* 5300 5301 CALL FCKDEN((NISHT.GT.0),(NASHT.GT.0),WRK(KDENC),WRK(KDENV), 5302 & CMO,DV,WRK(KWRK1),LWRK1) 5303 5304 CALL DCOPY(N2BASX,WRK(KDENC),1,WRK(KDENT),1) ! Construct DC dens. matetrix (KDENC) 5305 CALL DAXPY(N2BASX,1.0D0,WRK(KDENV),1,WRK(KDENT),1) ! Add valence density matrix DV (DC + DV) 5306 5307 CALL DGEFSP(NBAST,WRK(KDENT),WRK(KDENTF)) ! Fold total dens. matrix 5308 5309 IF (LOCDEB) THEN 5310 WRITE(LUPRI,*) 'KDENTF IN PEGRD BEFORE QMMM_FCK_AO' 5311 CALL OUTPAK(WRK(KDENTF),NBAST,1,LUPRI) 5312 CALL DCOPY(NNBASX,WRK(KDENTF),1,WRK(KDENC),1) 5313 ENDIF 5314 5315 CALL QMMM_FCK_AO(WRK(KFPE),WRK(KDENTF),EQMMM,WRK(KWRK1),LWRK1, 5316 & IPQMMM) 5317 ! Gradient routine needs EQMMM 5318 ! PEFCMO should be changed 5319 ! to deliver EQMMM as well 5320 ! requires call change for other places where 5321 CALL UPKCMO(CMO,WRK(KUCMO)) 5322 ! PEFCMO 5323 CALL UTHU(WRK(KFPE),WRK(KFPEMO),WRK(KUCMO),WRK(KWRK1), 5324 & NBAST,NORBT) 5325 5326 CALL PEFCMO(WRK(KUCMO),WRK(KFPEM),DV,WRK(KWRK1),LWRK1,IPQMMM) 5327 ! edh: KFPEM is a temp. variable used to debug 5328 ! and prepare this module to magnus' PE module 5329 ! problem is that PEFCMO doesn't calc. EQMMM 5330 ! and now we get it from QMMM_FCK_AO 5331 IF (NASHT .GT. 0) THEN 5332 CALL GETAC2(WRK(KFPEM),WRK(KFPEAC)) 5333 IF (DFT_SPINDNS) CALL QUIT('PEGRD: '// 5334 & 'DFT_SPINDNS not implemented here yet, sorry!') 5335 END IF 5336 5337C 5338C Expextation value of FPE 5339 5340 TFPEMO = SOLELM(DV,WRK(KFPEAC),WRK(KFPEM),TFPEAC) 5341 5342C 5343C ************* Write statements for debugging **************** 5344C ************************************************************* 5345 5346 IF ( (IPQMMM .GE. 15) .OR. (LOCDEB) ) THEN 5347 WRITE (LUPRI,'(A,F17.8)') 5348 * ' --- FPE expectation value MO :',TFPEMO 5349 WRITE (LUPRI,'(A,F17.8)') 5350 * ' --- active part of FPE :',TFPEAC 5351 ENDIF 5352 5353 IF ( (IPQMMM .GE. 15) .OR. (LOCDEB) ) THEN 5354 WRITE (LUPRI,'(/A)') ' PE_ao matrix in PEGRD:' 5355 CALL OUTPAK(WRK(KFPE),NBAST,1,LUPRI) 5356 WRITE (LUPRI,'(/A)') ' PE_mo matrix in KFPEMO:' 5357 CALL OUTPAK(WRK(KFPEMO),NORBT,1,LUPRI) 5358 IF (NASHT .GT. 0) THEN 5359 WRITE (LUPRI,'(/A)') ' PE_ac matrix in PEGRD:' 5360 CALL OUTPAK(WRK(KFPEAC),NASHT,1,LUPRI) 5361 ENDIF 5362 ENDIF 5363 5364 IF ( (IPQMMM .GE. 15) .OR. (LOCDEB) ) THEN 5365 WRITE (LUPRI,'(/A)') ' PE_ao matrix from pefcmo call in PEGRD:' 5366 CALL OUTPAK(WRK(KFPE),NBAST,1,LUPRI) 5367 WRITE (LUPRI,'(/A)') ' PE_mo matrix in KFPEM:' 5368 CALL OUTPAK(WRK(KFPEM),NORBT,1,LUPRI) 5369 ENDIF 5370 5371C ************************************************************* 5372C ************************************************************* 5373C 5374C ******* edh: SOLGC computes the solvent CI integrals ******* 5375C ******* input: CREF(NCONF) = CI reference state ******* 5376C ******* KFPEAC(NNASHX) = Solvent integrals ******* 5377C ******* TFPEAC = CREF exp. value ******* 5378C ******* INDXCI(*) = CI index ******* 5379C ******* output: GLMCI(NCONF) = CI solv. gradient ******* 5380 5381 IF (NCONF .GT. 1) THEN 5382 CALL SOLGC(CREF,WRK(KFPEAC),TFPEAC,WRK(KGRDPE),INDXCI, ! NOTE: Output here is GRDPE (solv. CI PE contribution) 5383 & WRK(KWRK1),LWRK1) ! edh: SOLGC calc. < u | Fg | 0 > + < 0 | Fg | 0 > c_u 5384 END IF 5385 5386 IF (NWOPT .GT. 0) THEN 5387 CALL SOLGO(DCVAL,DV,WRK(KFPEM),WRK(KGRDPE+NCONF)) ! edh: SOLGO calc. 2 < 0 | [Ers, Fg] | 0 > 5388 END IF 5389 5390 CALL SOLDIA(TFPEAC,WRK(KFPEAC),INDXCI, 5391 * WRK(KFPEM),DV,WRK(KDIAPE),WRK(KWRK1),LWRK1) 5392 5393 DO 420 I = 0,(NVAR-1) 5394 WRK(KDIAPE+I) = - WRK(KDIAPE+I) 5395 420 CONTINUE 5396 5397C 5398C ******************* Orthogonality test ********************** 5399C ************************************************************* 5400C 5401 IF ( (IPQMMM .GE. 15) .OR. (LOCDEB) ) THEN 5402 WRITE (LUPRI,'(/A)')' --- PEGRD - grdj1, grdj2, diape, '// 5403 & 'diape, cref' 5404 DO 430 I = 1,NCONF 5405 WRITE (LUPRI,'(A,I10,3F10.6)') ' conf #',I, 5406 * WRK(KDIAPE-1+I), 5407 * WRK(KDIAPE-1+I),CREF(I) 5408 430 CONTINUE 5409 END IF 5410C 5411 TEST = DDOT(NCONF,CREF,1,WRK(KGRDPE),1) 5412 IF (ABS(TEST) .GT. 1.D-8) THEN 5413 NWARN = NWARN + 1 5414 WRITE (LUPRI,*) ' --- PEGRD WARNING --- ' 5415 WRITE (LUPRI,*) ' <CREF | GRAD > =',TEST 5416 END IF 5417 5418C ************************************************************* 5419C ************************************************************* 5420 5421C Add PE gradient contribution to MCSCF gradient 5422C 5423 CALL DAXPY(NVARH,D1,WRK(KGRDPE),1,G,1) 5424 5425 IF ( (IPQMMM .GE. 15) .OR. (LOCDEB) ) THEN 5426 WRITE (LUPRI,'(/A/A,2I10)') 5427 * ' --- PEGRD - grdB, gtot (accum) - non-zero grdpe', 5428 * ' NCONF, NWOPT =',NCONF,NWOPT 5429 DO 440 I = 1,NCONF 5430 IF (WRK(KGRDPE-1+I) .NE. D0) 5431 * WRITE (LUPRI,'(A,I10,3F15.10)') 5432 * ' conf #',I,WRK(KGRDPE-1+I),G(I) 5433 440 CONTINUE 5434 DO 450 I = NCONF+1,NVAR 5435 IF (WRK(KGRDPE-1+I) .NE. D0) 5436 * WRITE (LUPRI,'(A,I10,3F15.10)') 5437 * ' orb #',I,WRK(KGRDPE-1+I),G(I) 5438 450 CONTINUE 5439 END IF 5440C 5441 IF ( (IPQMMM .GE. 15) .OR. (LOCDEB) ) THEN 5442 WRITE (LUPRI,'(/A/A,2I10)') 5443 * ' --- PEGRD - gtot (output) - non-zero elements', 5444 * ' NCONF, NWOPT =',NCONF,NWOPT 5445 DO 840 I = 1,NCONF 5446 IF (G(I) .NE. D0) WRITE (LUPRI,'(A,I10,3F15.10)') 5447 * ' conf #',I,G(I) 5448 840 CONTINUE 5449 DO 850 I = NCONF+1,NVAR 5450 IF (G(I) .NE. D0) WRITE (LUPRI,'(A,I10,3F15.10)') 5451 * ' orb #',I,G(I) 5452 850 CONTINUE 5453 END IF 5454 5455 IF (LUIT2 .GT. 0) THEN 5456 NC4 = MAX(NCONF,4) 5457 NW4 = MAX(NWOPT,4) 5458 REWIND LUIT2 5459 IF (FNDLAB(EODATA,LUIT2)) BACKSPACE LUIT2 5460 WRITE (LUIT2) STAR8,STAR8,STAR8,SOLVDI 5461 IF (NCONF .GT. 1) CALL WRITT(LUIT2,NC4,WRK(KDIAPE)) 5462 WRITE (LUIT2) STAR8,STAR8,STAR8,EODATA 5463 END IF 5464 5465 CALL QEXIT('PEGRD') 5466C end of pegrd. 5467 END 5468 5469C 5470C /* Deck pcmgrd */ 5471 SUBROUTINE PEFCMO(CMO,FSOL,DV,WRK,LFREE,IPRINT) 5472C 5473C 5474C Written Erik Donovan Hedegård (edh) 5475C 5476C Purpose: Transform (MCSCF) Fg PE operator to MO basis 5477C 5478C Output: 5479C FSOL Tg PE operator in MO basis 5480C 5481#include "implicit.h" 5482#include "priunit.h" 5483#include "pi.h" 5484C 5485C 5486C Used from common blocks: 5487C INFVAR: NCONF, NWOPT, NVAR, NVARH 5488C INFORB: NNASHX, NNBASX, NNORBX, etc. 5489C INFIND: IROW(*) 5490C INFTAP: LUSOL, LUIT2 5491C INFPRI: IPRSOL 5492C 5493 5494#include "maxash.h" 5495#include "maxorb.h" 5496#include "mxcent.h" 5497#include "qmmm.h" 5498#include "nuclei.h" 5499#include "orgcom.h" 5500#include "infvar.h" 5501#include "inforb.h" 5502#include "infind.h" 5503#include "inftap.h" 5504#include "infpri.h" 5505#include "gnrinf.h" 5506 5507 DIMENSION CMO(*), FSOL(*) 5508 DIMENSION DV(*), WRK(*) 5509 PARAMETER ( D0 = 0.0D0, DP5 = 0.5D0, D1 = 1.0D0, D2 = 2.0D0, 5510 & DCVAL = D2, FPI = 4.0D0 * PI ) 5511 5512 CALL QENTER('PEFCMO') 5513 5514C Core allocation 5515C 5516 KDENC = 1 5517 KDENV = KDENC + N2BASX 5518 KDENT = KDENV + N2BASX 5519 KDENTF = KDENT + N2BASX 5520C ------------------------------- 5521 KFPE = KDENTF + NNBASX 5522 KUCMO = KFPE + NNBASX 5523 KFPEMO = KUCMO + NORBT*NBAST 5524C ------------------------------ 5525 KWRK1 = KFPEMO + NNORBX 5526 LWRK1 = LFREE - KWRK1 5527 5528C 1. KDENC : Core (inactive) density matrix. CALL from fckden subroutine 5529C 2. KDENV : Valence (active) density matrix 5530C 3. KDENT : Total density matrix (sum DC + DA) 5531C 4. KDENTF : Folded total density matrix 5532C ------------------------------ 5533C 6. KFPE : Polarizable Embedded (PE) Tg operator (AO basis) 5534C 7. KUCMO : MO coefficients 5535C 8. KFPEMO : Polarizable Embedded (PE) Tg operator (MO basis) 5536 5537 5538 CALL DZERO(WRK(KDENC),N2BASX) 5539 CALL DZERO(WRK(KDENV),N2BASX) 5540 CALL DZERO(WRK(KDENT),N2BASX) 5541 CALL DZERO(WRK(KDENTF),NNBASX) 5542 CALL DZERO(WRK(KFPE),NNBASX) 5543 CALL DZERO(WRK(KUCMO),NORBT*NBAST) 5544 CALL DZERO(WRK(KFPEMO),NNORBX) 5545 5546 IF (LWRK1 .LT. 0) CALL ERRWRK('PEFCMO',-KWRK1,LWRK1) 5547 5548 IF (IPQMMM .GE. 15 .AND. NASHT .GT. 0) THEN 5549 WRITE (LUPRI,'(/A)') ' --- PEFCMO - DV matrix :' 5550 CALL OUTPAK(DV,NASHT,1,LUPRI) 5551 END IF 5552 5553 CALL FCKDEN((NISHT.GT.0),(NASHT.GT.0),WRK(KDENC),WRK(KDENV), 5554 & CMO,DV,WRK(KWRK1),LWRK1) 5555 5556 CALL DCOPY(N2BASX,WRK(KDENC),1,WRK(KDENT),1) 5557 CALL DAXPY(N2BASX,1.0D0,WRK(KDENV),1,WRK(KDENT),1) 5558 CALL DGEFSP(NBAST,WRK(KDENT),WRK(KDENTF)) 5559 5560 CALL QMMM_FCK_AO(WRK(KFPE),WRK(KDENTF),EQMMM,WRK(KWRK1),LWRK1, 5561 & IPQMMM) 5562 5563 CALL UPKCMO(CMO,WRK(KUCMO)) 5564 CALL UTHU(WRK(KFPE),FSOL,WRK(KUCMO),WRK(KWRK1), 5565 & NBAST,NORBT) 5566 5567 IF (IPQMMM .GE. 15) THEN 5568 WRITE (LUPRI,'(/A)') ' PE_ao matrix in PEFCMO:' 5569 CALL OUTPAK(WRK(KFPE),NBAST,1,LUPRI) 5570 WRITE (LUPRI,'(/A)') ' PE_mo matrix in PEFCMO:' 5571 CALL OUTPAK(FSOL,NORBT,1,LUPRI) 5572 END IF 5573 5574 CALL QEXIT('PEFCMO') 5575C end of pefcmo. 5576 END 5577 5578C /* Deck pelin */ 5579 SUBROUTINE PELIN(NCSIM,NOSIM,BCVECS,BOVECS,CREF,CMO,INDXCI, 5580 & DV,DTV,SCVECS,SOVECS,ORBLIN,WRK,LWRK) 5581C 5582C Written by Erik Donovan Hedegård december 2011 5583C after original code by Hans Joergen Aa. Jensen 5584C Common driver for PELNC and PELNO 5585C 5586#include "implicit.h" 5587#include "maxorb.h" 5588#include "mxcent.h" 5589#include "priunit.h" 5590#include "inflin.h" 5591#include "infvar.h" 5592C edh 13/12 2011 5593#include "qmmm.h" 5594#include "gnrinf.h" 5595 5596C Used from common blocks: 5597C INFLIN : NWOPPT,NVARPT 5598 5599 5600 DIMENSION BCVECS(*),BOVECS(*),CREF(*),CMO(*),INDXCI(*) 5601 DIMENSION DV(*),DTV(*),SCVECS(*),SOVECS(*),WRK(LWRK) 5602 LOGICAL ORBLIN, LOCDEB 5603 5604 LOCDEB = .FALSE. 5605 5606 CALL QENTER('PELIN') 5607 5608 IF (NCSIM .GT. 0) THEN 5609 IF ( (LOCDEB) .OR. (IPQMMM.GT.15) ) THEN 5610 WRITE(LUPRI,*)' LINEAR TRANSFORMED CONFIGURATION VECTOR' 5611 WRITE(LUPRI,*)' BEFORE PELNC CALL, ITERATION # ' 5612 CALL OUTPUT(SCVECS,1,NCONF,1,NCSIM,NCONF,NCSIM,1,LUPRI) 5613 END IF 5614 5615 CALL PELNC(NCSIM,BCVECS,CREF,CMO,INDXCI, 5616 & DV,DTV,SCVECS,WRK,LWRK) 5617 5618 IF ( (LOCDEB) .OR. (IPQMMM .GT. 15) ) THEN 5619 WRITE(LUPRI,*)' LINEAR TRANSFORMED CONFIGURATION VECTOR' 5620 WRITE(LUPRI,*)' AFTER PELNC CALL, ITERATION # ' 5621 CALL OUTPUT(SCVECS,1,NCONF,1,NCSIM,NCONF,NCSIM,1,LUPRI) 5622 END IF 5623 END IF 5624 5625 IF ( NOSIM .GT.0 ) THEN 5626 IF ( .NOT.ORBLIN ) THEN 5627 NSVAR = NVARPT 5628 ELSE 5629 NSVAR = NWOPPT 5630 END IF 5631 IF ( (LOCDEB) .OR. (IPQMMM .GT. 15) ) THEN 5632 WRITE(LUPRI,*)' LINEAR TRANSFORMED ORBITAL VECTOR' 5633 WRITE(LUPRI,*)' BEFORE PELNO CALL, ITERATION # ' 5634 CALL OUTPUT(SOVECS,1,NWOPPT,1,NOSIM,NWOPPT,NOSIM,1,LUPRI) 5635 END IF 5636 5637 CALL PELNO(NOSIM,BOVECS,CREF,CMO,INDXCI, 5638 & DV, SOVECS,NSVAR,WRK,LWRK) 5639 5640 IF ( (LOCDEB) .OR. (IPQMMM .GT. 15) ) THEN 5641 WRITE(LUPRI,*)' LINEAR TRANSFORMED ORBITAL VECTOR' 5642 WRITE(LUPRI,*)' AFTER PELNO, ITERATION # ' 5643 CALL OUTPUT(SOVECS,1,NWOPPT,1,NOSIM,NWOPPT,NOSIM,1,LUPRI) 5644 END IF 5645 END IF 5646 5647 CALL QEXIT('PELIN') 5648 RETURN 5649 END 5650 5651C /* Deck pelnc */ 5652 SUBROUTINE PELNC(NCSIM,BCVEC,CREF,CMO,INDXCI, 5653 * DV,DTV,SVEC,WRK,LFREE) 5654C 5655C Written by Erik Donovan Hedegaard Jan-03 2012 5656C after original routine by Hans Jørgen Aa. Jensen 5657C 5658C Purpose: Calculate MCSCF Hessian contribution from a 5659C surrounding PE medium to a csf trial vector. 5660C 5661#include "implicit.h" 5662#include "priunit.h" 5663#include "mxcent.h" 5664#include "dummy.h" 5665#include "iratdef.h" 5666#include "thrzer.h" 5667#include "maxash.h" 5668#include "maxorb.h" 5669C 5670C Used from common blocks: 5671C INFORB : NNASHX, NNORBX, NNBASX, etc. 5672C INFVAR : NWOPH 5673C INFLIN : NCONST, NVARPT, NWOPPT 5674C dftcom.h : DFT_SPINDNS 5675C 5676#include "infinp.h" 5677#include "inforb.h" 5678#include "infvar.h" 5679#include "inflin.h" 5680#include "inftap.h" 5681#include "infpri.h" 5682#include "qmmm.h" 5683#include "qm3.h" 5684#include "gnrinf.h" 5685#include "orgcom.h" 5686#include "dftcom.h" 5687 5688 DIMENSION BCVEC(*), CREF(*), CMO(*) 5689 DIMENSION INDXCI(*), DV(*), DTV(NNASHX,*) 5690 DIMENSION SVEC(NVARPT,*), WRK(*) 5691 CHARACTER*8 LABINT(9*MXCENT) 5692 LOGICAL TOFILE, TRIMAT, EXP1VL, LOCDEB, FNDLAB, LPOL 5693 DIMENSION INTREP(9*MXCENT), INTADR(9*MXCENT) 5694 5695 PARAMETER ( D0 = 0.0D0 , D1 = 1.0D0 , D2 = 2.0D0 ) 5696 5697 LOCDEB = .FALSE. 5698 LPOL = .FALSE. 5699 5700 CALL QENTER('PELNC') 5701 5702 IF (IPOLTP .GT. 0) LPOL = .TRUE. 5703 5704 XSAVE = DIPORG(1) 5705 YSAVE = DIPORG(2) 5706 ZSAVE = DIPORG(3) 5707C 5708C Core allocation 5709C 5710 KUCMO = 1 5711 KFPEMO = KUCMO + NORBT*NBAST 5712 KFPEAC = KFPEMO + NNORBT 5713C ------------------------------------------- 5714 KINVMAT = KFPEAC + NNASHX 5715 KEFIELD = KINVMAT + 3*NNZAL*(3*NNZAL+1)/2 5716 KINDMOM = KEFIELD + 3*NNZAL*NCSIM 5717C ------------------------------------------- 5718 KFXC = KINDMOM + 3*NNZAL*NCSIM 5719 KFXCAC = KFXC + NCSIM*NNORBT 5720 KTFXCAC = KFXCAC + NCSIM*NNASHX 5721C ------------------------------------------- 5722 KWRK1 = KTFXCAC + NCSIM 5723 LWRK1 = LFREE - KWRK1 5724C 5725C 1. KUCMO : MO coefficients 5726C 2. KFPEMO : Fg(PE) operator mo basis 5727C 3. KFPEAC : active part of Fg(PE) 5728C ------------------------------------------ 5729C 4. KINVMAT : [alpha]^(-1) 5730C 5. KEFIELD : Electric field on MM (polarizable) 5731C sites due to F^(1) field 5732C F(tilde) = < 0 | Fel(1) | B > (for B each state) 5733C 6. KINDMOM : induced moments (from NNZAL 5734C polarizable sites) 5735C ------------------------------------------ 5736C 7. KFXC : Fxc(PE) operator 5737C 8. KFXCAC : active part of Fxc(PE) operator 5738C 9. KTFXCAC : Vector of expectation values 5739C < 0 | Fxc | B > (for B each state) 5740 5741 CALL DZERO(WRK(KUCMO),NORBT*NBAST) 5742 CALL DZERO(WRK(KFPEMO),NNORBT) 5743 CALL DZERO(WRK(KFPEAC),NNASHX) 5744 CALL DZERO(WRK(KINVMAT),3*NNZAL*(3*NNZAL+1)/2) 5745 CALL DZERO(WRK(KEFIELD),3*NNZAL*NCSIM) 5746 CALL DZERO(WRK(KINDMOM),3*NNZAL*NCSIM) 5747 CALL DZERO(WRK(KFXC),NCSIM*NNORBT) 5748 CALL DZERO(WRK(KFXCAC),NCSIM*NNASHX) 5749 CALL DZERO(WRK(KTFXCAC),NCSIM) 5750C 5751 IF (LWRK1 .LT. 0) CALL ERRWRK('PELNC',-KWRK1,LWRK1) 5752C 5753 CALL UPKCMO(CMO,WRK(KUCMO)) 5754C -------------------------------------------------------- 5755C Define FXC operator (DTV = < 0 | Fxc | B > ) 5756C -------------------------------------------------------- 5757C 5758C ---- 1) Construct B(r) response (relay) matrix ---- 5759 5760 N = 3*NNZAL 5761 5762 IF (LPOL .AND. MMMAT) THEN 5763 LUQMMM = -1 5764 IF (LUQMMM .LT. 0) THEN 5765 CALL GPOPEN(LUQMMM,'QMMMIM','UNKNOWN','SEQUENTIAL', 5766 & 'UNFORMATTED',IDUMMY,.FALSE.) 5767 ENDIF 5768 REWIND(LUQMMM) 5769 5770 IF (FNDLAB('QQMMMMAT',LUQMMM)) THEN 5771 CALL READT(LUQMMM,N*(N+1)/2,WRK(KINVMAT)) 5772 ELSE 5773 CALL QUIT('Problem reading the matrix from the QMMMIM file.') 5774 ENDIF 5775 5776 CALL GPCLOSE(LUQMMM,'KEEP') 5777 ENDIF 5778 5779C ---- 2) F^(1) operator ---- 5780 5781 IF (.NOT. LPOL) GOTO 755 5782 5783 KMATAO = KWRK1 5784 KMATMO = KMATAO + 3*NNBASX 5785 KMATAC = KMATMO + 3*NNORBT 5786 KWRK2 = KMATAC + 3*NNASHX 5787 LWRK2 = LFREE - KWRK2 5788C ----------------------------------- 5789C 1. KMATAO : F^(1) in ao basis 5790C 2. KMATMO : F^(1) in mo basis 5791C 3. KMATAC : Active part of F^(1) 5792C ----------------------------------- 5793 IF (LWRK2 .LT. 0) CALL ERRWRK('PELNC',-KWRK2,LWRK2) 5794 5795 ! index in transformed electric field vector 5796 LRI = 0 5797 5798 DO I = 1,MMCENT 5799 5800 KPATOM = 0 5801 NCOM = 3 5802 TOFILE = .FALSE. 5803 TRIMAT = .TRUE. 5804 EXP1VL = .FALSE. 5805 5806 CALL DZERO(WRK(KMATAO),3*NNBASX) 5807 CALL DZERO(WRK(KMATMO),3*NNORBT) 5808 CALL DZERO(WRK(KMATAC),3*NNASHX) 5809 5810 DIPORG(1) = MMCORD(1,I) 5811 DIPORG(2) = MMCORD(2,I) 5812 DIPORG(3) = MMCORD(3,I) 5813 5814C ---- 2.a) Get F^(1) integral ---- 5815C 1. x-coord. 2. y-coord. 3. z-coord. 5816 5817 RUNQM3 = .TRUE. 5818 CALL GET1IN(WRK(KMATAO),'NEFIELD',NCOM,WRK(KWRK2), 5819 & LWRK2,LABINT,INTREP,INTADR,I,TOFILE, 5820 & KPATOM,TRIMAT,DUMMY,EXP1VL,DUMMY,IPQMMM) 5821 RUNQM3 = .FALSE. 5822 5823 CALL UTHU(WRK(KMATAO),WRK(KMATMO),WRK(KUCMO), 5824 & WRK(KWRK2),NBAST,NORBT) 5825 CALL UTHU(WRK(KMATAO + 1*NNBASX),WRK(KMATMO + 1*NNORBT), 5826 & WRK(KUCMO),WRK(KWRK2),NBAST,NORBT) 5827 CALL UTHU(WRK(KMATAO + 2*NNBASX),WRK(KMATMO + 2*NNORBT), 5828 & WRK(KUCMO),WRK(KWRK2),NBAST,NORBT) 5829 5830 IF (NASHT .GT. 0) THEN 5831 5832 CALL GETAC2(WRK(KMATMO), 5833 & WRK(KMATAC)) 5834 CALL GETAC2(WRK(KMATMO + 1*NNORBT), 5835 & WRK(KMATAC + 1*NNASHX)) 5836 CALL GETAC2(WRK(KMATMO + 2*NNORBT), 5837 & WRK(KMATAC + 2*NNASHX)) 5838 IF (DFT_SPINDNS) CALL QUIT('PELNC: '// 5839 & 'DFT_SPINDNS not implemented here yet, sorry!') 5840 ENDIF 5841 5842C ---- 2.c ) Make F = 2 < 0 | F^(1) | B > ---- 5843C 5844 LCI = 0 5845 5846 DO ICSIM = 1,NCSIM 5847 5848 TXPE1 = SOLELM(DTV(1,ICSIM),WRK(KMATAC), 5849 & WRK(KMATMO),TXPEAC1) 5850 TXPE2 = SOLELM(DTV(1,ICSIM),WRK(KMATAC + 1*NNASHX), 5851 & WRK(KMATMO + 1*NNORBT),TXPEAC2) 5852 TXPE3 = SOLELM(DTV(1,ICSIM),WRK(KMATAC + 2*NNASHX), 5853 & WRK(KMATMO + 2*NNORBT),TXPEAC3) 5854 5855C ...To store the F(tilde) in dynamical memory, get 5856C KEFIELD x, y, z first time loop is run. Next time 5857C Set LRI + 3 to get next MM center. 5858 5859C x-value ! This is for storage of the vector 5860 WRK(KEFIELD + LRI + 0 + LCI) = TXPEAC1 ! containing the expectation value of F(tilde) 5861C y-value ! LCI is a counter for each state in 5862 WRK(KEFIELD + LRI + 1 + LCI) = TXPEAC2 ! < 0 | F(el) | B > = sum(u) < 0 | F(el) | u > 5863C z-value 5864 WRK(KEFIELD + LRI + 2 + LCI) = TXPEAC3 5865C start from x MM center of next root 5866 LCI = LCI + 3*NNZAL 5867 5868 END DO ! NCSIM 5869 5870 LRI = LRI + 3 5871 5872 END DO ! MMCENT 5873 5874C ---- make FXC = 2 B*< 0 | F^(1) | B > ---- 5875C ... Dot the KEFIELD matrix with B matrix to 5876C get mu for each | B > vector 5877 5878 DO ICSIM = 1, NCSIM 5879 5880 NDIM=3*NNZAL 5881 IF (MMMAT) THEN 5882 CALL DSPMV('L',NDIM,D1,WRK(KINVMAT), 5883 & WRK(KEFIELD + (ICSIM-1)*3*NNZAL),1,D0, 5884 & WRK(KINDMOM + (ICSIM-1)*3*NNZAL),1) 5885 ELSE IF (MMITER) THEN 5886 IOPT = 2 ! Do not read from file any previuos induced moments 5887 CALL F2QMMM(WRK(KEFIELD + 3*(ICSIM-1)*NNZAL),NDIM, 5888 & WRK(KINDMOM + 3*(ICSIM-1)*NNZAL), 5889 & WRK(KWRK2),LWRK2,IOPT,IPQMMM) 5890 ENDIF 5891 5892 END DO ! ICSIM 5893 5894C ---- 3) Make F(el) and daxpy first x, then y and then z ---- 5895C (for each CI B vector) 5896 5897 LRI = 0 5898 5899 DO I = 1, MMCENT 5900 5901 DIPORG(1) = MMCORD(1,I) 5902 DIPORG(2) = MMCORD(2,I) 5903 DIPORG(3) = MMCORD(3,I) 5904 5905 CALL DZERO(WRK(KMATAO),3*NNBASX) 5906 CALL DZERO(WRK(KMATMO),3*NNORBT) 5907 CALL DZERO(WRK(KMATAC),3*NNASHX) 5908 5909C ---- 3.a) F^(1) operator ---- 5910 5911 RUNQM3 = .TRUE. 5912 CALL GET1IN(WRK(KMATAO),'NEFIELD',NCOM,WRK(KWRK2), 5913 & LWRK2,LABINT,INTREP,INTADR,I,TOFILE, 5914 & KPATOM,TRIMAT,DUMMY,EXP1VL,DUMMY,IPQMMM) 5915 RUNQM3 = .FALSE. 5916 5917 CALL UTHU(WRK(KMATAO),WRK(KMATMO),WRK(KUCMO), 5918 & WRK(KWRK2),NBAST,NORBT) 5919 CALL UTHU(WRK(KMATAO + 1*NNBASX),WRK(KMATMO + 1*NNORBT), 5920 & WRK(KUCMO),WRK(KWRK2),NBAST,NORBT) 5921 CALL UTHU(WRK(KMATAO + 2*NNBASX),WRK(KMATMO + 2*NNORBT), 5922 & WRK(KUCMO),WRK(KWRK2),NBAST,NORBT) 5923 5924C --- 3.b) Add B*<0|F^(1)|B> to F^(1) operator ---- 5925 5926 LCI = 0 ! alternative set LCI = 3*NNZAL*(ICSIM-1) 5927 5928 DO ICSIM = 1,NCSIM 5929 FACx = -WRK(KINDMOM + LRI + 0 + LCI) 5930 5931 CALL DAXPY(NNORBT,FACx,WRK(KMATMO),1, 5932 & WRK(KFXC + (ICSIM-1)*NNORBT),1) 5933 5934 FACy = -WRK(KINDMOM + LRI + 1 + LCI) 5935 5936 CALL DAXPY(NNORBT,FACy,WRK(KMATMO + 1*NNORBT),1, 5937 & WRK(KFXC + (ICSIM-1)*NNORBT),1) 5938 5939 FACz = -WRK(KINDMOM + LRI + 2 + LCI) 5940 5941 CALL DAXPY(NNORBT,FACz,WRK(KMATMO + 2*NNORBT),1, 5942 & WRK(KFXC + (ICSIM-1)*NNORBT),1) 5943 5944 IF (NASHT .GT. 0) THEN 5945 CALL GETAC2(WRK(KFXC + (ICSIM-1)*NNORBT), 5946 & WRK(KFXCAC + (ICSIM-1)*NNASHX)) 5947 IF (DFT_SPINDNS) CALL QUIT('PELNC: '// 5948 & 'DFT_SPINDNS not implemented here yet, sorry!') 5949 END IF 5950 5951 LCI = LCI + 3*NNZAL 5952 END DO 5953 LRI = LRI + 3 5954 END DO 5955 5956 DO ICSIM = 1,NCSIM 5957 TFXC = SOLELM(DV,WRK(KFXCAC + (ICSIM-1)*NNASHX), 5958 & WRK(KFXC + (ICSIM-1)*NNORBT),TFXCAC) 5959 WRK(KTFXCAC-1+ICSIM) = TFXCAC 5960 END DO 5961 5962 755 CONTINUE ! IF LPOL 5963 5964 CALL PEFCMO(WRK(KUCMO),WRK(KFPEMO),DV,WRK(KWRK1),LWRK1,IPQMMM) 5965 5966 IF (NASHT .GT. 0) THEN 5967 CALL GETAC2(WRK(KFPEMO),WRK(KFPEAC)) 5968 IF (DFT_SPINDNS) CALL QUIT('PELNC: '// 5969 & 'DFT_SPINDNS not implemented here yet, sorry!') 5970 END IF 5971 5972 TFPEMO = SOLELM(DV,WRK(KFPEAC),WRK(KFPEMO),TFPEAC) 5973C 5974C ----Write statements for debugging ---- 5975 IF ( (IPQMMM .GE. 15) .OR. (LOCDEB) ) THEN 5976 WRITE (LUPRI,'(A,F17.8)') 5977 * ' --- FPE expectation value MO :',TFPEMO 5978 WRITE (LUPRI,'(A,F17.8)') 5979 * ' --- active part of FPE :',TFPEAC 5980 5981 WRITE (LUPRI,'(/A)') ' F(PE)_mo matrix in PELNC:' 5982 CALL OUTPAK(WRK(KFPEMO), NORBT,1,LUPRI) 5983 IF (NASHT .GT. 0) THEN 5984 WRITE (LUPRI,'(/A)') ' F(PE)_ac matrix in PELNC:' 5985 CALL OUTPAK(WRK(KFPEAC),NASHT,1,LUPRI) 5986 END IF 5987 END IF 5988C --------------------------------------- 5989C 5990C ...CSF part of sigma vectors 5991 5992 CALL SOLSC(NCSIM,0,BCVEC,CREF,SVEC,WRK(KFXCAC),WRK(KFPEAC), ! KRYCAC = KFPEAC (i.e. KRYC = KFPEMO) 5993 * WRK(KTFXCAC),TFPEAC,INDXCI,WRK(KWRK1),LWRK1) ! KRXCAC = KFXCAC (i.e. KRXC = KFXC ) 5994 5995 IF (NWOPPT .GT. 0) THEN 5996 MWOPH = NWOPH 5997 NWOPH = NWOPPT 5998C ... tell SOLGO only to use the NWOPPT first JWOP entries 5999 JSVECO = 1 + NCONST 6000 JFXC = KFXC 6001 DO ICSIM = 1,NCSIM 6002 IF (LPOL) CALL SOLGO(D2,DV,WRK(JFXC),SVEC(JSVECO,ICSIM)) 6003 IF ( (IPQMMM .GE. 15) .OR. (LOCDEB) ) THEN 6004 WRITE(LUPRI,*) 6005 * ' orbital part of LINEAR TRANSFORMED CONF VEC No',ICSIM 6006 WRITE(LUPRI,*)' Fxc(PE) CONTRIBUTION' 6007 CALL OUTPUT(SVEC(JSVECO,ICSIM),1,NWOPPT,1,1, 6008 * NWOPPT,1,1,LUPRI) 6009 END IF 6010 CALL SOLGO(D0,DTV(1,ICSIM),WRK(KFPEMO),SVEC(JSVECO,ICSIM)) 6011 IF ( (IPQMMM .GE. 15) .OR. (LOCDEB) ) THEN 6012 WRITE(LUPRI,*) 6013 * ' orbital part of LINEAR TRANSFORMED CONF VEC No',ICSIM 6014 WRITE(LUPRI,*)' + Fg(PE) CONTRIBUTION' 6015 CALL OUTPUT(SVEC(JSVECO,ICSIM),1,NWOPPT,1,1, 6016 * NWOPPT,1,1,LUPRI) 6017 END IF 6018 JFXC = JFXC + NNORBT 6019 END DO 6020 NWOPH = MWOPH 6021 END IF 6022 6023C ...Restore the dipole origin. 6024 6025 DIPORG(1) = XSAVE 6026 DIPORG(1) = YSAVE 6027 DIPORG(1) = ZSAVE 6028 6029 CALL QEXIT('PELNC') 6030 RETURN 6031 END 6032C end of pelnc. 6033 6034 SUBROUTINE PELNO(NOSIM,BOVECS,CREF,CMO,INDXCI, 6035 * DV,SVEC,NSVEC,WRK,LFREE) 6036C 6037C Erik Donovan Hedegaard jan. 2012 6038C after original code by Hans Jorgen Aa. Jensen 6039C 6040C Purpose: Calculate MCSCF Hessian contribution from a 6041C surrounding PE medium to an orbital trial vector. 6042C 6043C NSVEC may be NVAR or NWOPT, dependent on LINTRN 6044C 6045#include "implicit.h" 6046#include "priunit.h" 6047#include "dummy.h" 6048#include "iratdef.h" 6049#include "maxash.h" 6050#include "maxorb.h" 6051#include "mxcent.h" 6052#include "infinp.h" 6053#include "orgcom.h" 6054#include "inforb.h" 6055#include "infvar.h" 6056#include "inflin.h" 6057#include "inftap.h" 6058#include "qmmm.h" 6059#include "qm3.h" 6060#include "dftcom.h" 6061#include "gnrinf.h" 6062C 6063C Used from common blocks: 6064C INFORB : NNASHX, NNORBX, NNBASX, etc. 6065C INFVAR : JWOP 6066C INFLIN : NWOPPT, NVARPT, NCONST, NCONRF 6067C dftcom.h : DFT_SPINDNS 6068C 6069 DIMENSION BOVECS(NWOPPT,*), CREF(*), CMO(*) 6070 DIMENSION INDXCI(*), DV(*) 6071 DIMENSION SVEC(NSVEC,*), WRK(*) 6072 LOGICAL FULHES, TOFILE, TRIMAT, EXP1VL, LOCDEB, FNDLAB, LPOL 6073 6074 CHARACTER*8 LABINT(9*MXCENT) 6075 DIMENSION INTREP(9*MXCENT), INTADR(9*MXCENT) 6076C 6077 DOUBLE PRECISION D0, D2, D1, DP5 6078 PARAMETER ( D0 = 0.0D0 , D1 = 1.0D0, D2 = 2.0D0, DP5 = 0.5D0 ) 6079 6080 LOCDEB = .FALSE. 6081 LPOL = .FALSE. 6082 6083 CALL QENTER('PELNO') 6084 6085C Determine if full Hessian or only orbital Hessian 6086C 6087 FULHES = (NSVEC .EQ. NVARPT) 6088 6089 IF (IPOLTP .GT. 0) LPOL = .TRUE. 6090 6091 IF (FULHES) THEN 6092 JSOVEC = 1 + NCONST 6093 ELSE 6094 JSOVEC = 1 6095 END IF 6096C 6097C ************************************************************* 6098C ************************************************************* 6099 6100 IF ( (IPQMMM .GE. 15) .OR. (LOCDEB) ) THEN 6101 WRITE (LUPRI,'(//A)') ' --- TEST OUTPUT FROM PELNO ---' 6102 END IF 6103 IF ( (IPQMMM .GE. 15) .OR. (LOCDEB) ) THEN 6104 IF (FULHES) THEN 6105 WRITE (LUPRI,'(/A)') ' --- PELNO - svec(ci,1) on entry' 6106 DO 30 I = 1,NCONST 6107 IF (SVEC(I,1) .NE. D0) WRITE (LUPRI,'(A,I10,F15.10)') 6108 * ' conf #',I,SVEC(I,1) 6109 30 CONTINUE 6110 END IF 6111 WRITE (LUPRI,'(/A)') ' --- PELNO - svec(orb) on entry' 6112 CALL OUTPUT(SVEC(JSOVEC,1),1,NWOPPT,1,NOSIM, 6113 * NSVEC,NOSIM,1,LUPRI) 6114 END IF 6115 6116C ************************************************************* 6117C ************************************************************* 6118 6119C ...Save the dipole origin 6120 6121 XSAVE = DIPORG(1) 6122 YSAVE = DIPORG(2) 6123 ZSAVE = DIPORG(3) 6124C 6125C Core allocation 6126C 6127 KUCMO = 1 6128 KUBO = KUCMO + NORBT*NBAST 6129C ------------------------------------------ 6130 KINVMAT = KUBO + NOSIM*N2ORBX 6131 KINDMOM = KINVMAT + 3*NNZAL*(3*NNZAL+1)/2 6132 KEFIEX = KINDMOM + 3*NOSIM*NNZAL 6133C ------------------------------------------ 6134 KFXO = KEFIEX + 3*NOSIM*NNZAL 6135 KFPEMO = KFXO + NNORBT*NOSIM 6136 KFPESQ = KFPEMO + NNORBX 6137 KFPXSQ = KFPESQ + N2ORBX 6138 KFPX = KFPXSQ + N2ORBX 6139 KFPXAC = KFPX + NOSIM*NNORBX 6140C ----------------------------------------- 6141 KFXYOA = KFPXAC + NOSIM*NNASHX 6142 KWRK1 = KFXYOA + NOSIM 6143 LWRK1 = LFREE - KWRK1 6144 6145 CALL DZERO(WRK(KUCMO),NORBT*NBAST) 6146 CALL DZERO(WRK(KUBO),NOSIM*N2ORBX) 6147 CALL DZERO(WRK(KINVMAT), 3*NNZAL*(3*NNZAL+1)/2) 6148 CALL DZERO(WRK(KINDMOM), 3*NOSIM*NNZAL) 6149 CALL DZERO(WRK(KEFIEX), 3*NOSIM*NNZAL) 6150 CALL DZERO(WRK(KFXO), NNORBT*NOSIM) 6151 CALL DZERO(WRK(KFPEMO), NNORBX) 6152 CALL DZERO(WRK(KFPESQ), N2ORBX) 6153 CALL DZERO(WRK(KFPXSQ), N2ORBX) 6154 CALL DZERO(WRK(KFPX),NOSIM*NNORBX) 6155 CALL DZERO(WRK(KFPXAC),NOSIM*NNASHX) 6156 CALL DZERO(WRK(KFXYOA),NOSIM) 6157 6158 IF (LWRK1 .LT. 0) CALL ERRWRK('PELNO',-KWRK1,LWRK1) 6159C 6160C Unpack symmetry blocked CMO 6161C 6162 CALL UPKCMO(CMO,WRK(KUCMO)) 6163C 6164C Calculate unpacked orbital trial vectors in UBO 6165C 6166 IF (NOSIM.GT.0) THEN 6167 DO IOSIM = 1,NOSIM 6168 JUBO = KUBO + (IOSIM-1)*N2ORBX 6169 CALL UPKWOP(NWOPPT,JWOP,BOVECS(1,IOSIM),WRK(JUBO)) 6170 IF ( (IPQMMM .GE. 15) .OR. (LOCDEB) ) THEN 6171 WRITE (LUPRI,*) IOSIM,NOSIM 6172 CALL OUTPUT(WRK(JUBO),1,NORBT,1,NORBT,NORBT,NORBT,1, 6173 & LUPRI) 6174 END IF 6175 END DO 6176 END IF 6177 6178 IF (.NOT. LPOL) GOTO 755 6179 6180C 1) Read B(r) response (Relay) matrix from file. 6181 6182 IF ( (LPOL) .AND. (MMMAT) ) THEN 6183 N = 3*NNZAL 6184 LUQMMM = -1 6185 CALL GPOPEN(LUQMMM,'QMMMIM','UNKNOWN','SEQUENTIAL', 6186 & 'UNFORMATTED',IDUMMY,.FALSE.) 6187 REWIND(LUQMMM) 6188 6189 IF (FNDLAB('QQMMMMAT',LUQMMM)) THEN 6190 CALL READT(LUQMMM,N*(N+1)/2,WRK(KINVMAT)) 6191 ELSE 6192 CALL QUIT('Problem reading the matrix from the QMMMIM file.') 6193 ENDIF 6194 6195 CALL GPCLOSE(LUQMMM,'KEEP') 6196 6197 ENDIF 6198 6199 KPATOM = 0 6200 NCOM = 3 ! edh: sometimes called NOSIM but denoted NCOM here 6201 TOFILE = .FALSE. 6202 TRIMAT = .TRUE. 6203 EXP1VL = .FALSE. 6204 6205C 2) Construct Fxo(PE) = B(r) * < 0 | f^(1)el | 0 > ; f(1)el is one-index transformed F(1)el 6206 6207C .. memory allocation for field matrix and one-electron transform. 6208 6209 KMTAO = KWRK1 6210 KMTMO = KMTAO + 3*NNBASX 6211 KMTSQ = KMTMO + 3*NNORBT 6212 KMTXSQ = KMTSQ + 3*N2ORBX 6213 KMTX = KMTXSQ + 3*N2ORBX 6214 KMTXAC = KMTX + 3*NOSIM*NNORBX 6215 KWRK2 = KMTXAC + 3*NOSIM*NNASHX 6216 LWRK2 = LFREE - KWRK2 6217 6218C 1. KMTAO ("KMAT") : QM dipole one-elctron integrals (F^(1) in ao basis) 6219C 2. KMTMO - : QM dipole one-elctron integrals (mo basis) 6220C 3. KMTSQ - : Unpacked F^(1) (needed for one-index transform) 6221C 4. KMTXSQ - : One-index transformed F^(1)el ( = f^(1)el ) 6222C 5. KMTX - : f^(1)el triangular packed 6223C 6. KMTXAC - : Active part of f^(1)el 6224 6225 CALL DZERO(WRK(KMTAO),3*NNBASX) 6226 CALL DZERO(WRK(KMTMO),3*NNORBT) 6227 CALL DZERO(WRK(KMTSQ),3*N2ORBX) 6228 CALL DZERO(WRK(KMTXSQ),3*N2ORBX) 6229 CALL DZERO(WRK(KMTX),3*NOSIM*NNORBX) 6230 CALL DZERO(WRK(KMTXAC),3*NOSIM*NNASHX) 6231 6232 IF (LWRK2 .LT. 0) CALL ERRWRK('PELNO',-KWRK2,LWRK2) 6233 6234 LRI = 0 ! counter for index in one-index transformed electric field vector 6235 6236 DO I = 1,MMCENT 6237 6238 DIPORG(1) = MMCORD(1,I) 6239 DIPORG(2) = MMCORD(2,I) 6240 DIPORG(3) = MMCORD(3,I) 6241 6242C 2.a Dipole one-electron integrals (Fel(1) operator in AO basis) 6243C ...Get F^(1)el integral: 1) x-coord. 2) y-coord. 3) z-coord. 6244 6245 RUNQM3 = .TRUE. 6246 6247 CALL GET1IN(WRK(KMTAO),'NEFIELD',NCOM,WRK(KWRK2), 6248 & LWRK2,LABINT,INTREP,INTADR,I,TOFILE, 6249 & KPATOM,TRIMAT,DUMMY,EXP1VL,DUMMY,IPQMMM) 6250 6251 RUNQM3 = .FALSE. 6252 6253 6254c WRITE(LUPRI,*) 'x-coord: Fel(1) operator in AO basis' 6255c CALL OUTPAK(WRK(KMTAO),NBAST,1,LUPRI) 6256c WRITE(LUPRI,*) 'y-coord Fel(1) operator in AO basis' 6257c CALL OUTPAK(WRK(KMTAO+NNBASX),NBAST,1,LUPRI) 6258c WRITE(LUPRI,*) 'z-coord Fel(1) operator in AO basis' 6259c CALL OUTPAK(WRK(KMTAO+2*NNBASX),NBAST,1,LUPRI) 6260 6261C 2.b Dipole one-electron integrals (F^(1)el operator in MO basis) 6262 6263 CALL UTHU(WRK(KMTAO),WRK(KMTMO),WRK(KUCMO), 6264 & WRK(KWRK2),NBAST,NORBT) 6265 6266 CALL UTHU(WRK(KMTAO + 1*NNBASX),WRK(KMTMO + 1*NNORBT), 6267 & WRK(KUCMO),WRK(KWRK2),NBAST,NORBT) 6268 6269 CALL UTHU(WRK(KMTAO + 2*NNBASX),WRK(KMTMO + 2*NNORBT), 6270 & WRK(KUCMO),WRK(KWRK2),NBAST,NORBT) 6271 6272c WRITE(LUPRI,*) 'x-coord: Fel(1) operator in MO basis' 6273c CALL OUTPAK(WRK(KMTMO),NORBT,1,LUPRI) 6274c WRITE(LUPRI,*) 'y-coord Fel(1) operator in MO basis' 6275c CALL OUTPAK(WRK(KMTMO+NNORBT),NORBT,1,LUPRI) 6276c WRITE(LUPRI,*) 'z-coord Fel(1) operator in MO basis' 6277c CALL OUTPAK(WRK(KMTMO+2*NNORBT),NORBT,1,LUPRI) 6278 6279C 2.c F^(1)el from packed (triangular) to unpacked (square) 6280 6281 CALL DSPTSI(NORBT,WRK(KMTMO),WRK(KMTSQ)) 6282 6283 CALL DSPTSI(NORBT,WRK(KMTMO + 1*NNORBT), 6284 & WRK(KMTSQ + 1*N2ORBX)) 6285 6286 CALL DSPTSI(NORBT,WRK(KMTMO + 2*NNORBT), 6287 & WRK(KMTSQ + 2*N2ORBX)) 6288 6289 6290c WRITE(LUPRI,*) 'x-coord: Square Fel(1) operator' 6291c CALL OUTPUT(WRK(KMTSQ),1,NORBT, 6292c & 1,NORBT,NORBT,NORBT,1,LUPRI) 6293c WRITE(LUPRI,*) 'y-coord: Square Fel(1) operator' 6294c CALL OUTPUT(WRK(KMTSQ + 1*N2ORBX),1,NORBT, 6295c & 1,NORBT,NORBT,NORBT,1,LUPRI) 6296c WRITE(LUPRI,*) 'z-coord: Square Fel(1) operator' 6297c CALL OUTPUT(WRK(KMTSQ + 2*N2ORBX),1,NORBT, 6298c & 1,NORBT,NORBT,NORBT,1,LUPRI) 6299 6300 DO IOSIM = 1, NOSIM 6301 6302 JUBO = KUBO + (IOSIM - 1) * N2ORBX ! Unpacked orbital trial vectors 6303 JMTX = KMTX + 3 * (IOSIM - 1) * NNORBX ! F^(1) for each orb. trial vector 6304 JMTXAC = KMTXAC + 3 * (IOSIM - 1) * NNASHX ! - active part 6305 6306 CALL DZERO(WRK(KMTXSQ),3*N2ORBX) 6307 6308 CALL TR1UH1(WRK(JUBO),WRK(KMTSQ), ! **** x component **** 6309 & WRK(KMTXSQ),1) ! one index transform F^(1)el to f^(1)el 6310 6311 CALL DGETSP(NORBT,WRK(KMTXSQ), ! pack (triangular) f^(1)el 6312 & WRK(JMTX)) 6313 6314 CALL TR1UH1(WRK(JUBO),WRK(KMTSQ + 1*N2ORBX), ! **** y component **** 6315 & WRK(KMTXSQ + 1*N2ORBX),1) ! one index transform F^(1) to f^(1) 6316 6317 CALL DGETSP(NORBT,WRK(KMTXSQ + 1*N2ORBX), ! pack (triangular) f^(1) 6318 & WRK(JMTX + 1*NNORBX)) 6319 6320 6321 CALL TR1UH1(WRK(JUBO),WRK(KMTSQ + 2*N2ORBX), ! **** z component **** 6322 & WRK(KMTXSQ + 2*N2ORBX),1) ! one index transform F^(1) to f^(1) z 6323 6324 CALL DGETSP(NORBT,WRK(KMTXSQ + 2*N2ORBX), ! pack (triangular) f^(1) 6325 & WRK(JMTX + 2*NNORBX)) 6326 6327 6328 IF (NASHT .GT. 0) THEN 6329 CALL GETAC2(WRK(JMTX),WRK(JMTXAC)) 6330 CALL GETAC2(WRK(JMTX + 1*NNORBX),WRK(JMTXAC + 1*NNASHX)) 6331 CALL GETAC2(WRK(JMTX + 2*NNORBX),WRK(JMTXAC + 2*NNASHX)) 6332 IF (DFT_SPINDNS) CALL QUIT('PELNO: '// 6333 & 'DFT_SPINDNS not implemented here yet, sorry!') 6334 END IF 6335 6336C ... Calculate < 0 | f^(1) | 0 > 6337 6338 TFX1 = SOLELM(DV,WRK(JMTXAC), 6339 & WRK(JMTX),TFXAC1) 6340 TFX2 = SOLELM(DV,WRK(JMTXAC + 1*NNASHX), 6341 & WRK(JMTX + 1*NNORBX),TFXAC2) 6342 TFX3 = SOLELM(DV,WRK(JMTXAC + 2*NNASHX), 6343 & WRK(JMTX + 2*NNORBX),TFXAC3) 6344 6345C **** x-component **** 6346 WRK(KEFIEX + 3*NNZAL*(IOSIM - 1) + LRI + 0) = TFX1 6347C **** y-component **** 6348 WRK(KEFIEX + 3*NNZAL*(IOSIM - 1) + LRI + 1) = TFX2 6349C **** z-component **** 6350 WRK(KEFIEX + 3*NNZAL*(IOSIM - 1) + LRI + 2) = TFX3 6351C ... start from x of the next MM center 6352 6353 END DO ! NOSIM 6354 6355 LRI = LRI + 3 6356 6357 END DO ! MMCENT 6358 6359C ... and calculate the one-index transformed 6360C induced moment: u = B * < 0 | f^(1) | 0 > 6361 6362 6363 DO IOSIM = 1, NOSIM 6364 6365 IF (IPOLTP .GT. 0) THEN 6366 IF (MMMAT) THEN 6367 CALL DSPMV('L',3*NNZAL,D1,WRK(KINVMAT), ! edh: note KINVMAT is a lower triangular matrix 6368 & WRK(KEFIEX + 3*(IOSIM - 1)*NNZAL),1,D0, 6369 & WRK(KINDMOM + 3*(IOSIM-1)*NNZAL),1) 6370 ELSE IF (MMITER) THEN 6371 IOPT = 2 ! Do not read from file any previuos induced moments 6372 CALL F2QMMM(WRK(KEFIEX + 3*(IOSIM - 1)*NNZAL),NNZAL, 6373 & WRK(KINDMOM + 3*(IOSIM-1)*NNZAL), 6374 & WRK(KWRK2),LWRK2,IOPT,IPQMMM) 6375 ENDIF 6376 END IF 6377 END DO 6378 6379 6380C 3) Make F^(1)el and daxpy to get one-index transformed u; first x, then y and then z 6381C 6382 LRI = 0 6383 6384 DO I = 1, MMCENT 6385 6386 DIPORG(1) = MMCORD(1,I) 6387 DIPORG(2) = MMCORD(2,I) 6388 DIPORG(3) = MMCORD(3,I) 6389 6390 CALL DZERO(WRK(KMTAO),3*NNBASX) 6391 CALL DZERO(WRK(KMTMO),3*NNORBT) 6392 6393C 3.a) F^(1)el operator in AO basis 6394 6395 RUNQM3 = .TRUE. 6396 6397 CALL GET1IN(WRK(KMTAO),'NEFIELD',NCOM,WRK(KWRK2), 6398 & LWRK2,LABINT,INTREP,INTADR,I,TOFILE, 6399 & KPATOM,TRIMAT,DUMMY,EXP1VL,DUMMY,IPQMMM) 6400 6401 RUNQM3 = .FALSE. 6402 6403C 3.b) Dipole one-electron integrals (F^(1)el operator in MO basis) 6404 6405 CALL UTHU(WRK(KMTAO),WRK(KMTMO),WRK(KUCMO), 6406 & WRK(KWRK2),NBAST,NORBT) 6407 6408 CALL UTHU(WRK(KMTAO + 1*NNBASX),WRK(KMTMO + 1*NNORBT), 6409 & WRK(KUCMO),WRK(KWRK2),NBAST,NORBT) 6410 6411 CALL UTHU(WRK(KMTAO + 2*NNBASX),WRK(KMTMO + 2*NNORBT), 6412 & WRK(KUCMO),WRK(KWRK2),NBAST,NORBT) 6413 6414 DO IOSIM = 1, NOSIM 6415 6416 FACx = -WRK(KINDMOM + LRI + 0 + 3*NNZAL*(IOSIM-1)) 6417 6418 CALL DAXPY(NNORBT,FACx,WRK(KMTMO),1, 6419 & WRK(KFXO+(IOSIM-1)*NNORBT),1) 6420 6421 FACy = -WRK(KINDMOM + LRI + 1 + 3*NNZAL*(IOSIM-1)) 6422 6423 CALL DAXPY(NNORBT,FACy,WRK(KMTMO + 1*NNORBT),1, 6424 & WRK(KFXO+(IOSIM-1)*NNORBT),1) 6425 6426 FACz = -WRK(KINDMOM + LRI + 2 + 3*NNZAL*(IOSIM-1)) 6427 6428 CALL DAXPY(NNORBT,FACz,WRK(KMTMO+2*NNORBT),1, 6429 & WRK(KFXO+(IOSIM-1)*NNORBT),1) 6430 6431 END DO 6432 6433 LRI = LRI + 3 6434 6435 END DO 6436 6437C Construct Fyo(PE) (corresponds to Fg(PE) one-index transformed) 6438 6439 755 CONTINUE ! .NOT. LPOL 6440 6441 CALL PEFCMO(WRK(KUCMO),WRK(KFPEMO),DV,WRK(KWRK1),LWRK1,IPQMMM) 6442 6443 CALL DSPTSI(NORBT,WRK(KFPEMO),WRK(KFPESQ)) 6444 6445 DO IOSIM = 1, NOSIM 6446 6447 JUBO = KUBO + (IOSIM - 1) * N2ORBX ! Unpacked orbital trial vectors 6448 JFPX = KFPX + (IOSIM - 1) * NNORBX ! KFPX = Fyo(PE) 6449 JFPXAC = KFPXAC + (IOSIM - 1) * NNASHX ! - active part 6450 6451 JTEST = KFXO + (IOSIM - 1) * NNORBX 6452 6453 CALL DZERO(WRK(KFPXSQ),N2ORBX) 6454 CALL DZERO(WRK(JFPX),NNORBX) 6455 CALL DZERO(WRK(JFPXAC),NNASHX) 6456 6457 CALL TR1UH1(WRK(JUBO),WRK(KFPESQ),WRK(KFPXSQ),1) 6458 6459 CALL DGETSP(NORBT,WRK(KFPXSQ),WRK(JFPX)) 6460 6461 IF (LPOL) CALL DAXPY(NNORBX,D1,WRK(JTEST),1,WRK(JFPX),1) ! Adds Fxo to Fyo when there are polarization contr. 6462 6463 IF (NASHT .GT. 0) THEN ! active part of f(PE)g operator (equivalent to Tg = Ryo in RFSCF) 6464 CALL GETAC2(WRK(JFPX),WRK(JFPXAC)) 6465 IF (DFT_SPINDNS) CALL QUIT('PELNO: '// 6466 & 'DFT_SPINDNS not implemented here yet, sorry!') 6467 END IF 6468 6469 FXYO = SOLELM(DV,WRK(JFPXAC),WRK(JFPX),FXYOA) 6470 6471 WRK(KFXYOA + (IOSIM-1)) = FXYOA 6472 6473 END DO 6474 6475C ... CSF part of sigma vectors 6476 6477 IF (LSYMRF .EQ. LSYMST) THEN 6478 NCOLIM = 1 6479 ELSE 6480 NCOLIM = 0 6481 END IF 6482 IF (FULHES .AND. NCONST .GT. NCOLIM) THEN 6483 6484 CALL SOLSC(0,NOSIM,DUMMY,CREF,SVEC,WRK(KFPXAC),DUMMY, 6485 & 100.D0*(WRK(KFXYOA)),DUMMY,INDXCI,WRK(KWRK1),LWRK1) 6486 END IF 6487 6488C ... orbital part of sigma vectors 6489 6490 MWOPH = NWOPH 6491 NWOPH = NWOPPT 6492C ... tell SOLGO only to use the NWOPPT first JWOP entries 6493 DO IOSIM = 1,NOSIM 6494 JFPX = KFPX + (IOSIM-1)*NNORBX 6495 CALL SOLGO(D2,DV,WRK(JFPX),SVEC(JSOVEC,IOSIM)) 6496 END DO 6497 NWOPH = MWOPH 6498 6499C ...Restore the dipole origin. 6500 6501 DIPORG(1) = XSAVE 6502 DIPORG(1) = YSAVE 6503 DIPORG(1) = ZSAVE 6504 6505 CALL QEXIT('PELNO') 6506 RETURN 6507C ... end of pelno. 6508 END 6509! -- end of sirqmmm.F -- 6510