1#if defined(CAFE_POLARIZATION) 2 subroutine cf_fpww(xw,xwm,fw,pw,pwp,idt,iwfrom,nwloc,lpbc,eww, 3 + vdw,chg,iwatm,iwq,lwwndx,lwwjpt,lwwin,lwwj, 4 + xi,xj,rwx,rwi1,rwi2,rwi6,rwc, 5 + f,fi,fj,facu,pl,pj) 6#elif defined(CAFE_FORCES) 7 subroutine cf_fww(xw,xwm,fw,idt,iwfrom,nwloc,lpbc,eww, 8 + vdw,chg,iwatm,iwq,lwwndx,lwwjpt,lwwin,lwwj, 9 + xi,xj,rwx,rwi1,rwi2,rwi6,rwc, 10 + f,fi,fj,facu) 11c,rdf,ngt,iagc,jagc,igrc,u,uwmw) 12#else 13c error 14#endif 15c 16c $Id$ 17c 18 implicit none 19c 20#include "cf_common.fh" 21#include "cf_funcs_dec.fh" 22#include "bitops_decls.fh" 23c 24 real*8 xw(mwm,3,mwa),xwm(mwm,3),fw(mwm,3,mwa,2),eww(mpe,2) 25 integer idt(mwm) 26 integer iwfrom,nwloc 27 logical lpbc 28c 29 real*8 vdw(mat,mat,map,mset),chg(mqt,mqp,mset) 30 integer iwatm(mwa),iwq(mwa) 31c 32 real*8 xi(mscr,3,mwa),xj(mscr,3,mwa),rwx(mscr,3) 33 real*8 rwi1(mscr),rwi2(mscr),rwi6(mscr),rwc(mscr,3) 34 real*8 f(mscr),fi(mscr,3,mwa),fj(mscr,3,mwa) 35c 36 real*8 facu(mscr) 37c real*8 rdf(mgl,mgr) 38c 39 integer lwwj(*) 40 integer lwwndx(0:mwm,2),lwwjpt(nwloc,2),lwwin(nwloc,2) 41c 42#if defined(CAFE_POLARIZATION) 43 real*8 pw(mwm,3,mwa,2),pwp(mwm,3,mwa,2,2) 44 real*8 pl(mscr,3,mwa),pj(mscr,3,mwa) 45c integer nax2,ipset 46 real*8 qai,qaj,pai,paj,pix,piy,piz,pjx,pjy,pjz 47 real*8 ri3,rmi,rmj,fri,fmi,fmj,rmm,qfaci 48 real*8 rx,ry,rz,ri1,ri2,ewwpsm,etermp 49#else 50 real*8 ferfc,fderfc 51 real*8 boxi(3),dx,ri1,ri2,ri6,eq,e6,e12,ff,df,xix,xiy,xiz,fact 52 real*8 rx,ry,rz,er,p2qi,p3qi,dqi 53 integer iw,inum,ix,jnum,jwm 54 logical lid,ljd 55#endif 56 real*8 ewwqsm 57c 58 integer iwfr,ipww,number,iwm,iwpm,nax 59 integer iwmn,lwwptr,iwa,iax,jwa,iptr,jptr,iwpj 60 real*8 ewwl6,ewwl12,q 61 real*8 c64,c124,qi,qj,qi4,qj4,dercon 62 real*8 c6p,c12p,qp,ep2tmp,ep3tmp 63 real*8 c6,cf6,c12,cf12 64c 65 integer nwwlen(2) 66 real*8 eterml,etermq 67c 68#include "cf_funcs_sfn.fh" 69#include "bitops_funcs.fh" 70c 71cx new stuff begin 72c 73#if !defined(CAFE_POLARIZATION) 74c 75 iwfr=iwfrom-1 76 boxi(1)=one/box(1) 77 boxi(2)=one/box(2) 78 boxi(3)=one/box(3) 79c if(npbtyp.eq.1.and.nbxtyp.eq.0.and.icntrl.eq.2) then 80 if(nbxtyp.eq.0.and.icntrl.eq.2) then 81 do 101 ipww=1,npww 82 do 102 iw=1,nwloc 83 iwm=iwfr+iw 84 inum=lwwjpt(iw,ipww)-1 85 lid=iand(idt(iwm),mdynam).eq.ldynam 86c 87 if(lpbc) then 88 do 104 ix=1,3 89 do 103 jnum=1,lwwin(iw,ipww) 90 jwm=lwwj(inum+jnum) 91 dx=xwm(iwm,ix)-xwm(jwm,ix) 92 rwc(jwm,ix)=dx 93 if(abs(dx).gt.boxh(ix)) then 94 rwx(jwm,ix)=anint(dx*boxi(ix))*box(ix) 95 rwc(jwm,ix)=dx-rwx(jwm,ix) 96 else 97 rwx(jwm,ix)=zero 98 rwc(jwm,ix)=xwm(iwm,ix)-xwm(jwm,ix) 99 endif 100 103 continue 101 104 continue 102 else 103 do 1103 ix=1,3 104 do 1104 jnum=1,lwwin(iw,ipww) 105 jwm=lwwj(inum+jnum) 106 rwx(jwm,ix)=zero 107 dx=xwm(iwm,ix)-xwm(jwm,ix) 108 rwc(jwm,ix)=dx 109 1104 continue 110 1103 continue 111 endif 112c 113 if(.not.ithint.and..not.ipert2.and..not.ipert3) then 114 do 105 iwa=1,nwa 115 qi=chg(iwq(iwa),1,iset) 116 iptr=iwatm(iwa) 117 xix=xw(iwm,1,iwa) 118 xiy=xw(iwm,2,iwa) 119 xiz=xw(iwm,3,iwa) 120 do 106 jwa=1,nwa 121 q=qi*chg(iwq(jwa),1,iset) 122 c6=vdw(iptr,iwatm(jwa),1,iset) 123 c12=vdw(iptr,iwatm(jwa),3,iset) 124 cf6=six*c6 125 cf12=twelve*c12 126 eq=zero 127 e6=zero 128 e12=zero 129 if(ipme.eq.0) then 130 do 107 jnum=1,lwwin(iw,ipww) 131 jwm=lwwj(inum+jnum) 132 ljd=iand(idt(jwm),mdynam).eq.ldynam 133 fact=one 134 if(.not.lid.or..not.ljd) fact=half 135 rx=xix-xw(jwm,1,jwa)-rwx(jwm,1) 136 ry=xiy-xw(jwm,2,jwa)-rwx(jwm,2) 137 rz=xiz-xw(jwm,3,jwa)-rwx(jwm,3) 138 ri2=one/(rx*rx+ry*ry+rz*rz) 139 ri1=sqrt(ri2) 140 ri6=ri2*ri2*ri2 141 eq=eq+fact*ri1 142 e6=e6+fact*ri6 143 e12=e12+fact*ri6*ri6 144 ff=(q*ri1+(cf12*ri6-cf6)*ri6)*ri2 145 df=ff*rx 146 fw(iwm,1,iwa,ipww)=fw(iwm,1,iwa,ipww)+df 147 fw(jwm,1,jwa,ipww)=fw(jwm,1,jwa,ipww)-df 148 zw(1,1,ipww)=zw(1,1,ipww)-df*rwc(jwm,1) 149 zw(2,1,ipww)=zw(2,1,ipww)-df*rwc(jwm,2) 150 zw(3,1,ipww)=zw(3,1,ipww)-df*rwc(jwm,3) 151 df=ff*ry 152 fw(iwm,2,iwa,ipww)=fw(iwm,2,iwa,ipww)+df 153 fw(jwm,2,jwa,ipww)=fw(jwm,2,jwa,ipww)-df 154 zw(1,2,ipww)=zw(1,2,ipww)-df*rwc(jwm,1) 155 zw(2,2,ipww)=zw(2,2,ipww)-df*rwc(jwm,2) 156 zw(3,2,ipww)=zw(3,2,ipww)-df*rwc(jwm,3) 157 df=ff*rz 158 fw(iwm,3,iwa,ipww)=fw(iwm,3,iwa,ipww)+df 159 fw(jwm,3,jwa,ipww)=fw(jwm,3,jwa,ipww)-df 160 zw(1,3,ipww)=zw(1,3,ipww)-df*rwc(jwm,1) 161 zw(2,3,ipww)=zw(2,3,ipww)-df*rwc(jwm,2) 162 zw(3,3,ipww)=zw(3,3,ipww)-df*rwc(jwm,3) 163 107 continue 164 eww(7,ipww)=eww(7,ipww)+c12*e12-c6*e6 165 eww(8,ipww)=eww(8,ipww)+q*eq 166 else 167 do 108 jnum=1,lwwin(iw,ipww) 168 jwm=lwwj(inum+jnum) 169 ljd=iand(idt(jwm),mdynam).eq.ldynam 170 fact=one 171 if(.not.lid.or..not.ljd) fact=half 172 rx=xix-xw(jwm,1,jwa)-rwx(jwm,1) 173 ry=xiy-xw(jwm,2,jwa)-rwx(jwm,2) 174 rz=xiz-xw(jwm,3,jwa)-rwx(jwm,3) 175 ri2=one/(rx*rx+ry*ry+rz*rz) 176 ri1=sqrt(ri2) 177 ri6=ri2*ri2*ri2 178 er=ealpha/ri1 179 ferfc=erfc(er) 180 fderfc=ealpha*derfc(er) 181 eq=eq+fact*ri1*ferfc 182 e6=e6+fact*ri6 183 e12=e12+fact*ri6*ri6 184 ff=(q*(ri1*ferfc-fderfc)+(cf12*ri6-cf6)*ri6)*ri2 185 df=ff*rx 186 fw(iwm,1,iwa,ipww)=fw(iwm,1,iwa,ipww)+df 187 fw(jwm,1,jwa,ipww)=fw(jwm,1,jwa,ipww)-df 188 zw(1,1,ipww)=zw(1,1,ipww)-df*rwc(jwm,1) 189 zw(2,1,ipww)=zw(2,1,ipww)-df*rwc(jwm,2) 190 zw(3,1,ipww)=zw(3,1,ipww)-df*rwc(jwm,3) 191 df=ff*ry 192 fw(iwm,2,iwa,ipww)=fw(iwm,2,iwa,ipww)+df 193 fw(jwm,2,jwa,ipww)=fw(jwm,2,jwa,ipww)-df 194 zw(1,2,ipww)=zw(1,2,ipww)-df*rwc(jwm,1) 195 zw(2,2,ipww)=zw(2,2,ipww)-df*rwc(jwm,2) 196 zw(3,2,ipww)=zw(3,2,ipww)-df*rwc(jwm,3) 197 df=ff*rz 198 fw(iwm,3,iwa,ipww)=fw(iwm,3,iwa,ipww)+df 199 fw(jwm,3,jwa,ipww)=fw(jwm,3,jwa,ipww)-df 200 zw(1,3,ipww)=zw(1,3,ipww)-df*rwc(jwm,1) 201 zw(2,3,ipww)=zw(2,3,ipww)-df*rwc(jwm,2) 202 zw(3,3,ipww)=zw(3,3,ipww)-df*rwc(jwm,3) 203 108 continue 204 eww(7,ipww)=eww(7,ipww)+c12*e12-c6*e6 205 eww(8,ipww)=eww(8,ipww)+q*eq 206 endif 207 106 continue 208 105 continue 209 else 210 do 115 iwa=1,nwa 211 qi=chg(iwq(iwa),1,iset) 212 dqi=zero 213 p2qi=zero 214 p3qi=zero 215 if(ipert2) p2qi=chg(iwq(iwa),1,2) 216 if(ipert3) p3qi=chg(iwq(iwa),1,3) 217 if(ithint) dqi=chg(iwq(iwa),1,4) 218 iptr=iwatm(iwa) 219 xix=xw(iwm,1,iwa) 220 xiy=xw(iwm,2,iwa) 221 xiz=xw(iwm,3,iwa) 222 do 116 jwa=1,nwa 223 qj=chg(iwq(jwa),1,iset) 224 q=qi*qj 225 c6=vdw(iptr,iwatm(jwa),1,iset) 226 c12=vdw(iptr,iwatm(jwa),3,iset) 227 cf6=six*c6 228 cf12=twelve*c12 229 eq=zero 230 e6=zero 231 e12=zero 232 do 117 jnum=1,lwwin(iw,ipww) 233 jwm=lwwj(inum+jnum) 234 ljd=iand(idt(jwm),mdynam).eq.ldynam 235 fact=one 236 if(.not.lid.or..not.ljd) fact=half 237 rx=xix-xw(jwm,1,jwa)-rwx(jwm,1) 238 ry=xiy-xw(jwm,2,jwa)-rwx(jwm,2) 239 rz=xiz-xw(jwm,3,jwa)-rwx(jwm,3) 240 ri2=one/(rx*rx+ry*ry+rz*rz) 241 ri1=sqrt(ri2) 242 ri6=ri2*ri2*ri2 243 eq=eq+fact*ri1 244 e6=e6+fact*ri6 245 e12=e12+fact*ri6*ri6 246 ff=(q*ri1+(cf12*ri6-cf6)*ri6)*ri2 247 df=ff*rx 248 fw(iwm,1,iwa,ipww)=fw(iwm,1,iwa,ipww)+df 249 fw(jwm,1,jwa,ipww)=fw(jwm,1,jwa,ipww)-df 250 zw(1,1,ipww)=zw(1,1,ipww)-df*rwc(jwm,1) 251 zw(2,1,ipww)=zw(2,1,ipww)-df*rwc(jwm,2) 252 zw(3,1,ipww)=zw(3,1,ipww)-df*rwc(jwm,3) 253 df=ff*ry 254 fw(iwm,2,iwa,ipww)=fw(iwm,2,iwa,ipww)+df 255 fw(jwm,2,jwa,ipww)=fw(jwm,2,jwa,ipww)-df 256 zw(1,2,ipww)=zw(1,2,ipww)-df*rwc(jwm,1) 257 zw(2,2,ipww)=zw(2,2,ipww)-df*rwc(jwm,2) 258 zw(3,2,ipww)=zw(3,2,ipww)-df*rwc(jwm,3) 259 df=ff*rz 260 fw(iwm,3,iwa,ipww)=fw(iwm,3,iwa,ipww)+df 261 fw(jwm,3,jwa,ipww)=fw(jwm,3,jwa,ipww)-df 262 zw(1,3,ipww)=zw(1,3,ipww)-df*rwc(jwm,1) 263 zw(2,3,ipww)=zw(2,3,ipww)-df*rwc(jwm,2) 264 zw(3,3,ipww)=zw(3,3,ipww)-df*rwc(jwm,3) 265 117 continue 266 eww(7,ipww)=eww(7,ipww)+c12*e12-c6*e6 267 eww(8,ipww)=eww(8,ipww)+q*eq 268 if(ithint) then 269 deriv(2,ipww)=deriv(2,ipww)+ 270 + vdw(iptr,iwatm(jwa),3,4)*e12-vdw(iptr,iwatm(jwa),1,4)*c6 271 deriv(4,ipww)=deriv(4,ipww)+(qi*chg(iwq(jwa),1,4)+qj*dqi)*eq 272 endif 273 if(ipert2) then 274 ep2(ipww)=ep2(ipww)+(p2qi*chg(iwq(jwa),1,2)-q)*eq+ 275 + (vdw(iptr,iwatm(jwa),3,2)-c12)*e12- 276 + (vdw(iptr,iwatm(jwa),1,2)-c6)*e6 277 endif 278 if(ipert3) then 279 ep3(ipww)=ep3(ipww)+(p3qi*chg(iwq(jwa),1,3)-q)*eq+ 280 + (vdw(iptr,iwatm(jwa),3,3)-c12)*e12- 281 + (vdw(iptr,iwatm(jwa),1,3)-c6)*e6 282 endif 283 116 continue 284 115 continue 285 endif 286 102 continue 287 101 continue 288 return 289 endif 290#endif 291 292cx new stuff end 293c 294c calculation of solvent-solvent intermolecular energies and forces 295c 296c subtract 1 from first molecule index for use as offset 297c 298 iwfr=iwfrom-1 299c 300c loop over short and long range parts 301c 302 do 1 ipww=1,lpww 303c 304c Evaluate the outer index array 305c 306 nwwlen(ipww)=0 307 lwwndx(0,ipww)=0 308 number=0 309 do 2 iwm=1,nwloc 310 if(number+lwwin(iwm,ipww).gt.mscr) then 311 nwwlen(ipww)=nwwlen(ipww)+1 312 lwwndx(nwwlen(ipww),ipww)=iwm-1 313 number=0 314 endif 315 number=number+lwwin(iwm,ipww) 316 2 continue 317 if(number.gt.0) then 318 nwwlen(ipww)=nwwlen(ipww)+1 319 lwwndx(nwwlen(ipww),ipww)=nwloc 320 endif 321c 322c loop over number of cycles to complete pairlist 323c 324 do 3 iwpm=1,nwwlen(ipww) 325 nax=0 326c 327c collect coordinates into workarrays 328c 329 do 4 iwm=lwwndx(iwpm-1,ipww)+1,lwwndx(iwpm,ipww) 330 iwpj=lwwjpt(iwm,ipww)-1 331 do 5 iwmn=1,lwwin(iwm,ipww) 332 lwwptr=lwwj(iwpj+iwmn) 333 rwc(nax+iwmn,1)=xwm(iwfr+iwm,1)-xwm(lwwptr,1) 334 rwc(nax+iwmn,2)=xwm(iwfr+iwm,2)-xwm(lwwptr,2) 335 rwc(nax+iwmn,3)=xwm(iwfr+iwm,3)-xwm(lwwptr,3) 336 facu(nax+iwmn)=one 337c if( (iand(idt(iwm),mdynam).eq.ldynam.and. 338c + iand(idt(lwwptr),mdynam).ne.ldynam).or. 339c + (iand(idt(iwm),mdynam).ne.ldynam.and. 340c + iand(idt(lwwptr),mdynam).eq.ldynam) ) facu(nax+iwmn)=half 341 if(iand(idt(iwm),mdynam).ne.ldynam.and. 342 + iand(idt(lwwptr),mdynam).ne.ldynam) facu(nax+iwmn)=zero 343 if(includ.eq.1) facu(nax+iwmn)=one 344 5 continue 345c 346 do 6 iwa=1,mwa 347 do 7 iwmn=1,lwwin(iwm,ipww) 348 lwwptr=lwwj(iwpj+iwmn) 349 xi(nax+iwmn,1,iwa)=xw(iwfr+iwm,1,iwa) 350 xi(nax+iwmn,2,iwa)=xw(iwfr+iwm,2,iwa) 351 xi(nax+iwmn,3,iwa)=xw(iwfr+iwm,3,iwa) 352 xj(nax+iwmn,1,iwa)=xw(lwwptr,1,iwa) 353 xj(nax+iwmn,2,iwa)=xw(lwwptr,2,iwa) 354 xj(nax+iwmn,3,iwa)=xw(lwwptr,3,iwa) 355#if defined(CAFE_POLARIZATION) 356 pl(nax+iwmn,1,iwa)=pw(iwfr+iwm,1,iwa,1) 357 pl(nax+iwmn,2,iwa)=pw(iwfr+iwm,2,iwa,1) 358 pl(nax+iwmn,3,iwa)=pw(iwfr+iwm,3,iwa,1) 359 pj(nax+iwmn,1,iwa)=pw(lwwptr,1,iwa,1) 360 pj(nax+iwmn,2,iwa)=pw(lwwptr,2,iwa,1) 361 pj(nax+iwmn,3,iwa)=pw(lwwptr,3,iwa,1) 362#endif 363 7 continue 364 6 continue 365 if(lpbc) then 366 call cf_pbc(0,rwc,mscr,rwx,mscr,nax,1,lwwin(iwm,ipww)) 367 do 8 iwmn=1,lwwin(iwm,ipww) 368 rwc(nax+iwmn,1)=rwc(nax+iwmn,1)-rwx(iwmn,1) 369 rwc(nax+iwmn,2)=rwc(nax+iwmn,2)-rwx(iwmn,2) 370 rwc(nax+iwmn,3)=rwc(nax+iwmn,3)-rwx(iwmn,3) 371 8 continue 372 do 9 iwa=1,mwa 373 do 10 iwmn=1,lwwin(iwm,ipww) 374 lwwptr=lwwj(iwpj+iwmn) 375 xj(nax+iwmn,1,iwa)=xj(nax+iwmn,1,iwa)+rwx(iwmn,1) 376 xj(nax+iwmn,2,iwa)=xj(nax+iwmn,2,iwa)+rwx(iwmn,2) 377 xj(nax+iwmn,3,iwa)=xj(nax+iwmn,3,iwa)+rwx(iwmn,3) 378 10 continue 379 9 continue 380 endif 381c 382 nax=nax+lwwin(iwm,ipww) 383 4 continue 384c 385c initializations 386c 387c if(npener.ne.0) then 388c do 12 iax=1,nax 389c u(iax)=zero 390c 12 continue 391c endif 392c 393c loops over number of atoms in a solvent molecule 394c 395#if defined(CAFE_POLARIZATION) 396 qfaci=one/qfac 397#endif 398 do 13 iwa=1,mwa 399 qi=chg(iwq(iwa),1,iset) 400#if defined(CAFE_POLARIZATION) 401 pai=chg(iwq(iwa),2,iset) 402 qai=qfaci*qi 403#endif 404 do 14 jwa=1,mwa 405 qj=chg(iwq(jwa),1,iset) 406 q=qi*qj 407#if defined(CAFE_POLARIZATION) 408 paj=chg(iwq(jwa),2,iset) 409 qaj=qfaci*qj 410#endif 411c 412 do 15 iax=1,nax 413 f(iax)=zero 414 rwx(iax,1)=xi(iax,1,iwa)-xj(iax,1,jwa) 415 rwx(iax,2)=xi(iax,2,iwa)-xj(iax,2,jwa) 416 rwx(iax,3)=xi(iax,3,iwa)-xj(iax,3,jwa) 417 rwi2(iax)=one/(rwx(iax,1)**2+rwx(iax,2)**2+rwx(iax,3)**2) 418 rwi1(iax)=sqrt(rwi2(iax)) 419 15 continue 420c 421c 422c van der Waals contribution 423c -------------------------- 424c 425 iptr=iwatm(iwa) 426 jptr=iwatm(jwa) 427 c6=vdw(iptr,jptr,1,iset) 428 cf6=six*c6 429 c12=vdw(iptr,jptr,3,iset) 430 cf12=twelve*c12 431c 432 eterml=zero 433 if(c6.ne.zero.or.c12.ne.zero) then 434 ewwl6=zero 435 ewwl12=zero 436 do 20 iax=1,nax 437 rwi6(iax)=rwi2(iax)*rwi2(iax)*rwi2(iax) 438 ewwl6=ewwl6+facu(iax)*rwi6(iax) 439 ewwl12=ewwl12+facu(iax)*rwi6(iax)*rwi6(iax) 440 f(iax)=f(iax)+(cf12*rwi6(iax)-cf6)*rwi6(iax)*rwi2(iax) 441 20 continue 442 eterml=c12*ewwl12-c6*ewwl6 443 eww(7,ipww)=eww(7,ipww)+eterml 444 endif 445c 446#if !defined(CAFE_POLARIZATION) 447c 448c electrostatic contribution 449c -------------------------- 450c 451 ewwqsm=zero 452 if(q.ne.zero) then 453 if(ipme.eq.0) then 454 do 16 iax=1,nax 455 ewwqsm=ewwqsm+facu(iax)*rwi1(iax) 456 f(iax)=f(iax)+q*rwi1(iax)*rwi2(iax) 457 16 continue 458 else 459 do 17 iax=1,nax 460 ferfc=erfc(ealpha/rwi1(iax)) 461 fderfc=ealpha*derfc(ealpha/rwi1(iax)) 462 ewwqsm=ewwqsm+facu(iax)*ferfc*rwi1(iax) 463 f(iax)=f(iax)+q*rwi2(iax)*(ferfc*rwi1(iax)-fderfc) 464 17 continue 465 endif 466c 467c reaction field contribution 468c --------------------------- 469c 470 if(ireact.ne.0) then 471 do 19 iax=1,nax 472 eww(8,ipww)=eww(8,ipww)+facu(iax)*q*rffww/rwi2(iax) 473 f(iax)=f(iax)-two*q*rffww 474 19 continue 475 endif 476 endif 477#endif 478c 479c force vectors 480c ------------- 481c 482 if(iwa.eq.1) then 483 do 22 iax=1,nax 484 fj(iax,1,jwa)=(-f(iax))*rwx(iax,1) 485 fj(iax,2,jwa)=(-f(iax))*rwx(iax,2) 486 fj(iax,3,jwa)=(-f(iax))*rwx(iax,3) 487 22 continue 488 else 489 do 23 iax=1,nax 490 fj(iax,1,jwa)=fj(iax,1,jwa)-f(iax)*rwx(iax,1) 491 fj(iax,2,jwa)=fj(iax,2,jwa)-f(iax)*rwx(iax,2) 492 fj(iax,3,jwa)=fj(iax,3,jwa)-f(iax)*rwx(iax,3) 493 23 continue 494 endif 495c 496 if(jwa.eq.1) then 497 do 24 iax=1,nax 498 fi(iax,1,iwa)=f(iax)*rwx(iax,1) 499 fi(iax,2,iwa)=f(iax)*rwx(iax,2) 500 fi(iax,3,iwa)=f(iax)*rwx(iax,3) 501 24 continue 502 else 503 do 25 iax=1,nax 504 fi(iax,1,iwa)=fi(iax,1,iwa)+f(iax)*rwx(iax,1) 505 fi(iax,2,iwa)=fi(iax,2,iwa)+f(iax)*rwx(iax,2) 506 fi(iax,3,iwa)=fi(iax,3,iwa)+f(iax)*rwx(iax,3) 507 25 continue 508 endif 509 do 26 iax=1,nax 510 zw(1,1,ipww)=zw(1,1,ipww)-f(iax)*rwx(iax,1)*rwc(iax,1) 511 zw(2,1,ipww)=zw(2,1,ipww)-f(iax)*rwx(iax,1)*rwc(iax,2) 512 zw(3,1,ipww)=zw(3,1,ipww)-f(iax)*rwx(iax,1)*rwc(iax,3) 513 zw(1,2,ipww)=zw(1,2,ipww)-f(iax)*rwx(iax,2)*rwc(iax,1) 514 zw(2,2,ipww)=zw(2,2,ipww)-f(iax)*rwx(iax,2)*rwc(iax,2) 515 zw(3,2,ipww)=zw(3,2,ipww)-f(iax)*rwx(iax,2)*rwc(iax,3) 516 zw(1,3,ipww)=zw(1,3,ipww)-f(iax)*rwx(iax,3)*rwc(iax,1) 517 zw(2,3,ipww)=zw(2,3,ipww)-f(iax)*rwx(iax,3)*rwc(iax,2) 518 zw(3,3,ipww)=zw(3,3,ipww)-f(iax)*rwx(iax,3)*rwc(iax,3) 519 26 continue 520c 521#if defined(CAFE_POLARIZATION) 522c 523c electrostatic and polarization contribution 524c ------------------------------------------- 525c 526 ewwqsm=zero 527 ewwpsm=zero 528 do 117 iax=1,nax 529 pix=pai*pl(iax,1,iwa) 530 piy=pai*pl(iax,2,iwa) 531 piz=pai*pl(iax,3,iwa) 532 pjx=paj*pj(iax,1,jwa) 533 pjy=paj*pj(iax,2,jwa) 534 pjz=paj*pj(iax,3,jwa) 535 rx=-rwx(iax,1) 536 ry=-rwx(iax,2) 537 rz=-rwx(iax,3) 538 ri1=rwi1(iax) 539 ri2=rwi2(iax) 540 ri3=qfac*qfac*ri1*ri2 541 rmi=three*(rx*pix+ry*piy+rz*piz)*ri2 542 rmj=three*(rx*pjx+ry*pjy+rz*pjz)*ri2 543 if(ipolt.eq.1) then 544 fri=((-qai)*qaj+qai*rmj-qaj*rmi)*ri3 545 fmi=(qaj)*ri3 546 fmj=(-qai)*ri3 547 else 548 rmm=three*(pix*pjx+piy*pjy+piz*pjz)*ri2 549 fri=((-qai)*qaj+qai*rmj-qaj*rmi+5.0*rmi*rmj/three-rmm)*ri3 550 fmi=(qaj-rmj)*ri3 551 fmj=((-qai)-rmi)*ri3 552 endif 553 fi(iax,1,iwa)=fi(iax,1,iwa)+fri*rx+fmi*pix+fmj*pjx 554 fi(iax,2,iwa)=fi(iax,2,iwa)+fri*ry+fmi*piy+fmj*pjy 555 fi(iax,3,iwa)=fi(iax,3,iwa)+fri*rz+fmi*piz+fmj*pjz 556 fj(iax,1,jwa)=fj(iax,1,jwa)-(fri*rx+fmi*pix+fmj*pjx) 557 fj(iax,2,jwa)=fj(iax,2,jwa)-(fri*ry+fmi*piy+fmj*pjy) 558 fj(iax,3,jwa)=fj(iax,3,jwa)-(fri*rz+fmi*piz+fmj*pjz) 559 zw(1,1,ipww)=zw(1,1,ipww)-(fri*rx+fmi*pix+fmj*pjx)*rwc(iax,1) 560 zw(2,1,ipww)=zw(2,1,ipww)-(fri*rx+fmi*pix+fmj*pjx)*rwc(iax,2) 561 zw(3,1,ipww)=zw(3,1,ipww)-(fri*rx+fmi*pix+fmj*pjx)*rwc(iax,3) 562 zw(1,2,ipww)=zw(1,2,ipww)-(fri*ry+fmi*piy+fmj*pjy)*rwc(iax,1) 563 zw(2,2,ipww)=zw(2,2,ipww)-(fri*ry+fmi*piy+fmj*pjy)*rwc(iax,2) 564 zw(3,2,ipww)=zw(3,2,ipww)-(fri*ry+fmi*piy+fmj*pjy)*rwc(iax,3) 565 zw(1,3,ipww)=zw(1,3,ipww)-(fri*rz+fmi*piz+fmj*pjz)*rwc(iax,1) 566 zw(2,3,ipww)=zw(2,3,ipww)-(fri*rz+fmi*piz+fmj*pjz)*rwc(iax,2) 567 zw(3,3,ipww)=zw(3,3,ipww)-(fri*rz+fmi*piz+fmj*pjz)*rwc(iax,3) 568 ewwpsm=ewwpsm+facu(iax)*(qai*rmj-qaj*rmi)*ri1 569 ewwqsm=ewwqsm+facu(iax)*ri1 570 117 continue 571 etermp=-qfac*qfac*ewwpsm/three 572 eww(8,ipww)=eww(8,ipww)+etermp 573#endif 574 etermq=q*ewwqsm 575 eww(8,ipww)=eww(8,ipww)+etermq 576c 577c Radial distribution functions 578c 579c if(ifstep-1.eq.((ifstep-1)/nfrdf)*nfrdf .and. ngrww.gt.0) then 580c do 27 igc=1,ngc 581c if(ngt(igc).eq.1) then 582c if(iagc(igc).eq.iwa .and. jagc(igc).eq.jwa) then 583c igr=igrc(igc) 584c do 28 iax=1,nax 585c indx=int(one/(rwi1(iax)*drdf)) 586c if(indx.le.ngl) rdf(indx,igr)=rdf(indx,igr)+rdfvol 587c 28 continue 588c endif 589c endif 590c 27 continue 591c endif 592c 593c Thermodynamic integration 594c 595 if(ithint) then 596 if(ith(2)) then 597 c64=vdw(iwatm(iwa),iwatm(jwa),1,4) 598 c124=vdw(iwatm(iwa),iwatm(jwa),3,4) 599 ewwl6=zero 600 ewwl12=zero 601 do 29 iax=1,nax 602 ewwl6=ewwl6+facu(iax)*rwi6(iax) 603 ewwl12=ewwl12+facu(iax)*rwi6(iax)*rwi6(iax) 604 29 continue 605 deriv(2,ipww)=deriv(2,ipww)+c124*ewwl12-c64*ewwl6 606 endif 607 if(ith(4)) then 608 qi=chg(iwq(iwa),1,iset) 609 qj=chg(iwq(jwa),1,iset) 610 qi4=chg(iwq(iwa),1,4) 611 qj4=chg(iwq(jwa),1,4) 612 dercon=zero 613 if(ipme.eq.0) then 614 do 30 iax=1,nax 615 dercon=dercon+rwi1(iax) 616 30 continue 617 else 618 do 130 iax=1,nax 619 dercon=dercon+rwi1(iax) 620 130 continue 621 endif 622 deriv(4,ipww)=deriv(4,ipww)+(qi*qj4+qj*qi4)*dercon 623 if(ireact.ne.0) then 624 dercon=zero 625 do 31 iax=1,nax 626 dercon=dercon+one/rwi2(iax) 627 31 continue 628 deriv(4,ipww)=deriv(4,ipww)+(qi*qj4+qj*qi4)*rffww*dercon 629 endif 630 endif 631 endif 632c 633c Thermodynamic perturbation 1 634c 635 if(ipert2) then 636 if(ip2(2)) then 637 c6p=vdw(iwatm(iwa),iwatm(jwa),1,2) 638 c12p=vdw(iwatm(iwa),iwatm(jwa),3,2) 639 do 32 iax=1,nax 640 ep2(ipww)=ep2(ipww)+facu(iax)*(c12p*rwi6(iax)-c6p)*rwi6(iax) 641 32 continue 642 ep2(ipww)=ep2(ipww)-eterml 643 endif 644 if(ip2(4).or.ip2(5)) then 645 qp=chg(iwq(iwa),1,2)*chg(iwq(jwa),1,2) 646 ep2tmp=zero 647 do 33 iax=1,nax 648 rwx(iax,1)=xi(iax,1,iwa)-xj(iax,1,jwa) 649 rwx(iax,2)=xi(iax,2,iwa)-xj(iax,2,jwa) 650 rwx(iax,3)=xi(iax,3,iwa)-xj(iax,3,jwa) 651 rwi2(iax)=one/(rwx(iax,1)**2+rwx(iax,2)**2+rwx(iax,3)**2) 652 rwi1(iax)=sqrt(rwi2(iax)) 653 if(ipme.eq.0) then 654 ep2tmp=ep2tmp+facu(iax)*rwi1(iax) 655 else 656 ep2tmp=ep2tmp+facu(iax)*erfc(ealpha/rwi1(iax))*rwi1(iax) 657 endif 658 33 continue 659 ep2(ipww)=ep2(ipww)+qp*ep2tmp-etermq 660 if(ireact.ne.0) then 661 ep2tmp=zero 662 do 34 iax=1,nax 663 ep2tmp=ep2tmp+facu(iax)/rwi2(iax) 664 34 continue 665 ep2(ipww)=ep2(ipww)+qp*rffww*ep2tmp 666 endif 667 endif 668 endif 669c 670c Thermodynamic perturbation 2 671c 672 if(ipert3) then 673 if(ip3(2)) then 674 c6p=vdw(iwatm(iwa),iwatm(jwa),1,3) 675 c12p=vdw(iwatm(iwa),iwatm(jwa),3,3) 676 do 35 iax=1,nax 677 ep3(ipww)=ep3(ipww)+facu(iax)*(c12p*rwi6(iax)-c6p)*rwi6(iax) 678 35 continue 679 ep3(ipww)=ep3(ipww)-eterml 680 endif 681 if(ip2(4).or.ip2(5)) then 682 qp=chg(iwatm(iwa),1,3)*chg(iwatm(jwa),1,3) 683 ep3tmp=zero 684 do 36 iax=1,nax 685 rwx(iax,1)=xi(iax,1,iwa)-xj(iax,1,jwa) 686 rwx(iax,2)=xi(iax,2,iwa)-xj(iax,2,jwa) 687 rwx(iax,3)=xi(iax,3,iwa)-xj(iax,3,jwa) 688 rwi2(iax)=one/(rwx(iax,1)**2+rwx(iax,2)**2+rwx(iax,3)**2) 689 rwi1(iax)=sqrt(rwi2(iax)) 690 if(ipme.eq.0) then 691 ep3tmp=ep3tmp+facu(iax)*rwi1(iax) 692 else 693 ep3tmp=ep3tmp+facu(iax)*erfc(ealpha/rwi1(iax))*rwi1(iax) 694 endif 695 36 continue 696 ep3(ipww)=ep3(ipww)+qp*ep3tmp-etermq 697 if(ireact.ne.0) then 698 ep3tmp=zero 699 do 37 iax=1,nax 700 ep3tmp=ep3tmp+facu(iax)/rwi2(iax) 701 37 continue 702 ep3(ipww)=ep3(ipww)+qp*rffww*ep3tmp 703 endif 704 endif 705 endif 706 14 continue 707 13 continue 708c 709c Update force arrays 710c 711 iax=0 712 do 38 iwm=lwwndx(iwpm-1,ipww)+1,lwwndx(iwpm,ipww) 713 iwpj=lwwjpt(iwm,ipww)-1 714 do 39 iwa=1,mwa 715 do 40 iwmn=1,lwwin(iwm,ipww) 716 lwwptr=lwwj(iwpj+iwmn) 717 fw(iwfr+iwm,1,iwa,ipww)=fw(iwfr+iwm,1,iwa,ipww)+fi(iax+iwmn,1,iwa) 718 fw(iwfr+iwm,2,iwa,ipww)=fw(iwfr+iwm,2,iwa,ipww)+fi(iax+iwmn,2,iwa) 719 fw(iwfr+iwm,3,iwa,ipww)=fw(iwfr+iwm,3,iwa,ipww)+fi(iax+iwmn,3,iwa) 720 fw(lwwptr,1,iwa,ipww)=fw(lwwptr,1,iwa,ipww)+fj(iax+iwmn,1,iwa) 721 fw(lwwptr,2,iwa,ipww)=fw(lwwptr,2,iwa,ipww)+fj(iax+iwmn,2,iwa) 722 fw(lwwptr,3,iwa,ipww)=fw(lwwptr,3,iwa,ipww)+fj(iax+iwmn,3,iwa) 723 40 continue 724 39 continue 725c 726c update energy arrays if appropriate print option was set 727c 728c if(npener.ne.0) then 729c do 41 iwmn=1,lwwin(iwm,ipww) 730c lwwptr=lwwj(iwpj+iwmn) 731c uwmw(iwfr+iwm)=uwmw(iwfr+iwm)+u(iax+iwmn) 732c uwmw(lwwptr)=uwmw(lwwptr)+u(iax+iwmn) 733c 41 continue 734c endif 735c 736 iax=iax+lwwin(iwm,ipww) 737 38 continue 738 3 continue 739c 740 1 continue 741c 742 return 743 end 744#if defined(CAFE_POLARIZATION) 745 subroutine cf_fpsw(xs,xsm,fs,zs,ps,psp, 746 + isga,isat,isdt,ismf,isml,isss,isq1, 747 + isfrom,nums,xw,xwm,fw,pw,pwp,rtos,iwdt,lpbc,lpbcs,esw,esa, 748 + vdw,chg,iwatm,iwq,iass,lswndx,lswjpt,lswin,lswj, 749 + xi,xj,rwx,rwi1,rwi2,rwi6,rwc,f,fi,fj,facu, 750 + rw,isal,isrx,list,pl,pj) 751#elif defined(CAFE_FORCES) 752 subroutine cf_fsw(xs,xsm,fs,zs, 753 + isga,isat,isdt,ismf,isml,isss,isq1, 754 + isfrom,nums,xw,xwm,fw,rtos,iwdt,lpbc,lpbcs,esw,esa, 755 + vdw,chg,iwatm,iwq,iass,lswndx,lswjpt,lswin,lswj, 756 + xi,xj,rwx,rwi1,rwi2,rwi6,rwc,f,fi,fj,facu, 757 + rw,isal,isrx,list,dera) 758#else 759c error 760#endif 761c 762c $Id$ 763c 764 implicit none 765c 766#include "cf_common.fh" 767#include "cf_funcs_dec.fh" 768#include "bitops_decls.fh" 769c 770 real*8 xs(msa,3),xsm(msm,3),fs(msa,3,2) 771 real*8 zs(msf,3,3,2),esw(msf,mpe,2) 772 integer isga(msa),isat(msa),isdt(msa),ismf(msa) 773 integer isml(msa),isss(msa),isq1(msa) 774 real*8 xw(mwm,3,mwa),xwm(mwm,3),fw(mwm,3,mwa,2),rtos(mwm) 775 real*8 esa(nsa) 776 integer iwdt(mwm) 777 integer isfrom 778 logical lpbc,lpbcs 779c 780 real*8 vdw(mat,mat,map,mset),chg(mqt,mqp,mset) 781 integer iass(mat,mat),iwatm(mwa),iwq(mwa) 782c 783 real*8 xi(mscr,3),xj(mscr,3,mwa),rwx(mscr,3) 784 real*8 rwi1(mscr),rwi2(mscr),rwi6(mscr),rw(mscr),rwc(mscr,3) 785 real*8 f(mscr),fi(mscr,3,mwa),fj(mscr,3,mwa),facu(mscr) 786 integer isal(mscr),isrx(mscr) 787c 788 integer lswj(*) 789 integer nums,i 790 integer lswndx(0:msa,2),lswjpt(nums,2),lswin(nums,2) 791 integer list(0:msa) 792c 793#if defined(CAFE_FORCES) 794 real*8 dera(6,nsatot) 795#endif 796#if defined(CAFE_POLARIZATION) 797 real*8 ps(msa,3,2),psp(msa,3,2,2) 798 real*8 pw(mwm,3,mwa,2),pwp(mwm,3,mwa,2,2) 799 real*8 pl(mscr,3),pj(mscr,3,mwa) 800#endif 801c 802 integer isatm,nswlen(2) 803 integer isfr,iwm,ipsw,number,isa,ispm,isf,nax,ism 804 integer ispj,ismn,lswptr,iwa,iax,iwatmi,ix,iy 805 integer iwatyp 806 real*8 c6,cf6,c12,cf12,sumen 807 real*8 c64,c124,dercon,qj,qj4,derco1,derco2 808 real*8 drvco1,drvco2,derco3,drvco3,c6p,c12p,etermq,eterml 809#if defined(CAFE_FORCES) 810 real*8 q,qwas,ferfc,fderfc 811#endif 812#if defined(CAFE_POLARIZATION) 813 real*8 qi,qai,qaj,pai,paj,pix,piy,piz,pjx,pjy,pjz 814 real*8 rx,ry,rz,ri1,ri2,ri3,rmi,rmj,fri,fmi,fmj,rmm 815 real*8 zxx,zxy,zxz,zyx,zyy,zyz,zzx,zzy,zzz 816 real*8 eswqsm,eswpsm,qfaci 817#else 818 real*8 boxi(3),dx,ri1,ri2,ri6,eq,eq0,e6,e8,e12,e14,ff,df 819 real*8 xix,xiy,xiz,fact 820 real*8 rx,ry,rz,er,p2qi,p3qi,dqi,qi,dd 821 integer is,inum,jnum,jwm,iptr,jwa,iss,isg 822 logical lid,ljd 823#endif 824 real*8 rtmp 825c 826#include "cf_funcs_sfn.fh" 827#include "bitops_funcs.fh" 828c 829 etermq=zero 830c 831#if !defined(CAFE_POLARIZATION) 832c 833 isfr=isfrom-1 834 boxi(1)=one/box(1) 835 boxi(2)=one/box(2) 836 boxi(3)=one/box(3) 837 if(npbtyp.eq.1.and.nbxtyp.eq.0.and.icntrl.eq.2) then 838 do 101 ipsw=1,npsw 839 do 102 is=1,nums 840 isa=isfr+is 841 ism=isml(isa) 842 isf=ismf(isa) 843 iss=0 844 inum=lswjpt(is,ipsw)-1 845 if(iand(isss(isa),6).eq.2) iss=-1 846 if(iand(isss(isa),6).eq.4) iss=-1 847c write(*,'(a,4i5)') 'iss ',isa,isss(isa),iand(isss(isa),6),iss 848 isg=isga(isa) 849 lid=iand(isdt(isa),mdynam).eq.ldynam 850 qi=chg(isq1(isa),1,iset) 851 iptr=isat(isa) 852 xix=xs(isa,1) 853 xiy=xs(isa,2) 854 xiz=xs(isa,3) 855c 856 if(lpbc) then 857 do 104 ix=1,3 858 do 103 jnum=1,lswin(is,ipsw) 859 jwm=lswj(inum+jnum) 860 dx=xsm(ism,ix)-xwm(jwm,ix) 861 rwc(jwm,ix)=dx 862 if(abs(dx).gt.boxh(ix)) then 863 rwx(jwm,ix)=anint(dx*boxi(ix))*box(ix) 864 rwc(jwm,ix)=dx-rwx(jwm,ix) 865 else 866 rwx(jwm,ix)=zero 867 endif 868 103 continue 869 104 continue 870 endif 871c 872 if(.not.ithint.and..not.ipert2.and..not.ipert3) then 873 do 106 jwa=1,nwa 874 q=qi*chg(iwq(jwa),1,iset) 875 c6=vdw(iptr,iwatm(jwa),1,iset) 876 c12=vdw(iptr,iwatm(jwa),3,iset) 877 cf6=six*c6 878 cf12=twelve*c12 879 eq=zero 880 eq0=zero 881 e6=zero 882 e12=zero 883 if(ipme.eq.0) then 884 do 107 jnum=1,lswin(is,ipsw) 885 jwm=lswj(inum+jnum) 886 ljd=iand(iwdt(jwm),mdynam).eq.ldynam 887 fact=one 888 if(.not.lid.or..not.ljd) fact=half 889 rx=xix-xw(jwm,1,jwa)-rwx(jwm,1) 890 ry=xiy-xw(jwm,2,jwa)-rwx(jwm,2) 891 rz=xiz-xw(jwm,3,jwa)-rwx(jwm,3) 892 ri2=one/(rx*rx+ry*ry+rz*rz) 893 if(iss.gt.0) ri2=one/(one/ri2+shift0(1)) 894 if(iss.lt.0) ri2=one/(one/ri2+shift1(1)) 895 ri1=sqrt(ri2) 896 ri6=ri2*ri2*ri2 897 eq=eq+fact*ri1 898 e6=e6+fact*ri6 899 e12=e12+fact*ri6*ri6 900 ff=(q*ri1+(cf12*ri6-cf6)*ri6)*ri2 901 df=ff*rx 902 fs(isa,1,ipsw)=fs(isa,1,ipsw)+df 903 fw(jwm,1,jwa,ipsw)=fw(jwm,1,jwa,ipsw)-df 904 zs(isf,1,1,ipsw)=zs(isf,1,1,ipsw)-half*df*rwc(jwm,1) 905 zs(isf,2,1,ipsw)=zs(isf,2,1,ipsw)-half*df*rwc(jwm,2) 906 zs(isf,3,1,ipsw)=zs(isf,3,1,ipsw)-half*df*rwc(jwm,3) 907 zw(1,1,ipsw)=zw(1,1,ipsw)-half*df*rwc(jwm,1) 908 zw(2,1,ipsw)=zw(2,1,ipsw)-half*df*rwc(jwm,2) 909 zw(3,1,ipsw)=zw(3,1,ipsw)-half*df*rwc(jwm,3) 910 df=ff*ry 911 fs(isa,2,ipsw)=fs(isa,2,ipsw)+df 912 fw(jwm,2,jwa,ipsw)=fw(jwm,2,jwa,ipsw)-df 913 zs(isf,1,2,ipsw)=zs(isf,1,2,ipsw)-half*df*rwc(jwm,1) 914 zs(isf,2,2,ipsw)=zs(isf,2,2,ipsw)-half*df*rwc(jwm,2) 915 zs(isf,3,2,ipsw)=zs(isf,3,2,ipsw)-half*df*rwc(jwm,3) 916 zw(1,2,ipsw)=zw(1,2,ipsw)-half*df*rwc(jwm,1) 917 zw(2,2,ipsw)=zw(2,2,ipsw)-half*df*rwc(jwm,2) 918 zw(3,2,ipsw)=zw(3,2,ipsw)-half*df*rwc(jwm,3) 919 df=ff*rz 920 fs(isa,3,ipsw)=fs(isa,3,ipsw)+df 921 fw(jwm,3,jwa,ipsw)=fw(jwm,3,jwa,ipsw)-df 922 zs(isf,1,3,ipsw)=zs(isf,1,3,ipsw)-half*df*rwc(jwm,1) 923 zs(isf,2,3,ipsw)=zs(isf,2,3,ipsw)-half*df*rwc(jwm,2) 924 zs(isf,3,3,ipsw)=zs(isf,3,3,ipsw)-half*df*rwc(jwm,3) 925 zw(1,3,ipsw)=zw(1,3,ipsw)-half*df*rwc(jwm,1) 926 zw(2,3,ipsw)=zw(2,3,ipsw)-half*df*rwc(jwm,2) 927 zw(3,3,ipsw)=zw(3,3,ipsw)-half*df*rwc(jwm,3) 928 107 continue 929 esw(isf,5,ipsw)=esw(isf,5,ipsw)+c12*e12-c6*e6 930 esw(isf,6,ipsw)=esw(isf,6,ipsw)+q*eq 931 if(npener.ne.0) esa(isg)=esa(isg)+c12*e12-c6*e6+q*eq 932 else 933 do 108 jnum=1,lswin(is,ipsw) 934 jwm=lswj(inum+jnum) 935 ljd=iand(iwdt(jwm),mdynam).eq.ldynam 936 fact=one 937 if(.not.lid.or..not.ljd) fact=half 938 rx=xix-xw(jwm,1,jwa)-rwx(jwm,1) 939 ry=xiy-xw(jwm,2,jwa)-rwx(jwm,2) 940 rz=xiz-xw(jwm,3,jwa)-rwx(jwm,3) 941 ri2=one/(rx*rx+ry*ry+rz*rz) 942 if(iss.gt.0) ri2=one/(one/ri2+shift0(1)) 943 if(iss.lt.0) ri2=one/(one/ri2+shift1(1)) 944 ri1=sqrt(ri2) 945 ri6=ri2*ri2*ri2 946 er=ealpha/ri1 947 ferfc=erfc(er) 948 fderfc=ealpha*derfc(er) 949 eq0=eq0+fact*ri1 950 eq=eq+fact*ri1*ferfc 951 e6=e6+fact*ri6 952 e12=e12+fact*ri6*ri6 953 ff=(q*(ri1*ferfc-fderfc)+(cf12*ri6-cf6)*ri6)*ri2 954 df=ff*rx 955 fs(isa,1,ipsw)=fs(isa,1,ipsw)+df 956 fw(jwm,1,jwa,ipsw)=fw(jwm,1,jwa,ipsw)-df 957 zs(isf,1,1,ipsw)=zs(isf,1,1,ipsw)-half*df*rwc(jwm,1) 958 zs(isf,2,1,ipsw)=zs(isf,2,1,ipsw)-half*df*rwc(jwm,2) 959 zs(isf,3,1,ipsw)=zs(isf,3,1,ipsw)-half*df*rwc(jwm,3) 960 zw(1,1,ipsw)=zw(1,1,ipsw)-half*df*rwc(jwm,1) 961 zw(2,1,ipsw)=zw(2,1,ipsw)-half*df*rwc(jwm,2) 962 zw(3,1,ipsw)=zw(3,1,ipsw)-half*df*rwc(jwm,3) 963 df=ff*ry 964 fs(isa,2,ipsw)=fs(isa,2,ipsw)+df 965 fw(jwm,2,jwa,ipsw)=fw(jwm,2,jwa,ipsw)-df 966 zs(isf,1,2,ipsw)=zs(isf,1,2,ipsw)-half*df*rwc(jwm,1) 967 zs(isf,2,2,ipsw)=zs(isf,2,2,ipsw)-half*df*rwc(jwm,2) 968 zs(isf,3,2,ipsw)=zs(isf,3,2,ipsw)-half*df*rwc(jwm,3) 969 zw(1,2,ipsw)=zw(1,2,ipsw)-half*df*rwc(jwm,1) 970 zw(2,2,ipsw)=zw(2,2,ipsw)-half*df*rwc(jwm,2) 971 zw(3,2,ipsw)=zw(3,2,ipsw)-half*df*rwc(jwm,3) 972 df=ff*rz 973 fs(isa,3,ipsw)=fs(isa,3,ipsw)+df 974 fw(jwm,3,jwa,ipsw)=fw(jwm,3,jwa,ipsw)-df 975 zs(isf,1,3,ipsw)=zs(isf,1,3,ipsw)-half*df*rwc(jwm,1) 976 zs(isf,2,3,ipsw)=zs(isf,2,3,ipsw)-half*df*rwc(jwm,2) 977 zs(isf,3,3,ipsw)=zs(isf,3,3,ipsw)-half*df*rwc(jwm,3) 978 zw(1,3,ipsw)=zw(1,3,ipsw)-half*df*rwc(jwm,1) 979 zw(2,3,ipsw)=zw(2,3,ipsw)-half*df*rwc(jwm,2) 980 zw(3,3,ipsw)=zw(3,3,ipsw)-half*df*rwc(jwm,3) 981 108 continue 982 esw(isf,5,ipsw)=esw(isf,5,ipsw)+c12*e12-c6*e6 983 esw(isf,6,ipsw)=esw(isf,6,ipsw)+q*eq 984 if(npener.ne.0) esa(isg)=esa(isg)+c12*e12-c6*e6+q*eq 985 endif 986 106 continue 987 else 988 dqi=zero 989 p2qi=zero 990 p3qi=zero 991 if(ipert2) p2qi=chg(isq1(isa),1,2) 992 if(ipert3) p3qi=chg(isq1(isa),1,3) 993 if(ithint) dqi=chg(isq1(isa),1,4) 994 do 116 jwa=1,nwa 995 q=qi*chg(iwq(jwa),1,iset) 996 c6=vdw(iptr,iwatm(jwa),1,iset) 997 c12=vdw(iptr,iwatm(jwa),3,iset) 998 cf6=six*c6 999 cf12=twelve*c12 1000 eq=zero 1001 eq0=zero 1002 e6=zero 1003 e8=zero 1004 e12=zero 1005 e14=zero 1006 do 117 jnum=1,lswin(is,ipsw) 1007 jwm=lswj(inum+jnum) 1008 ljd=iand(iwdt(jwm),mdynam).eq.ldynam 1009 fact=one 1010 if(.not.lid.or..not.ljd) fact=half 1011 rx=xix-xw(jwm,1,jwa)-rwx(jwm,1) 1012 ry=xiy-xw(jwm,2,jwa)-rwx(jwm,2) 1013 rz=xiz-xw(jwm,3,jwa)-rwx(jwm,3) 1014 ri2=one/(rx*rx+ry*ry+rz*rz) 1015 if(iss.gt.0) ri2=one/(one/ri2+shift0(1)) 1016 if(iss.lt.0) ri2=one/(one/ri2+shift1(1)) 1017 ri1=sqrt(ri2) 1018 ri6=ri2*ri2*ri2 1019 if(ipme.eq.0) then 1020 eq=eq+fact*ri1 1021 ff=(q*ri1+(cf12*ri6-cf6)*ri6)*ri2 1022 else 1023 er=ealpha/ri1 1024 ferfc=erfc(er) 1025 fderfc=ealpha*derfc(er) 1026 eq=eq+fact*ri1*ferfc 1027 ff=(q*(ri1*ferfc-fderfc)+(cf12*ri6-cf6)*ri6)*ri2 1028 endif 1029 e6=e6+fact*ri6 1030 e12=e12+fact*ri6*ri6 1031 if(iss.ne.0) then 1032 e8=e8+fact*ri6*ri2 1033 e14=e14+fact*ri6*ri6*ri2 1034 endif 1035 df=ff*rx 1036 fs(isa,1,ipsw)=fs(isa,1,ipsw)+df 1037 fw(jwm,1,jwa,ipsw)=fw(jwm,1,jwa,ipsw)-df 1038 zs(isf,1,1,ipsw)=zs(isf,1,1,ipsw)-half*df*rwc(jwm,1) 1039 zs(isf,2,1,ipsw)=zs(isf,2,1,ipsw)-half*df*rwc(jwm,2) 1040 zs(isf,3,1,ipsw)=zs(isf,3,1,ipsw)-half*df*rwc(jwm,3) 1041 zw(1,1,ipsw)=zw(1,1,ipsw)-half*df*rwc(jwm,1) 1042 zw(2,1,ipsw)=zw(2,1,ipsw)-half*df*rwc(jwm,2) 1043 zw(3,1,ipsw)=zw(3,1,ipsw)-half*df*rwc(jwm,3) 1044 df=ff*ry 1045 fs(isa,2,ipsw)=fs(isa,2,ipsw)+df 1046 fw(jwm,2,jwa,ipsw)=fw(jwm,2,jwa,ipsw)-df 1047 zs(isf,1,2,ipsw)=zs(isf,1,2,ipsw)-half*df*rwc(jwm,1) 1048 zs(isf,2,2,ipsw)=zs(isf,2,2,ipsw)-half*df*rwc(jwm,2) 1049 zs(isf,3,2,ipsw)=zs(isf,3,2,ipsw)-half*df*rwc(jwm,3) 1050 zw(1,2,ipsw)=zw(1,2,ipsw)-half*df*rwc(jwm,1) 1051 zw(2,2,ipsw)=zw(2,2,ipsw)-half*df*rwc(jwm,2) 1052 zw(3,2,ipsw)=zw(3,2,ipsw)-half*df*rwc(jwm,3) 1053 df=ff*rz 1054 fs(isa,3,ipsw)=fs(isa,3,ipsw)+df 1055 fw(jwm,3,jwa,ipsw)=fw(jwm,3,jwa,ipsw)-df 1056 zs(isf,1,3,ipsw)=zs(isf,1,3,ipsw)-half*df*rwc(jwm,1) 1057 zs(isf,2,3,ipsw)=zs(isf,2,3,ipsw)-half*df*rwc(jwm,2) 1058 zs(isf,3,3,ipsw)=zs(isf,3,3,ipsw)-half*df*rwc(jwm,3) 1059 zw(1,3,ipsw)=zw(1,3,ipsw)-half*df*rwc(jwm,1) 1060 zw(2,3,ipsw)=zw(2,3,ipsw)-half*df*rwc(jwm,2) 1061 zw(3,3,ipsw)=zw(3,3,ipsw)-half*df*rwc(jwm,3) 1062 117 continue 1063 esw(isf,5,ipsw)=esw(isf,5,ipsw)+c12*e12-c6*e6 1064 esw(isf,6,ipsw)=esw(isf,6,ipsw)+q*eq 1065 if(npener.ne.0) esa(isg)=esa(isg)+c12*e12-c6*e6+q*eq 1066 if(ithint) then 1067 dd=half*(vdw(iptr,iwatm(jwa),3,4)*e12-vdw(iptr,iwatm(jwa),1,4)*c6) 1068 if(iss.eq.0) dd=dd+dd 1069 if(iss.gt.0) dd=dd+shift0(4)*(e8*vdw(iptr,iwatm(jwa),1,4)- 1070 + e14*vdw(iptr,iwatm(jwa),3,4)) 1071 if(iss.lt.0) dd=dd+shift1(4)*(e8*vdw(iptr,iwatm(jwa),1,4)- 1072 + e14*vdw(iptr,iwatm(jwa),3,4)) 1073 deriv(3,ipsw)=deriv(3,ipsw)+dd 1074 deriv(14,ipsw)=deriv(14,ipsw)+dd 1075 dd=half*(qi*chg(iwq(jwa),1,4)+chg(iwq(jwa),1,iset)*dqi)*eq0 1076 deriv(5,ipsw)=deriv(5,ipsw)+dd 1077 deriv(16,ipsw)=deriv(16,ipsw)+dd 1078 endif 1079 if(ipert2) then 1080 ep2(ipsw)=ep2(ipsw)+(p2qi*chg(iwq(jwa),1,2)-q)*eq+ 1081 + (vdw(iptr,iwatm(jwa),3,2)-c12)*e12- 1082 + (vdw(iptr,iwatm(jwa),1,2)-c6)*e6 1083 endif 1084 if(ipert3) then 1085 ep3(ipsw)=ep3(ipsw)+(p3qi*chg(iwq(jwa),1,3)-q)*eq+ 1086 + (vdw(iptr,iwatm(jwa),3,3)-c12)*e12- 1087 + (vdw(iptr,iwatm(jwa),1,3)-c6)*e6 1088 endif 1089 116 continue 1090 endif 1091c 1092 102 continue 1093 101 continue 1094 return 1095 endif 1096#endif 1097c 1098cx new stuff end 1099c this subroutine evaluates the solute-solvent forces for nums 1100c solute atoms starting from isfrom. the interacting solvent 1101c molecules are determined from the pairlist. 1102c 1103 isfr=isfrom-1 1104c 1105 if(nrwrec.gt.0) then 1106 do 1 iwm=1,mwm 1107 rtos(iwm)=zero 1108 1 continue 1109 endif 1110c 1111#if defined(CAFE_POLARIZATION) 1112 qfaci=one/qfac 1113#endif 1114c 1115 do 2 ipsw=1,lpsw 1116c 1117c evaluate outer index array 1118c 1119 nswlen(ipsw)=0 1120 lswndx(0,ipsw)=0 1121 number=0 1122 do 3 isa=1,nums 1123 if(number+lswin(isa,ipsw).gt.mscr .or. 1124 + (ismf(isfr+isa).ne.ismf(isfr+isa-1).and. 1125 + number.gt.0)) then 1126 nswlen(ipsw)=nswlen(ipsw)+1 1127 lswndx(nswlen(ipsw),ipsw)=isa-1 1128 number=0 1129 endif 1130 number=number+lswin(isa,ipsw) 1131 3 continue 1132 if(number.gt.0) then 1133 nswlen(ipsw)=nswlen(ipsw)+1 1134 lswndx(nswlen(ipsw),ipsw)=nums 1135 endif 1136c 1137 do 4 ispm=1,nswlen(ipsw) 1138 isf=ismf(isfr+lswndx(ispm,ipsw)) 1139 do 5 isa=0,nums 1140 list(isa)=0 1141 5 continue 1142 nax=0 1143c 1144 do 6 isa=lswndx(ispm-1,ipsw)+1,lswndx(ispm,ipsw) 1145 ispj=lswjpt(isa,ipsw)-1 1146 ism=isml(isfr+isa) 1147 if(lpbc.or.lpbcs.or.ism.eq.0) then 1148 do 7 ismn=1,lswin(isa,ipsw) 1149 lswptr=lswj(ispj+ismn) 1150 rwc(nax+ismn,1)=xs(isfr+isa,1)-xwm(lswptr,1) 1151 rwc(nax+ismn,2)=xs(isfr+isa,2)-xwm(lswptr,2) 1152 rwc(nax+ismn,3)=xs(isfr+isa,3)-xwm(lswptr,3) 1153 isrx(nax+ismn)=0 1154 7 continue 1155 if(lpbc.or.lpbcs) 1156 + call cf_pbc(0,rwc,mscr,rwx,mscr,nax,1,lswin(isa,ipsw)) 1157 endif 1158 if(ism.gt.0) then 1159 do 8 ismn=1,lswin(isa,ipsw) 1160 lswptr=lswj(ispj+ismn) 1161 rwc(nax+ismn,1)=xsm(ism,1)-xwm(lswptr,1) 1162 rwc(nax+ismn,2)=xsm(ism,2)-xwm(lswptr,2) 1163 rwc(nax+ismn,3)=xsm(ism,3)-xwm(lswptr,3) 1164 8 continue 1165 endif 1166c 1167c if(lssscl) then 1168c isrst=iand(isss(isfr+isa),3) 1169c isatm=isat(isfr+isa) 1170c do 9 iwa=1,mwa 1171c iasst=iass(isatm,iwatm(iwa)) 1172c if(iasst.le.0.or.iasst.ge.3.or.isrst.ne.iasst) isrst=0 1173c 9 continue 1174c do 10 ismn=1,lswin(isa,ipsw) 1175c isrx(nax+ismn)=isrst 1176c 10 continue 1177c endif 1178c 1179c write(*,'(4i5,2f12.6)') 1180c + lssscl,isga(isa),isss(isfr+isa),iand(isss(isfr+isa),6), 1181c + shift0(1),shift1(1) 1182 if(lssscl) then 1183 do 10 ismn=1,lswin(isa,ipsw) 1184c isrx(nax+ismn)=isss(isfr+isa) 1185 if(iand(isss(isfr+isa),6).eq.2) isrx(nax+ismn)=-1 1186 if(iand(isss(isfr+isa),6).eq.4) isrx(nax+ismn)=1 1187 10 continue 1188 endif 1189c 1190 if(iand(isdt(isfr+isa),mdynam).eq.ldynam) then 1191 do 11 ismn=1,lswin(isa,ipsw) 1192 lswptr=lswj(ispj+ismn) 1193 xi(nax+ismn,1)=xs(isfr+isa,1) 1194 xi(nax+ismn,2)=xs(isfr+isa,2) 1195 xi(nax+ismn,3)=xs(isfr+isa,3) 1196#if defined(CAFE_POLARIZATION) 1197 pl(nax+ismn,1)=ps(isfr+isa,1,1) 1198 pl(nax+ismn,2)=ps(isfr+isa,2,1) 1199 pl(nax+ismn,3)=ps(isfr+isa,3,1) 1200#endif 1201 isal(nax+ismn)=isfr+isa 1202c if(iand(iwdt(lswptr),mdynam).ne.ldynam) then 1203c facu(nax+ismn)=half 1204c else 1205 facu(nax+ismn)=one 1206c endif 1207c if(includ.eq.1) facu(nax+ismn)=one 1208 11 continue 1209 else 1210 do 12 ismn=1,lswin(isa,ipsw) 1211 lswptr=lswj(ispj+ismn) 1212 xi(nax+ismn,1)=xs(isfr+isa,1) 1213 xi(nax+ismn,2)=xs(isfr+isa,2) 1214 xi(nax+ismn,3)=xs(isfr+isa,3) 1215#if defined(CAFE_POLARIZATION) 1216 pl(nax+ismn,1)=ps(isfr+isa,1,1) 1217 pl(nax+ismn,2)=ps(isfr+isa,2,1) 1218 pl(nax+ismn,3)=ps(isfr+isa,3,1) 1219#endif 1220 isal(nax+ismn)=isfr+isa 1221 if(iand(iwdt(lswptr),mdynam).eq.ldynam) then 1222 facu(nax+ismn)=one 1223 else 1224 facu(nax+ismn)=zero 1225 endif 1226 if(includ.eq.1) facu(nax+ismn)=one 1227 12 continue 1228 endif 1229c 1230 if(.not.lpbc.and..not.lpbcs) then 1231 do 13 iwa=1,mwa 1232 do 14 ismn=1,lswin(isa,ipsw) 1233 lswptr=lswj(ispj+ismn) 1234 xj(nax+ismn,1,iwa)=xw(lswptr,1,iwa) 1235 xj(nax+ismn,2,iwa)=xw(lswptr,2,iwa) 1236 xj(nax+ismn,3,iwa)=xw(lswptr,3,iwa) 1237#if defined(CAFE_POLARIZATION) 1238 pj(nax+ismn,1,iwa)=pw(lswptr,1,iwa,1) 1239 pj(nax+ismn,2,iwa)=pw(lswptr,2,iwa,1) 1240 pj(nax+ismn,3,iwa)=pw(lswptr,3,iwa,1) 1241#endif 1242 14 continue 1243 13 continue 1244 else 1245 do 15 ismn=1,lswin(isa,ipsw) 1246 rwc(nax+ismn,1)=rwc(nax+ismn,1)-rwx(ismn,1) 1247 rwc(nax+ismn,2)=rwc(nax+ismn,2)-rwx(ismn,2) 1248 rwc(nax+ismn,3)=rwc(nax+ismn,3)-rwx(ismn,3) 1249 15 continue 1250 do 16 iwa=1,mwa 1251 do 17 ismn=1,lswin(isa,ipsw) 1252 lswptr=lswj(ispj+ismn) 1253 xj(nax+ismn,1,iwa)=xw(lswptr,1,iwa)+rwx(ismn,1) 1254 xj(nax+ismn,2,iwa)=xw(lswptr,2,iwa)+rwx(ismn,2) 1255 xj(nax+ismn,3,iwa)=xw(lswptr,3,iwa)+rwx(ismn,3) 1256#if defined(CAFE_POLARIZATION) 1257 pj(nax+ismn,1,iwa)=pw(lswptr,1,iwa,1) 1258 pj(nax+ismn,2,iwa)=pw(lswptr,2,iwa,1) 1259 pj(nax+ismn,3,iwa)=pw(lswptr,3,iwa,1) 1260#endif 1261 17 continue 1262 16 continue 1263 endif 1264c 1265 nax=nax+lswin(isa,ipsw) 1266 list(isa)=nax 1267 6 continue 1268c 1269 do 22 iax=1,nax 1270 fi(iax,1,1)=zero 1271 fi(iax,2,1)=zero 1272 fi(iax,3,1)=zero 1273 22 continue 1274 do 23 iwa=1,mwa 1275 do 24 iax=1,nax 1276 fj(iax,1,iwa)=zero 1277 fj(iax,2,iwa)=zero 1278 fj(iax,3,iwa)=zero 1279 24 continue 1280 23 continue 1281c if(npener.ne.0) then 1282c do 25 iax=1,nax 1283c u(iax)=zero 1284c 25 continue 1285c endif 1286 do 26 iwa=1,mwa 1287 do 27 iax=1,nax 1288 f(iax)=zero 1289 rwx(iax,1)=xi(iax,1)-xj(iax,1,iwa) 1290 rwx(iax,2)=xi(iax,2)-xj(iax,2,iwa) 1291 rwx(iax,3)=xi(iax,3)-xj(iax,3,iwa) 1292 rwi2(iax)=one/(rwx(iax,1)**2+rwx(iax,2)**2+rwx(iax,3)**2) 1293 rtmp=rwi2(iax) 1294 if(isrx(iax).gt.0) rwi2(iax)=one/(one/rwi2(iax)+shift0(1)) 1295 if(isrx(iax).lt.0) rwi2(iax)=one/(one/rwi2(iax)+shift1(1)) 1296c write(*,'(3i5,2f12.6)') 1297c + isga(isal(iax)),isal(iax),isrx(iax),rtmp,rwi2(iax) 1298 27 continue 1299c 1300c Lennard-Jones interactions 1301c 1302 iwatmi=iwatm(iwa) 1303 eterml=zero 1304 do 28 iax=1,nax 1305 isa=isal(iax) 1306 isatm=isat(isa) 1307 c6=vdw(isatm,iwatmi,1,iset) 1308 cf6=six*c6 1309 c12=vdw(isatm,iwatmi,3,iset) 1310 cf12=twelve*c12 1311 rwi6(iax)=rwi2(iax)*rwi2(iax)*rwi2(iax) 1312 rw(iax)=facu(iax)*(c12*rwi6(iax)-c6)*rwi6(iax) 1313 eterml=eterml+rw(iax) 1314 if(npener.ne.0) then 1315 esa(isga(isa))=esa(isga(isa))+half*rw(iax) 1316 endif 1317 f(iax)=f(iax)+(cf12*rwi6(iax)-cf6)*rwi6(iax)*rwi2(iax) 1318 28 continue 1319 esw(isf,5,ipsw)=esw(isf,5,ipsw)+eterml 1320c 1321#if !defined(CAFE_POLARIZATION) 1322c 1323c electrostatic interactions 1324c 1325 qwas=chg(iwq(iwa),1,iset) 1326 if(abs(qwas).gt.small.or.ithint.or. 1327 + (ifstep-1.eq.((ifstep-1)/nfrdf)*nfrdf.and.ngrsw.gt.0)) then 1328 do 29 iax=1,nax 1329 rwi1(iax)=sqrt(rwi2(iax)) 1330 29 continue 1331 endif 1332 etermq=zero 1333 if(abs(qwas).gt.small) then 1334 if(ipme.eq.0) then 1335 do 30 iax=1,nax 1336 isa=isal(iax) 1337 q=qwas*chg(isq1(isa),1,iset) 1338 rw(iax)=facu(iax)*q*rwi1(iax) 1339 etermq=etermq+rw(iax) 1340 if(npener.ne.0) then 1341 esa(isga(isa))=esa(isga(isa))+half*rw(iax) 1342 endif 1343 f(iax)=f(iax)+q*rwi1(iax)*rwi2(iax) 1344 30 continue 1345 else 1346 do 31 iax=1,nax 1347 isa=isal(iax) 1348 q=qwas*chg(isq1(isa),1,iset) 1349 ferfc=erfc(ealpha/rwi1(iax)) 1350 fderfc=ealpha*derfc(ealpha/rwi1(iax)) 1351 rw(iax)=facu(iax)*q*rwi1(iax) 1352 etermq=etermq+ferfc*rw(iax) 1353 if(npener.ne.0) then 1354 esa(isga(isa))=esa(isga(isa))+half*rw(iax) 1355 endif 1356 f(iax)=f(iax)+q*rwi2(iax)*(ferfc*rwi1(iax)-fderfc) 1357 31 continue 1358 endif 1359 esw(isf,6,ipsw)=esw(isf,6,ipsw)+etermq 1360 endif 1361c 1362c reaction field contribution 1363c 1364 if(ireact.ne.0) then 1365 do 32 iax=1,nax 1366 isa=isal(iax) 1367 q=qwas*chg(isq1(isa),1,iset) 1368 rw(iax)=facu(iax)*q*rffsw/rwi2(iax) 1369 if(npener.ne.0) then 1370 esa(isga(isa))=esa(isga(isa))+half*q*rffsw/rwi2(iax) 1371 endif 1372 f(iax)=f(iax)-two*rffsw*q 1373 32 continue 1374 do 33 isa=lswndx(ispm-1,ipsw)+1,lswndx(ispm,ipsw) 1375 if(list(isa).gt.list(isa-1)) then 1376 sumen=zero 1377 do 34 iax=list(isa-1)+1,list(isa) 1378 sumen=sumen+rw(iax) 1379 34 continue 1380 endif 1381 33 continue 1382 endif 1383#else 1384 qj=chg(iwq(iwa),1,iset) 1385 qaj=qfaci*qj 1386c dqj=qwa(iwa,4) 1387c dqaj=qfaci*dqj 1388 paj=chg(iwq(iwa),2,iset) 1389c dpaj=pwa(iwa,4) 1390 eswqsm=zero 1391 eswpsm=zero 1392c dswqsm=zero 1393c dswqws=zero 1394c dswqps=zero 1395c dswpss=zero 1396c dswpws=zero 1397 do 21 iax=1,nax 1398 isa=isal(iax) 1399 qi=chg(isq1(isa),1,iset) 1400c dqi=qsa(isa,4,1) 1401 qai=qfaci*qi 1402c dqai=qfaci*dqi 1403 pai=chg(isq1(isa),2,iset) 1404c dpai=psa(isa,4) 1405 pix=pai*pl(iax,1) 1406 piy=pai*pl(iax,2) 1407 piz=pai*pl(iax,3) 1408 pjx=paj*pj(iax,1,iwa) 1409 pjy=paj*pj(iax,2,iwa) 1410 pjz=paj*pj(iax,3,iwa) 1411 rwx(iax,1)=xi(iax,1)-xj(iax,1,iwa) 1412 rwx(iax,2)=xi(iax,2)-xj(iax,2,iwa) 1413 rwx(iax,3)=xi(iax,3)-xj(iax,3,iwa) 1414 rx=-rwx(iax,1) 1415 ry=-rwx(iax,2) 1416 rz=-rwx(iax,3) 1417 rwi2(iax)=one/(rx**2+ry**2+rz**2) 1418 rwi1(iax)=sqrt(rwi2(iax)) 1419 ri1=rwi1(iax) 1420 ri2=rwi2(iax) 1421 ri3=qfac*qfac*ri1*ri2 1422 rmi=three*(rx*pix+ry*piy+rz*piz)*ri2 1423 rmj=three*(rx*pjx+ry*pjy+rz*pjz)*ri2 1424 if(ipolt.eq.1) then 1425 fri=((-qai)*qaj+qai*rmj-qaj*rmi)*ri3 1426 fmi=(qaj)*ri3 1427 fmj=(-qai)*ri3 1428 else 1429 rmm=three*(pix*pjx+piy*pjy+piz*pjz)*ri2 1430 fri=((-qai)*qaj+qai*rmj-qaj*rmi+5.0*rmi*rmj/three-rmm)*ri3 1431 fmi=(qaj-rmj)*ri3 1432 fmj=((-qai)-rmi)*ri3 1433 endif 1434 fi(iax,1,1)=fi(iax,1,1)+fri*rx+fmi*pix+fmj*pjx 1435 fi(iax,2,1)=fi(iax,2,1)+fri*ry+fmi*piy+fmj*pjy 1436 fi(iax,3,1)=fi(iax,3,1)+fri*rz+fmi*piz+fmj*pjz 1437 fj(iax,1,iwa)=fj(iax,1,iwa)-(fri*rx+fmi*pix+fmj*pjx) 1438 fj(iax,2,iwa)=fj(iax,2,iwa)-(fri*ry+fmi*piy+fmj*pjy) 1439 fj(iax,3,iwa)=fj(iax,3,iwa)-(fri*rz+fmi*piz+fmj*pjz) 1440 eswqsm=eswqsm+qi*facu(iax)*ri1 1441 eswpsm=eswpsm+facu(iax)*(qai*rmj-qaj*rmi)*ri1 1442c if(ithint.ne.0) then 1443c dpix=dpai*pl(iax,1) 1444c dpiy=dpai*pl(iax,2) 1445c dpiz=dpai*pl(iax,3) 1446c dpjx=dpaj*pj(iax,1,jwa) 1447c dpjy=dpaj*pj(iax,2,jwa) 1448c dpjz=dpaj*pj(iax,3,jwa) 1449c drmi=three*(rx*dpix+ry*dpiy+rz*dpiz)*ri2 1450c drmj=three*(rx*dpjx+ry*dpjy+rz*dpjz)*ri2 1451c dswqsm=dswqsm+dqi*facu(iax)*ri1 1452c dswqws=dswqws+drmj*ri1 1453c dswqps=dswqps+dqai*rmj*ri1 1454c dswpss=dswpss-drmi*ri1 1455c dswpws=dswpws+qai*drmj*ri1 1456c endif 1457 zxx=(-half)*(fri*rx+fmi*pix+fmj*pjx)*rwc(iax,1) 1458 zyx=(-half)*(fri*rx+fmi*pix+fmj*pjx)*rwc(iax,2) 1459 zzx=(-half)*(fri*rx+fmi*pix+fmj*pjx)*rwc(iax,3) 1460 zxy=(-half)*(fri*ry+fmi*piy+fmj*pjy)*rwc(iax,1) 1461 zyy=(-half)*(fri*ry+fmi*piy+fmj*pjy)*rwc(iax,2) 1462 zzy=(-half)*(fri*ry+fmi*piy+fmj*pjy)*rwc(iax,3) 1463 zxz=(-half)*(fri*rz+fmi*piz+fmj*pjz)*rwc(iax,1) 1464 zyz=(-half)*(fri*rz+fmi*piz+fmj*pjz)*rwc(iax,2) 1465 zzz=(-half)*(fri*rz+fmi*piz+fmj*pjz)*rwc(iax,3) 1466 zw(1,1,ipsw)=zw(1,1,ipsw)+zxx 1467 zw(2,1,ipsw)=zw(2,1,ipsw)+zyx 1468 zw(3,1,ipsw)=zw(3,1,ipsw)+zzx 1469 zw(1,2,ipsw)=zw(1,2,ipsw)+zxy 1470 zw(2,2,ipsw)=zw(2,2,ipsw)+zyy 1471 zw(3,2,ipsw)=zw(3,2,ipsw)+zzy 1472 zw(1,3,ipsw)=zw(1,3,ipsw)+zxz 1473 zw(2,3,ipsw)=zw(2,3,ipsw)+zyz 1474 zw(3,3,ipsw)=zw(3,3,ipsw)+zzz 1475 zs(isf,1,1,ipsw)=zs(isf,1,1,ipsw)+zxx 1476 zs(isf,2,1,ipsw)=zs(isf,2,1,ipsw)+zyx 1477 zs(isf,3,1,ipsw)=zs(isf,3,1,ipsw)+zzx 1478 zs(isf,1,2,ipsw)=zs(isf,1,2,ipsw)+zxy 1479 zs(isf,2,2,ipsw)=zs(isf,2,2,ipsw)+zyy 1480 zs(isf,3,2,ipsw)=zs(isf,3,2,ipsw)+zzy 1481 zs(isf,1,3,ipsw)=zs(isf,1,3,ipsw)+zxz 1482 zs(isf,2,3,ipsw)=zs(isf,2,3,ipsw)+zyz 1483 zs(isf,3,3,ipsw)=zs(isf,3,3,ipsw)+zzz 1484 21 continue 1485#endif 1486c 1487 do 35 iax=1,nax 1488 fi(iax,1,1)=fi(iax,1,1)+f(iax)*rwx(iax,1) 1489 fi(iax,2,1)=fi(iax,2,1)+f(iax)*rwx(iax,2) 1490 fi(iax,3,1)=fi(iax,3,1)+f(iax)*rwx(iax,3) 1491 fj(iax,1,iwa)=fj(iax,1,iwa)-f(iax)*rwx(iax,1) 1492 fj(iax,2,iwa)=fj(iax,2,iwa)-f(iax)*rwx(iax,2) 1493 fj(iax,3,iwa)=fj(iax,3,iwa)-f(iax)*rwx(iax,3) 1494 35 continue 1495 do 136 iy=1,3 1496 do 36 ix=1,3 1497 sumen=zero 1498 do 37 iax=1,nax 1499 sumen=sumen-half*f(iax)*rwx(iax,iy)*rwc(iax,ix) 1500 37 continue 1501 zs(isf,ix,iy,ipsw)=zs(isf,ix,iy,ipsw)+sumen 1502 zw(ix,iy,ipsw)=zw(ix,iy,ipsw)+sumen 1503 36 continue 1504 136 continue 1505c 1506c Radial distribution functions 1507c 1508c if(ifstep-1.eq.((ifstep-1)/nfrdf)*nfrdf .and. ngrsw.gt.0) then 1509c do 38 igc=1,ngc 1510c if(ngt(igc).eq.2) then 1511c if(iagc(igc).eq.iwa) then 1512c igr=igrc(igc) 1513c do 39 iax=1,nax 1514c if(isga(isal(iax)).eq.jagc(igc)) then 1515c indx=int(one/(rwi1(iax)*drdf)) 1516c if(indx.gt.ngl) indx=ngl 1517c rdf(indx,igr)=rdf(indx,igr)+rdfvol 1518c endif 1519c 39 continue 1520c endif 1521c endif 1522c 38 continue 1523c endif 1524c 1525c Thermodynamic integration 1526c 1527 if(ithint) then 1528 if(ith(2).or.ith(14)) then 1529 if(.not.lssscl) then 1530 do 40 iax=1,nax 1531 isa=isal(iax) 1532 isatm=isat(isa) 1533 c64=vdw(isatm,iwatm(iwa),1,4) 1534 c124=vdw(isatm,iwatm(iwa),3,4) 1535 dercon=half*(c124*rwi6(iax)-c64)*rwi6(iax) 1536 deriv(3,ipsw)=deriv(3,ipsw)+dercon 1537 deriv(14,ipsw)=deriv(14,ipsw)+dercon 1538#if defined(CAFE_FORCES) 1539 if(npgdec.gt.1) dera(1,isga(isa))=dera(1,isga(isa))+dercon 1540#endif 1541 40 continue 1542 else 1543 do 41 iax=1,nax 1544 isa=isal(iax) 1545 isatm=isat(isa) 1546 c64=vdw(isatm,iwatm(iwa),1,4) 1547 c124=vdw(isatm,iwatm(iwa),3,4) 1548 dercon=half*(c124*rwi6(iax)-c64)*rwi6(iax) 1549 if(isrx(iax).gt.0) then 1550 c64=half*three*vdw(isatm,iwatm(iwa),1,iset) 1551 c124=three*vdw(isatm,iwatm(iwa),3,iset) 1552 dercon=dercon+shift0(4)*rwi2(iax)*rwi6(iax)*(c64-c124*rwi6(iax)) 1553 elseif(isrx(iax).lt.0) then 1554 c64=half*three*vdw(isatm,iwatm(iwa),1,iset) 1555 c124=three*vdw(isatm,iwatm(iwa),3,iset) 1556 dercon=dercon+shift1(4)*rwi2(iax)*rwi6(iax)*(c64-c124*rwi6(iax)) 1557 else 1558 c64=vdw(isatm,iwatm(iwa),1,4) 1559 c124=vdw(isatm,iwatm(iwa),3,4) 1560 dercon=half*(c124*rwi6(iax)-c64)*rwi6(iax) 1561 endif 1562 deriv(3,ipsw)=deriv(3,ipsw)+dercon 1563 deriv(14,ipsw)=deriv(14,ipsw)+dercon 1564#if defined(CAFE_FORCES) 1565 if(npgdec.gt.1) dera(1,isga(isa))=dera(1,isga(isa))+dercon 1566#endif 1567 41 continue 1568 endif 1569 endif 1570 if(ith(4).or.ith(16)) then 1571 qj=chg(iwq(iwa),1,iset) 1572 qj4=chg(iwq(iwa),1,4) 1573 derco1=zero 1574 derco2=zero 1575 if(ipme.eq.0) then 1576 if(.not.lssscl) then 1577 do 42 iax=1,nax 1578 isa=isal(iax) 1579 drvco1=qj*chg(isq1(isa),1,4)*rwi1(iax) 1580 derco1=derco1+drvco1 1581 drvco2=chg(isq1(isa),1,iset)*qj4*rwi1(iax) 1582 derco2=derco2+drvco2 1583#if defined(CAFE_FORCES) 1584 if(npgdec.gt.1) 1585 + dera(2,isga(isa))=dera(2,isga(isa))+half*(drvco1+drvco2) 1586#endif 1587 42 continue 1588 deriv(5,ipsw)=deriv(5,ipsw)+derco1 1589 deriv(16,ipsw)=deriv(16,ipsw)+derco2 1590 else 1591 derco3=zero 1592 do 43 iax=1,nax 1593 isa=isal(iax) 1594 drvco1=qj*chg(isq1(isa),1,4)*rwi1(iax) 1595 derco1=derco1+drvco1 1596 drvco2=chg(isq1(isa),1,iset)*qj4*rwi1(iax) 1597 derco2=derco2+drvco2 1598 drvco3=zero 1599 if(isrx(iax).gt.0) then 1600 drvco3=(-half)*shift0(4)*chg(isq1(isa),1,iset)* 1601 + qj*rwi1(iax)*rwi2(iax) 1602 elseif(isrx(iax).lt.0) then 1603 drvco3=(-half)*shift1(4)*chg(isq1(isa),1,iset)* 1604 + qj*rwi1(iax)*rwi2(iax) 1605 endif 1606 derco3=derco3+drvco3 1607#if defined(CAFE_FORCES) 1608 if(npgdec.gt.1) dera(2,isga(isa))=dera(2,isga(isa))+ 1609 + half*(drvco1+drvco2+drvco3) 1610#endif 1611 43 continue 1612 deriv(5,ipsw)=deriv(5,ipsw)+derco1+half*derco3 1613 deriv(16,ipsw)=deriv(16,ipsw)+derco2+half*derco3 1614 endif 1615 else 1616 if(.not.lssscl) then 1617 do 142 iax=1,nax 1618 isa=isal(iax) 1619 drvco1=qj*chg(isq1(isa),1,4)*rwi1(iax) 1620 derco1=derco1+drvco1 1621 drvco2=chg(isq1(isa),1,iset)*qj4*rwi1(iax) 1622 derco2=derco2+drvco2 1623#if defined(CAFE_FORCES) 1624 if(npgdec.gt.1) 1625 + dera(2,isga(isa))=dera(2,isga(isa))+half*(drvco1+drvco2) 1626#endif 1627 142 continue 1628 deriv(5,ipsw)=deriv(5,ipsw)+derco1 1629 deriv(16,ipsw)=deriv(16,ipsw)+derco2 1630 else 1631 derco3=zero 1632 do 143 iax=1,nax 1633 isa=isal(iax) 1634 drvco1=qj*chg(isq1(isa),1,4)*rwi1(iax) 1635 derco1=derco1+drvco1 1636 drvco2=chg(isq1(isa),1,iset)*qj4*rwi1(iax) 1637 derco2=derco2+drvco2 1638 drvco3=zero 1639 if(isrx(iax).gt.0) then 1640 drvco3=(-half)*shift0(4)*chg(isq1(isa),1,iset)* 1641 + qj*rwi1(iax)*rwi2(iax) 1642 elseif(isrx(iax).lt.0) then 1643 drvco3=(-half)*shift1(4)*chg(isq1(isa),1,iset)* 1644 + qj*rwi1(iax)*rwi2(iax) 1645 endif 1646 derco3=derco3+drvco3 1647#if defined(CAFE_FORCES) 1648 if(npgdec.gt.1) dera(2,isga(isa))=dera(2,isga(isa))+ 1649 + half*(drvco1+drvco2+drvco3) 1650#endif 1651 143 continue 1652 deriv(5,ipsw)=deriv(5,ipsw)+derco1+half*derco3 1653 deriv(16,ipsw)=deriv(16,ipsw)+derco2+half*derco3 1654 endif 1655 endif 1656 endif 1657 endif 1658c 1659c Thermodynamic perturbation 1 1660c 1661 if(ipert2) then 1662 if(ip2(2).or.ip2(14)) then 1663 iwatyp=iwatm(iwa) 1664 if(.not.lssscl) then 1665 do 44 iax=1,nax 1666 isa=isal(iax) 1667 c6p=vdw(isat(isa),iwatyp,1,2) 1668 c12p=vdw(isat(isa),iwatyp,3,2) 1669 ep2(ipsw)=ep2(ipsw)+facu(iax)*(c12p*rwi6(iax)-c6p)*rwi6(iax) 1670 44 continue 1671 else 1672 do 45 iax=1,nax 1673 isa=isal(iax) 1674 c6p=vdw(isat(isa),iwatyp,1,2) 1675 c12p=vdw(isat(isa),iwatyp,3,2) 1676 if(isrx(iax).gt.0) then 1677 rwi6(iax)=(one/(one/rwi2(iax)-shift0(1)+shift0(2)))**3 1678 elseif(isrx(iax).lt.0) then 1679 rwi6(iax)=(one/(one/rwi2(iax)-shift1(1)+shift1(2)))**3 1680 else 1681 rwi6(iax)=rwi2(iax)**3 1682 endif 1683 ep2(ipsw)=ep2(ipsw)+facu(iax)*(c12p*rwi6(iax)-c6p)*rwi6(iax) 1684 45 continue 1685 endif 1686 ep2(ipsw)=ep2(ipsw)-eterml 1687 endif 1688 if(ip2(4).or.ip2(5).or.ip2(16).or.ip2(17)) then 1689 qj=chg(iwq(iwa),1,2) 1690 if(ipme.eq.0) then 1691 if(.not.lssscl) then 1692 do 46 iax=1,nax 1693 isa=isal(iax) 1694 rwx(iax,1)=xi(iax,1)-xj(iax,1,iwa) 1695 rwx(iax,2)=xi(iax,2)-xj(iax,2,iwa) 1696 rwx(iax,3)=xi(iax,3)-xj(iax,3,iwa) 1697 rwi2(iax)=one/(rwx(iax,1)**2+rwx(iax,2)**2+rwx(iax,3)**2) 1698 rwi1(iax)=sqrt(rwi2(iax)) 1699 ep2(ipsw)=ep2(ipsw)+facu(iax)*chg(isq1(isa),1,2)*qj*rwi1(iax) 1700 46 continue 1701 else 1702 do 47 iax=1,nax 1703 isa=isal(iax) 1704 rwx(iax,1)=xi(iax,1)-xj(iax,1,iwa) 1705 rwx(iax,2)=xi(iax,2)-xj(iax,2,iwa) 1706 rwx(iax,3)=xi(iax,3)-xj(iax,3,iwa) 1707 rwi6(iax)=one/(rwx(iax,1)**2+rwx(iax,2)**2+rwx(iax,3)**2) 1708 if(isrx(iax).gt.0) then 1709 rwi6(iax)=one/(one/rwi6(iax)+shift0(2)) 1710 elseif(isrx(iax).lt.0) then 1711 rwi6(iax)=one/(one/rwi6(iax)+shift1(2)) 1712 endif 1713 rwi1(iax)=sqrt(rwi6(iax)) 1714 ep2(ipsw)=ep2(ipsw)+facu(iax)*chg(isq1(isa),1,2)*qj*rwi1(iax) 1715 47 continue 1716 endif 1717 else 1718 if(.not.lssscl) then 1719 do 146 iax=1,nax 1720 isa=isal(iax) 1721 rwx(iax,1)=xi(iax,1)-xj(iax,1,iwa) 1722 rwx(iax,2)=xi(iax,2)-xj(iax,2,iwa) 1723 rwx(iax,3)=xi(iax,3)-xj(iax,3,iwa) 1724 rwi2(iax)=one/(rwx(iax,1)**2+rwx(iax,2)**2+rwx(iax,3)**2) 1725 rwi1(iax)=sqrt(rwi2(iax)) 1726 ep2(ipsw)=ep2(ipsw)+facu(iax)*erfc(ealpha/rwi1(iax))* 1727 + chg(isq1(isa),1,2)*qj*rwi1(iax) 1728 146 continue 1729 else 1730 do 147 iax=1,nax 1731 isa=isal(iax) 1732 rwx(iax,1)=xi(iax,1)-xj(iax,1,iwa) 1733 rwx(iax,2)=xi(iax,2)-xj(iax,2,iwa) 1734 rwx(iax,3)=xi(iax,3)-xj(iax,3,iwa) 1735 rwi6(iax)=one/(rwx(iax,1)**2+rwx(iax,2)**2+rwx(iax,3)**2) 1736 if(isrx(iax).gt.0) then 1737 rwi6(iax)=one/(one/rwi6(iax)+shift0(2)) 1738 elseif(isrx(iax).lt.0) then 1739 rwi6(iax)=one/(one/rwi6(iax)+shift1(2)) 1740 endif 1741 rwi1(iax)=sqrt(rwi6(iax)) 1742 ep2(ipsw)=ep2(ipsw)+facu(iax)*erfc(ealpha/rwi1(iax))* 1743 + chg(isq1(isa),1,2)*qj*rwi1(iax) 1744 147 continue 1745 endif 1746 endif 1747 ep2(ipsw)=ep2(ipsw)-etermq 1748 endif 1749 endif 1750c 1751c Thermodynamic perturbation 2 1752c 1753 if(ipert3) then 1754 if(ip3(2).or.ip3(14)) then 1755 iwatyp=iwatm(iwa) 1756 if(.not.lssscl) then 1757 do 48 iax=1,nax 1758 isa=isal(iax) 1759 c6p=vdw(isat(isa),iwatyp,1,3) 1760 c12p=vdw(isat(isa),iwatyp,3,3) 1761 ep3(ipsw)=ep3(ipsw)+facu(iax)*(c12p*rwi6(iax)-c6p)*rwi6(iax) 1762 48 continue 1763 else 1764 do 49 iax=1,nax 1765 isa=isal(iax) 1766 c6p=vdw(isat(isa),iwatyp,1,3) 1767 c12p=vdw(isat(isa),iwatyp,3,3) 1768 if(isrx(iax).gt.0) then 1769 rwi6(iax)=(one/(one/rwi2(iax)-shift0(1)+shift0(3)))**3 1770 elseif(isrx(iax).lt.0) then 1771 rwi6(iax)=(one/(one/rwi2(iax)-shift1(1)+shift1(3)))**3 1772 else 1773 rwi6(iax)=rwi2(iax)**3 1774 endif 1775 ep3(ipsw)=ep3(ipsw)+facu(iax)*(c12p*rwi6(iax)-c6p)*rwi6(iax) 1776 49 continue 1777 endif 1778 ep3(ipsw)=ep3(ipsw)-eterml 1779 endif 1780 if(ip2(4).or.ip2(5).or.ip2(16).or.ip2(17)) then 1781 qj=chg(iwq(iwa),1,3) 1782 if(ipme.eq.0) then 1783 if(.not.lssscl) then 1784 do 50 iax=1,nax 1785 isa=isal(iax) 1786 rwx(iax,1)=xi(iax,1)-xj(iax,1,iwa) 1787 rwx(iax,2)=xi(iax,2)-xj(iax,2,iwa) 1788 rwx(iax,3)=xi(iax,3)-xj(iax,3,iwa) 1789 rwi2(iax)=one/(rwx(iax,1)**2+rwx(iax,2)**2+rwx(iax,3)**2) 1790 rwi1(iax)=sqrt(rwi2(iax)) 1791 ep3(ipsw)=ep3(ipsw)+facu(iax)*chg(isq1(isa),1,3)*qj*rwi1(iax) 1792 50 continue 1793 else 1794 do 51 iax=1,nax 1795 isa=isal(iax) 1796 rwx(iax,1)=xi(iax,1)-xj(iax,1,iwa) 1797 rwx(iax,2)=xi(iax,2)-xj(iax,2,iwa) 1798 rwx(iax,3)=xi(iax,3)-xj(iax,3,iwa) 1799 rwi6(iax)=one/(rwx(iax,1)**2+rwx(iax,2)**2+rwx(iax,3)**2) 1800 if(isrx(iax).gt.0) then 1801 rwi6(iax)=one/(one/rwi6(iax)+shift0(3)) 1802 elseif(isrx(iax).lt.0) then 1803 rwi6(iax)=one/(one/rwi6(iax)+shift1(3)) 1804 endif 1805 rwi1(iax)=sqrt(rwi6(iax)) 1806 ep3(ipsw)=ep3(ipsw)+facu(iax)*chg(isq1(isa),1,3)*qj*rwi1(iax) 1807 51 continue 1808 endif 1809 else 1810 if(.not.lssscl) then 1811 do 150 iax=1,nax 1812 isa=isal(iax) 1813 rwx(iax,1)=xi(iax,1)-xj(iax,1,iwa) 1814 rwx(iax,2)=xi(iax,2)-xj(iax,2,iwa) 1815 rwx(iax,3)=xi(iax,3)-xj(iax,3,iwa) 1816 rwi2(iax)=one/(rwx(iax,1)**2+rwx(iax,2)**2+rwx(iax,3)**2) 1817 rwi1(iax)=sqrt(rwi2(iax)) 1818 ep3(ipsw)=ep3(ipsw)+facu(iax)*erfc(ealpha/rwi1(iax))* 1819 + chg(isq1(isa),1,3)*qj*rwi1(iax) 1820 150 continue 1821 else 1822 do 151 iax=1,nax 1823 isa=isal(iax) 1824 rwx(iax,1)=xi(iax,1)-xj(iax,1,iwa) 1825 rwx(iax,2)=xi(iax,2)-xj(iax,2,iwa) 1826 rwx(iax,3)=xi(iax,3)-xj(iax,3,iwa) 1827 rwi6(iax)=one/(rwx(iax,1)**2+rwx(iax,2)**2+rwx(iax,3)**2) 1828 if(isrx(iax).gt.0) then 1829 rwi6(iax)=one/(one/rwi6(iax)+shift0(3)) 1830 elseif(isrx(iax).lt.0) then 1831 rwi6(iax)=one/(one/rwi6(iax)+shift1(3)) 1832 endif 1833 rwi1(iax)=sqrt(rwi6(iax)) 1834 ep3(ipsw)=ep3(ipsw)+facu(iax)*erfc(ealpha/rwi1(iax))* 1835 + chg(isq1(isa),1,3)*qj*rwi1(iax) 1836 151 continue 1837 endif 1838 endif 1839 ep3(ipsw)=ep3(ipsw)-etermq 1840 endif 1841 endif 1842 26 continue 1843c 1844 iax=0 1845 do 52 isa=lswndx(ispm-1,ipsw)+1,lswndx(ispm,ipsw) 1846 ispj=lswjpt(isa,ipsw)-1 1847 do 53 ismn=1,lswin(isa,ipsw) 1848 fs(isfr+isa,1,ipsw)=fs(isfr+isa,1,ipsw)+fi(iax+ismn,1,1) 1849 fs(isfr+isa,2,ipsw)=fs(isfr+isa,2,ipsw)+fi(iax+ismn,2,1) 1850 fs(isfr+isa,3,ipsw)=fs(isfr+isa,3,ipsw)+fi(iax+ismn,3,1) 1851 53 continue 1852 do 54 iwa=1,mwa 1853 do 55 ismn=1,lswin(isa,ipsw) 1854 lswptr=lswj(ispj+ismn) 1855 fw(lswptr,1,iwa,ipsw)=fw(lswptr,1,iwa,ipsw)+fj(iax+ismn,1,iwa) 1856 fw(lswptr,2,iwa,ipsw)=fw(lswptr,2,iwa,ipsw)+fj(iax+ismn,2,iwa) 1857 fw(lswptr,3,iwa,ipsw)=fw(lswptr,3,iwa,ipsw)+fj(iax+ismn,3,iwa) 1858 55 continue 1859c 1860 if(nrwrec.gt.0) then 1861 do 56 ismn=1,lswin(isa,ipsw) 1862 lswptr=lswj(ispj+ismn) 1863 if(rtos(lswptr).lt.rwi2(iax+ismn)) rtos(lswptr)=rwi2(iax+ismn) 1864 56 continue 1865 endif 1866 54 continue 1867c 1868c if(npener.ne.0) then 1869c do 57 ismn=1,lswin(isa,ipsw) 1870c lswptr=lswj(ispj+ismn) 1871c uwms(lswptr)=uwms(lswptr)+u(iax+ismn) 1872c 57 continue 1873c endif 1874c 1875 iax=iax+lswin(isa,ipsw) 1876 52 continue 1877 4 continue 1878 2 continue 1879c 1880 return 1881 end 1882#if defined(CAFE_POLARIZATION) 1883 subroutine cf_fpss(xs,xsm,fs,zs,ps,psp, 1884 + isga,isat,isdt,ismf,isml,isss,isq2,isq3, 1885 + isfrom,nums,lpbc,lpbcs,ess,fss,esa, 1886 + vdw,chg,iass, 1887 + lssndx,lssjpt,lssin,lssj, 1888 + xi,xj,rwx,rwi1,rwi2,rwi6,rwc,f,fi,fj,facu, 1889 + rw,isal,jsal,jmal,jfal,isrx,qsa2,qsa3,pl,pj) 1890#elif defined(CAFE_FORCES) 1891 subroutine cf_fss(xs,xsm,fs,zs, 1892 + isga,isat,isdt,ismf,isml,isss,isq2,isq3,isgm, 1893 + isfrom,nums,lpbc,lpbcs,ess,fss,esa, 1894 + vdw,chg,iass, 1895 + lssndx,lssjpt,lssin,lssj, 1896 + xi,xj,rwx,rwi1,rwi2,rwi6,rwc,f,fi,fj,facu, 1897 + rw,isal,jsal,jmal,jfal,isrx,qsa2,qsa3,dera,lda,rda,uda,lseq) 1898#else 1899c error 1900#endif 1901c 1902c $Id$ 1903c 1904 implicit none 1905c 1906#include "cf_common.fh" 1907#include "mafdecls.fh" 1908c 1909 real*8 rtmp 1910 real*8 xs(msa,3),xsm(msm,3),fs(msa,3,2) 1911 real*8 zs(msf,3,3,2),ess(msf,msf,mpe,2) 1912 real*8 fss(msf,msf,3,2) 1913 real*8 esa(nsa) 1914 integer isga(msa),isat(msa),isdt(msa),ismf(msa) 1915 integer isml(msa),isss(msa),isq2(msa),isq3(msa) 1916 integer isgm(msa),lseq(mseq) 1917c 1918 real*8 vdw(mat,mat,map,mset),chg(mqt,mqp,mset) 1919 logical lpbc,lpbcs 1920 logical ismfcheck 1921c 1922 real*8 xi(mscr,3),xj(mscr,3),rwx(mscr,3),rwi1(mscr) 1923 real*8 rwi2(mscr),rwi6(mscr),rwc(mscr,3),rw(mscr) 1924 real*8 f(mscr),fi(mscr,3),fj(mscr,3) 1925 real*8 qsa2(mscr),qsa3(mscr) 1926 integer isal(mscr),jsal(mscr),jmal(mscr),jfal(mscr),isrx(mscr) 1927 integer lssj(*) 1928 real*8 facu(mscr) 1929 integer nums 1930 integer lssndx(0:msa,2),lssjpt(nums,2),lssin(nums,2) 1931 integer iass(mat,mat),nsslen(2) 1932c 1933#if defined(CAFE_FORCES) 1934 real*8 dera(6,nsatot) 1935 integer lda(16,*) 1936 real*8 rda(11,*),uda(4,*) 1937#endif 1938#if defined(CAFE_POLARIZATION) 1939 real*8 ps(msa,3,2),psp(msa,3,2,2) 1940 real*8 pl(mscr,3),pj(mscr,3) 1941#endif 1942c 1943 integer isa,jsa,i,isf,jsf,ix 1944 integer isfr,isfrom,ism,jsm 1945 integer ipss,number,isslen,nax,jsaptr 1946 integer jnum,lssptr,iax 1947 real*8 dercon 1948c 1949 real*8 c6,c12,cf6,cf12 1950 real*8 c64,c124 1951 real*8 q14,sumen1,sumen2,sumen3 1952 real*8 etermq,eterml 1953 integer istt,jstt 1954#if defined(CAFE_FORCES) 1955 real*8 q,ferfc,fderfc 1956#endif 1957#if defined(CAFE_POLARIZATION) 1958 real*8 qfaci,qi,qj,pai,paj,qai,qaj,rx,ry,rz,ri1,ri2,ri3 1959 real*8 pix,piy,piz,pjx,pjy,pjz,rmi,rmj,fri,fmi,fmj,rmm 1960 real*8 zxx,zyx,zzx,zxy,zyy,zzy,zxz,zyz,zzz,etermp 1961#endif 1962c 1963#include "cf_funcs_dec.fh" 1964#include "bitops_decls.fh" 1965#include "cf_funcs_sfn.fh" 1966#include "bitops_funcs.fh" 1967c 1968#if defined(CAFE_POLARIZATION) 1969 qfaci=one/qfac 1970#endif 1971c 1972 if(nfhop.eq.0) then 1973 do 112 i=1,msa 1974 if(isq2(i).le.0.or.isq3(i).le.0.or. 1975 + isq2(i).gt.mqt.or.isq3(i).gt.mqt) goto 113 1976 qsa2(i)=chg(isq2(i),1,iset) 1977 qsa3(i)=chg(isq3(i),1,iset) 1978 112 continue 1979 113 continue 1980 else 1981 do 1112 i=1,msa 1982 if(isq2(i).le.0.or.isq3(i).le.0.or. 1983 + isq2(i).gt.mqt.or.isq3(i).gt.mqt) goto 1113 1984 qsa2(i)=chg(isq2(i),1,lseq(isgm(i))) 1985 qsa3(i)=chg(isq3(i),1,lseq(isgm(i))) 1986 1112 continue 1987 1113 continue 1988 endif 1989c 1990c solute non-bonded interactions 1991c ============================== 1992c 1993 isfr=isfrom-1 1994c 1995c loop over short and long range pairlists 1996c 1997 do 11 ipss=1,lpss 1998c 1999c evaluate outer index array 2000c 2001 nsslen(ipss)=0 2002 lssndx(0,ipss)=0 2003 number=0 2004 do 12 isa=1,nums 2005 ismfcheck=.true. 2006 if(isa.gt.1) ismfcheck= 2007 + ismf(isfr+isa).ne.ismf(isfr+isa-1) 2008 if(number+lssin(isa,ipss).gt.mscr.or. 2009 + (ismfcheck.and. 2010 + number.gt.0)) then 2011 nsslen(ipss)=nsslen(ipss)+1 2012 lssndx(nsslen(ipss),ipss)=isa-1 2013 number=0 2014 endif 2015 number=number+lssin(isa,ipss) 2016 12 continue 2017 if(number.gt.0) then 2018 nsslen(ipss)=nsslen(ipss)+1 2019 lssndx(nsslen(ipss),ipss)=nums 2020 endif 2021c 2022c loop over number of cycles to complete pairlists 2023c 2024 do 13 isslen=1,nsslen(ipss) 2025c 2026 etermq=zero 2027 eterml=zero 2028c 2029 nax=0 2030 isf=ismf(isfr+lssndx(isslen,ipss)) 2031c 2032c collect coordinates into workarrays 2033c 2034 do 14 isa=lssndx(isslen-1,ipss)+1,lssndx(isslen,ipss) 2035 jsaptr=lssjpt(isa,ipss)-1 2036 ism=isml(isfr+isa) 2037 if(lpbc.or.lpbcs) then 2038 if(ipbtyp.eq.1) then 2039 do 15 jnum=1,lssin(isa,ipss) 2040 lssptr=lssj(jsaptr+jnum) 2041 rwc(nax+jnum,1)=xs(isfr+isa,1)-xs(lssptr,1) 2042 rwc(nax+jnum,2)=xs(isfr+isa,2)-xs(lssptr,2) 2043 rwc(nax+jnum,3)=xs(isfr+isa,3)-xs(lssptr,3) 2044 isrx(nax+jnum)=0 2045 15 continue 2046 else 2047 do 115 jnum=1,lssin(isa,ipss) 2048 lssptr=lssj(jsaptr+jnum) 2049 jsm=isml(lssptr) 2050 rwc(nax+jnum,1)=xsm(ism,1)-xsm(jsm,1) 2051 rwc(nax+jnum,2)=xsm(ism,2)-xsm(jsm,2) 2052 rwc(nax+jnum,3)=xsm(ism,3)-xsm(jsm,3) 2053 isrx(nax+jnum)=0 2054 115 continue 2055 endif 2056 call cf_pbc(0,rwc,mscr,rwx,mscr,nax,1,lssin(isa,ipss)) 2057 endif 2058 do 16 jnum=1,lssin(isa,ipss) 2059 lssptr=lssj(jsaptr+jnum) 2060 jsf=ismf(lssptr) 2061 isal(nax+jnum)=isfr+isa 2062 jsal(nax+jnum)=lssptr 2063 jfal(nax+jnum)=jsf 2064 jmal(nax+jnum)=0 2065 jsm=isml(lssptr) 2066 if(ism.ne.jsm) jmal(nax+jnum)=1 2067 if(ism.gt.0) then 2068 if(jsm.gt.0) then 2069 rwc(nax+jnum,1)=xsm(ism,1)-xsm(jsm,1) 2070 rwc(nax+jnum,2)=xsm(ism,2)-xsm(jsm,2) 2071 rwc(nax+jnum,3)=xsm(ism,3)-xsm(jsm,3) 2072 else 2073 rwc(nax+jnum,1)=xsm(ism,1)-xs(lssptr,1) 2074 rwc(nax+jnum,2)=xsm(ism,2)-xs(lssptr,2) 2075 rwc(nax+jnum,3)=xsm(ism,3)-xs(lssptr,3) 2076 endif 2077 else 2078 if(jsm.gt.0) then 2079 rwc(nax+jnum,1)=xs(isfr+isa,1)-xsm(jsm,1) 2080 rwc(nax+jnum,2)=xs(isfr+isa,2)-xsm(jsm,2) 2081 rwc(nax+jnum,3)=xs(isfr+isa,3)-xsm(jsm,3) 2082 else 2083 rwc(nax+jnum,1)=xs(isfr+isa,1)-xs(lssptr,1) 2084 rwc(nax+jnum,2)=xs(isfr+isa,2)-xs(lssptr,2) 2085 rwc(nax+jnum,3)=xs(isfr+isa,3)-xs(lssptr,3) 2086 endif 2087 endif 2088c 2089 isrx(nax+jnum)=0 2090c 2091 if(lssscl) then 2092c 2093 istt=iand(isss(isfr+isa),48) 2094 jstt=iand(isss(lssptr),48) 2095 if(ism.ne.jsm) then 2096 if(istt.eq.16.or.jstt.eq.16) isrx(nax+jnum)=-1 2097 if(istt.eq.32.or.jstt.eq.32) isrx(nax+jnum)=1 2098 endif 2099c 2100 istt=iand(isss(isfr+isa),384) 2101 jstt=iand(isss(lssptr),384) 2102 if(istt.eq.128.or.jstt.eq.128) isrx(nax+jnum)=-2 2103 if(istt.eq.256.or.jstt.eq.256) isrx(nax+jnum)=2 2104c 2105 istt=iand(isss(isfr+isa),384) 2106 jstt=iand(isss(lssptr),384) 2107 if(istt.eq.128.and.jstt.eq.256) isrx(nax+jnum)=999 2108 if(istt.eq.256.and.jstt.eq.128) isrx(nax+jnum)=999 2109c 2110c write(*,'(5i5)') 2111c + isga(isfr+isa),isga(lssptr),istt,jstt,isrx(nax+jnum) 2112c 2113 endif 2114c 2115 16 continue 2116c 2117 do 17 jnum=1,lssin(isa,ipss) 2118 lssptr=lssj(jsaptr+jnum) 2119 facu(nax+jnum)=zero 2120 if(iand(isdt(isfr+isa),mdynam).eq.ldynam.or. 2121 + iand(isdt(lssptr),mdynam).eq.ldynam) facu(nax+jnum)=one 2122c if((iand(isdt(isfr+isa),mdynam).eq.ldynam.and. 2123c + iand(isdt(lssptr),mdynam).ne.ldynam) .or. 2124c + (iand(isdt(isfr+isa),mdynam).ne.ldynam.and. 2125c + iand(isdt(lssptr),mdynam).eq.ldynam)) facu(nax+jnum)=half 2126 if(includ.eq.1) facu(nax+jnum)=one 2127 17 continue 2128c 2129 if(.not.lpbc.and..not.lpbcs) then 2130 do 18 jnum=1,lssin(isa,ipss) 2131 lssptr=lssj(jsaptr+jnum) 2132 xi(nax+jnum,1)=xs(isfr+isa,1) 2133 xi(nax+jnum,2)=xs(isfr+isa,2) 2134 xi(nax+jnum,3)=xs(isfr+isa,3) 2135 xj(nax+jnum,1)=xs(lssptr,1) 2136 xj(nax+jnum,2)=xs(lssptr,2) 2137 xj(nax+jnum,3)=xs(lssptr,3) 2138#if defined(CAFE_POLARIZATION) 2139 pl(nax+jnum,1)=ps(isfr+isa,1,1) 2140 pl(nax+jnum,2)=ps(isfr+isa,2,1) 2141 pl(nax+jnum,3)=ps(isfr+isa,3,1) 2142 pj(nax+jnum,1)=ps(lssptr,1,1) 2143 pj(nax+jnum,2)=ps(lssptr,2,1) 2144 pj(nax+jnum,3)=ps(lssptr,3,1) 2145#endif 2146 isal(nax+jnum)=isfr+isa 2147 jsal(nax+jnum)=lssptr 2148 18 continue 2149 else 2150 do 19 jnum=1,lssin(isa,ipss) 2151 rwc(nax+jnum,1)=rwc(nax+jnum,1)-rwx(jnum,1) 2152 rwc(nax+jnum,2)=rwc(nax+jnum,2)-rwx(jnum,2) 2153 rwc(nax+jnum,3)=rwc(nax+jnum,3)-rwx(jnum,3) 2154 lssptr=lssj(jsaptr+jnum) 2155 xi(nax+jnum,1)=xs(isfr+isa,1) 2156 xi(nax+jnum,2)=xs(isfr+isa,2) 2157 xi(nax+jnum,3)=xs(isfr+isa,3) 2158 xj(nax+jnum,1)=xs(lssptr,1)+rwx(jnum,1) 2159 xj(nax+jnum,2)=xs(lssptr,2)+rwx(jnum,2) 2160 xj(nax+jnum,3)=xs(lssptr,3)+rwx(jnum,3) 2161#if defined(CAFE_POLARIZATION) 2162 pl(nax+jnum,1)=ps(isfr+isa,1,1) 2163 pl(nax+jnum,2)=ps(isfr+isa,2,1) 2164 pl(nax+jnum,3)=ps(isfr+isa,3,1) 2165 pj(nax+jnum,1)=ps(lssptr,1,1) 2166 pj(nax+jnum,2)=ps(lssptr,2,1) 2167 pj(nax+jnum,3)=ps(lssptr,3,1) 2168#endif 2169 isal(nax+jnum)=isfr+isa 2170 jsal(nax+jnum)=lssptr 2171 19 continue 2172 endif 2173c 2174 nax=nax+lssin(isa,ipss) 2175 14 continue 2176c 2177#if !defined(CAFE_POLARIZATION) 2178c 2179c evaluate electrostatic energies and forces 2180c 2181c etermq=zero 2182 if(.not.lssscl) then 2183 if(ipme.eq.0.or.isolvo.ne.0) then 2184 do 24 iax=1,nax 2185 f(iax)=zero 2186 rwx(iax,1)=xi(iax,1)-xj(iax,1) 2187 rwx(iax,2)=xi(iax,2)-xj(iax,2) 2188 rwx(iax,3)=xi(iax,3)-xj(iax,3) 2189 rwi2(iax)=one/(rwx(iax,1)**2+rwx(iax,2)**2+rwx(iax,3)**2) 2190 rwi1(iax)=sqrt(rwi2(iax)) 2191 isa=isal(iax) 2192 jsa=jsal(iax) 2193c 2194 if(jfal(iax).ne.isf) then 2195 q=qsa2(isa)*qsa2(jsa) 2196 else 2197 q=qsa3(isa)*qsa3(jsa) 2198 endif 2199c 2200 rw(iax)=facu(iax)*q*rwi1(iax) 2201 f(iax)=f(iax)+q*rwi1(iax)*rwi2(iax) 2202 if(ireact.ne.0) then 2203 ess(isf,jfal(iax),6,ipss)=ess(isf,jfal(iax),6,ipss)+ 2204 + facu(iax)*q*rffss/rwi2(iax) 2205 if(npener.ne.0) then 2206 esa(isga(isa))=esa(isga(isa))+half*facu(iax)*q*rffss/rwi2(iax) 2207 esa(isga(jsa))=esa(isga(jsa))+half*facu(iax)*q*rffss/rwi2(iax) 2208 endif 2209 f(iax)=f(iax)-two*q*rffss 2210 endif 2211cx if(ihess.gt.0) then 2212cx h(iax)=three*q*rwi1(iax)*rwi2(iax)*rwi2(iax) 2213cx endif 2214 24 continue 2215 else 2216 do 25 iax=1,nax 2217 f(iax)=zero 2218 rwx(iax,1)=xi(iax,1)-xj(iax,1) 2219 rwx(iax,2)=xi(iax,2)-xj(iax,2) 2220 rwx(iax,3)=xi(iax,3)-xj(iax,3) 2221 rwi2(iax)=one/(rwx(iax,1)**2+rwx(iax,2)**2+rwx(iax,3)**2) 2222 if(isrx(iax).eq.999) then 2223 rwi2(iax)=zero 2224 isrx(iax)=0 2225 endif 2226 rwi1(iax)=sqrt(rwi2(iax)) 2227 isa=isal(iax) 2228 jsa=jsal(iax) 2229 if(jfal(iax).ne.isf) then 2230 q=qsa2(isa)*qsa2(jsa) 2231 else 2232 q=qsa3(isa)*qsa3(jsa) 2233 endif 2234c 2235 ferfc=erfc(ealpha/rwi1(iax)) 2236 fderfc=ealpha*derfc(ealpha/rwi1(iax)) 2237 rw(iax)=ferfc*facu(iax)*q*rwi1(iax) 2238 f(iax)=f(iax)+q*rwi2(iax)*(ferfc*rwi1(iax)-fderfc) 2239 25 continue 2240 endif 2241 else 2242 if(ipme.eq.0.or.isolvo.ne.0) then 2243 do 26 iax=1,nax 2244 f(iax)=zero 2245 rwx(iax,1)=xi(iax,1)-xj(iax,1) 2246 rwx(iax,2)=xi(iax,2)-xj(iax,2) 2247 rwx(iax,3)=xi(iax,3)-xj(iax,3) 2248 rwi2(iax)=one/(rwx(iax,1)**2+rwx(iax,2)**2+rwx(iax,3)**2) 2249 if(isrx(iax).eq.999) then 2250 rwi2(iax)=zero 2251 isrx(iax)=0 2252 endif 2253 rtmp=rwi2(iax) 2254 if(isrx(iax).gt.0) then 2255 rwi2(iax)=one/(one/rwi2(iax)+shift0(1)) 2256 elseif(isrx(iax).lt.0) then 2257 rwi2(iax)=one/(one/rwi2(iax)+shift1(1)) 2258 endif 2259 rwi1(iax)=sqrt(rwi2(iax)) 2260 isa=isal(iax) 2261 jsa=jsal(iax) 2262c write(*,'(3i5,4f12.6)') 2263c + isga(isa),isga(jsa),isrx(iax),shift0(1),shift1(1),rtmp,rwi2(iax) 2264 if(jfal(iax).ne.isf) then 2265 q=qsa2(isa)*qsa2(jsa) 2266 else 2267 q=qsa3(isa)*qsa3(jsa) 2268 endif 2269 rw(iax)=facu(iax)*q*rwi1(iax) 2270 f(iax)=f(iax)+q*rwi1(iax)*rwi2(iax) 2271 if(ireact.ne.0) then 2272 rw(iax)=rw(iax)+facu(iax)*q*rffss/rwi2(iax) 2273 f(iax)=f(iax)-two*q*rffss 2274 endif 2275 26 continue 2276 else 2277 do 126 iax=1,nax 2278 f(iax)=zero 2279 rwx(iax,1)=xi(iax,1)-xj(iax,1) 2280 rwx(iax,2)=xi(iax,2)-xj(iax,2) 2281 rwx(iax,3)=xi(iax,3)-xj(iax,3) 2282 rwi2(iax)=one/(rwx(iax,1)**2+rwx(iax,2)**2+rwx(iax,3)**2) 2283 if(isrx(iax).eq.999) then 2284 rwi2(iax)=zero 2285 isrx(iax)=0 2286 endif 2287 if(isrx(iax).gt.0) then 2288 rwi2(iax)=one/(one/rwi2(iax)+shift0(1)) 2289 elseif(isrx(iax).lt.0) then 2290 rwi2(iax)=one/(one/rwi2(iax)+shift1(1)) 2291 endif 2292 rwi1(iax)=sqrt(rwi2(iax)) 2293 isa=isal(iax) 2294 jsa=jsal(iax) 2295 if(jfal(iax).ne.isf) then 2296 q=qsa2(isa)*qsa2(jsa) 2297 else 2298 q=qsa3(isa)*qsa3(jsa) 2299 endif 2300 ferfc=erfc(ealpha/rwi1(iax)) 2301 fderfc=ealpha*derfc(ealpha/rwi1(iax)) 2302 rw(iax)=ferfc*facu(iax)*q*rwi1(iax) 2303 f(iax)=f(iax)+q*rwi2(iax)*(ferfc*rwi1(iax)-fderfc) 2304 if(ireact.ne.0) then 2305 rw(iax)=rw(iax)+facu(iax)*q*rffss/rwi2(iax) 2306 f(iax)=f(iax)-two*q*rffss 2307 endif 2308 126 continue 2309 endif 2310 endif 2311c 2312c accumulate electrostatic energies per solute molecule 2313c 2314c etermq=zero 2315 do 27 iax=1,nax 2316 if(npener.ne.0) then 2317 esa(isga(isal(iax)))=esa(isga(isal(iax)))+half*rw(iax) 2318 esa(isga(jsal(iax)))=esa(isga(jsal(iax)))+half*rw(iax) 2319 endif 2320 ess(isf,jfal(iax),6,ipss)=ess(isf,jfal(iax),6,ipss)+rw(iax) 2321 etermq=etermq+rw(iax) 2322 27 continue 2323c 2324c do 27 jsf=1,msf 2325c sumen=zero 2326c do 28 iax=1,nax 2327c if(jfal(iax).eq.jsf) sumen=sumen+rw(iax) 2328c if(npener.ne.0) then 2329c esa(isga(isal(iax)))=esa(isga(isal(iax)))+half*rw(iax) 2330c esa(isga(jsal(iax)))=esa(isga(jsal(iax)))+half*rw(iax) 2331c endif 2332c 28 continue 2333c ess(isf,jsf,6,ipss)=ess(isf,jsf,6,ipss)+sumen 2334c etermq=etermq+sumen 2335c 27 continue 2336c 2337#endif 2338c 2339#if defined(CAFE_POLARIZATION) 2340c 2341c evaluate electrostatic energies and forces 2342c 2343c dssq=zero 2344c dssqp=zero 2345c dssp=zero 2346 do 24 iax=1,nax 2347 if(isf.ne.jfal(iax)) then 2348 qi=chg(isq2(isal(iax)),1,iset) 2349 qj=chg(isq2(jsal(iax)),1,iset) 2350 pai=chg(isq2(isal(iax)),2,iset) 2351 paj=chg(isq2(jsal(iax)),2,iset) 2352 else 2353 qi=chg(isq3(isal(iax)),1,iset) 2354 qj=chg(isq3(jsal(iax)),1,iset) 2355 pai=chg(isq3(isal(iax)),2,iset) 2356 paj=chg(isq3(jsal(iax)),2,iset) 2357 endif 2358 qai=qfaci*qi 2359 qaj=qfaci*qj 2360 rwx(iax,1)=xi(iax,1)-xj(iax,1) 2361 rwx(iax,2)=xi(iax,2)-xj(iax,2) 2362 rwx(iax,3)=xi(iax,3)-xj(iax,3) 2363 rx=-rwx(iax,1) 2364 ry=-rwx(iax,2) 2365 rz=-rwx(iax,3) 2366 ri2=one/(rx*rx+ry*ry+rz*rz) 2367 ri1=sqrt(ri2) 2368 ri3=qfac*qfac*ri1*ri2 2369 rwi2(iax)=ri2 2370 rwi1(iax)=ri1 2371 pix=pai*pl(iax,1) 2372 piy=pai*pl(iax,2) 2373 piz=pai*pl(iax,3) 2374 pjx=paj*pj(iax,1) 2375 pjy=paj*pj(iax,2) 2376 pjz=paj*pj(iax,3) 2377 rmi=three*(rx*pix+ry*piy+rz*piz)*ri2 2378 rmj=three*(rx*pjx+ry*pjy+rz*pjz)*ri2 2379 if(ipolt.eq.1) then 2380 fri=((-qai)*qaj+qai*rmj-qaj*rmi)*ri3 2381 fmi=(qaj)*ri3 2382 fmj=(-qai)*ri3 2383 else 2384 rmm=three*(pix*pjx+piy*pjy+piz*pjz)*ri2 2385 fri=((-qai)*qaj+qai*rmj-qaj*rmi+5.0*rmi*rmj/three-rmm)*ri3 2386 fmi=(qaj-rmj)*ri3 2387 fmj=((-qai)-rmi)*ri3 2388 endif 2389 fi(iax,1)=fri*rx+fmi*pix+fmj*pjx 2390 fi(iax,2)=fri*ry+fmi*piy+fmj*pjy 2391 fi(iax,3)=fri*rz+fmi*piz+fmj*pjz 2392 fj(iax,1)=(fri*rx+fmi*pix+fmj*pjx) 2393 fj(iax,2)=(fri*ry+fmi*piy+fmj*pjy) 2394 fj(iax,3)=(fri*rz+fmi*piz+fmj*pjz) 2395 jsf=jfal(iax) 2396 if(isf.ne.jsf) then 2397 zxx=(-half)*(fri*rx+fmi*pix+fmj*pjx)*rwc(iax,1) 2398 zyx=(-half)*(fri*rx+fmi*pix+fmj*pjx)*rwc(iax,2) 2399 zzx=(-half)*(fri*rx+fmi*pix+fmj*pjx)*rwc(iax,3) 2400 zxy=(-half)*(fri*ry+fmi*piy+fmj*pjy)*rwc(iax,1) 2401 zyy=(-half)*(fri*ry+fmi*piy+fmj*pjy)*rwc(iax,2) 2402 zzy=(-half)*(fri*ry+fmi*piy+fmj*pjy)*rwc(iax,3) 2403 zxz=(-half)*(fri*rz+fmi*piz+fmj*pjz)*rwc(iax,1) 2404 zyz=(-half)*(fri*rz+fmi*piz+fmj*pjz)*rwc(iax,2) 2405 zzz=(-half)*(fri*rz+fmi*piz+fmj*pjz)*rwc(iax,3) 2406 zs(isf,1,1,ipss)=zs(isf,1,1,ipss)+zxx 2407 zs(isf,2,1,ipss)=zs(isf,2,1,ipss)+zyx 2408 zs(isf,3,1,ipss)=zs(isf,3,1,ipss)+zzx 2409 zs(isf,1,2,ipss)=zs(isf,1,2,ipss)+zxy 2410 zs(isf,2,2,ipss)=zs(isf,2,2,ipss)+zyy 2411 zs(isf,3,2,ipss)=zs(isf,3,2,ipss)+zzy 2412 zs(isf,1,3,ipss)=zs(isf,1,3,ipss)+zxz 2413 zs(isf,2,3,ipss)=zs(isf,2,3,ipss)+zyz 2414 zs(isf,3,3,ipss)=zs(isf,3,3,ipss)+zzz 2415 zs(jsf,1,1,ipss)=zs(jsf,1,1,ipss)+zxx 2416 zs(jsf,2,1,ipss)=zs(jsf,2,1,ipss)+zyx 2417 zs(jsf,3,1,ipss)=zs(jsf,3,1,ipss)+zzx 2418 zs(jsf,1,2,ipss)=zs(jsf,1,2,ipss)+zxy 2419 zs(jsf,2,2,ipss)=zs(jsf,2,2,ipss)+zyy 2420 zs(jsf,3,2,ipss)=zs(jsf,3,2,ipss)+zzy 2421 zs(jsf,1,3,ipss)=zs(jsf,1,3,ipss)+zxz 2422 zs(jsf,2,3,ipss)=zs(jsf,2,3,ipss)+zyz 2423 zs(jsf,3,3,ipss)=zs(jsf,3,3,ipss)+zzz 2424 endif 2425 etermp=facu(iax)*(qi*qj-qfac*qfac*(qai*rmj-qaj*rmi))*ri1 2426 if(npener.ne.0) then 2427 esa(isga(isal(iax)))=esa(isga(isal(iax)))+half*etermp 2428 esa(isga(jsal(iax)))=esa(isga(jsal(iax)))+half*etermp 2429 endif 2430 ess(isf,jsf,6,ipss)=ess(isf,jsf,6,ipss)+etermp 2431c 2432 24 continue 2433c 2434#endif 2435c 2436c Lennard-Jones energies and forces 2437c ================================= 2438c 2439 do 29 iax=1,nax 2440 isa=isal(iax) 2441 jsa=jsal(iax) 2442 rwi6(iax)=rwi2(iax)*rwi2(iax)*rwi2(iax) 2443 c6=vdw(isat(isa),isat(jsa),1,iset) 2444 c12=vdw(isat(isa),isat(jsa),3,iset) 2445 cf6=six*c6 2446 cf12=twelve*c12 2447 rw(iax)=facu(iax)*(c12*rwi6(iax)-c6)*rwi6(iax) 2448 f(iax)=f(iax)+(cf12*rwi6(iax)-cf6)*rwi6(iax)*rwi2(iax) 2449cx if(ihess.gt.0) then 2450cx h(iax)=h(iax)+(forten*cf12*rwi6(iax)-eight*cf6)*rwi6(iax)* 2451cx + rwi2(iax)*rwi2(iax) 2452cx endif 2453 29 continue 2454c 2455c accumulate Lennard-Jones energies per solute molecule 2456c 2457c eterml=zero 2458c etermq=zero 2459 do 30 iax=1,nax 2460 if(npener.ne.0) then 2461 esa(isga(isal(iax)))=esa(isga(isal(iax)))+half*rw(iax) 2462 esa(isga(jsal(iax)))=esa(isga(jsal(iax)))+half*rw(iax) 2463 endif 2464 ess(isf,jfal(iax),5,ipss)=ess(isf,jfal(iax),5,ipss)+rw(iax) 2465 eterml=eterml+rw(iax) 2466 30 continue 2467c 2468c do 30 jsf=1,msf 2469c sumen=zero 2470c do 31 iax=1,nax 2471c if(jfal(iax).eq.jsf) sumen=sumen+rw(iax) 2472c if(npener.ne.0) then 2473c esa(isga(isal(iax)))=esa(isga(isal(iax)))+half*rw(iax) 2474c esa(isga(jsal(iax)))=esa(isga(jsal(iax)))+half*rw(iax) 2475c endif 2476c 31 continue 2477c ess(isf,jsf,5,ipss)=ess(isf,jsf,5,ipss)+sumen 2478c eterml=eterml+sumen 2479c 30 continue 2480c 2481c evaluate and accumulate the solute-solute virial contributions 2482c allow virial contributions from interactions between a solute 2483c molecule and its own image 2484c 2485 do 132 ix=1,3 2486 do 32 jsf=1,msf 2487 sumen1=zero 2488 sumen2=zero 2489 sumen3=zero 2490 do 33 iax=1,nax 2491cx if(jfal(iax).eq.jsf.and.jmal(iax).eq.1) then 2492 if(jfal(iax).eq.jsf) then 2493 sumen1=sumen1-half*f(iax)*rwx(iax,1)*rwc(iax,ix) 2494 sumen2=sumen2-half*f(iax)*rwx(iax,2)*rwc(iax,ix) 2495 sumen3=sumen3-half*f(iax)*rwx(iax,3)*rwc(iax,ix) 2496 endif 2497 33 continue 2498 zs(isf,ix,1,ipss)=zs(isf,ix,1,ipss)+sumen1 2499 zs(jsf,ix,1,ipss)=zs(jsf,ix,1,ipss)+sumen1 2500 zs(isf,ix,2,ipss)=zs(isf,ix,2,ipss)+sumen2 2501 zs(jsf,ix,2,ipss)=zs(jsf,ix,2,ipss)+sumen2 2502 zs(isf,ix,3,ipss)=zs(isf,ix,3,ipss)+sumen3 2503 zs(jsf,ix,3,ipss)=zs(jsf,ix,3,ipss)+sumen3 2504 32 continue 2505 132 continue 2506c 2507c generate radial distribution functions 2508c 2509c if(ifstep-1.eq.((ifstep-1)/nfrdf)*nfrdf.and.ngrss.gt.0) then 2510c do 34 iax=1,nax 2511c isa=isal(iax) 2512c jsa=jsal(iax) 2513c do 35 igc=1,ngc 2514c if(ngt(igc).eq.3) then 2515c if((isga(isa).eq.iagc(igc).and. 2516c + isga(jsa).eq.jagc(igc)).or. 2517c + (isga(isa).eq.jagc(igc).and. 2518c + isga(jsa).eq.iagc(igc))) then 2519c igr=igrc(igc) 2520c indx=int(one/(rwi1(iax)*drdf)) 2521c if(indx.gt.ngl) indx=ngl 2522c rdf(indx,igr)=rdf(indx,igr)+rdfvol 2523c endif 2524c endif 2525c 35 continue 2526c 34 continue 2527c endif 2528c 2529c accumulate forces into solute force arrays 2530c 2531 nax=0 2532 do 36 isa=lssndx(isslen-1,ipss)+1,lssndx(isslen,ipss) 2533 jsaptr=lssjpt(isa,ipss)-1 2534 do 37 jnum=1,lssin(isa,ipss) 2535 lssptr=lssj(jsaptr+jnum) 2536 fs(isfr+isa,1,ipss)=fs(isfr+isa,1,ipss)+ 2537 + f(nax+jnum)*rwx(nax+jnum,1) 2538 fs(isfr+isa,2,ipss)=fs(isfr+isa,2,ipss)+ 2539 + f(nax+jnum)*rwx(nax+jnum,2) 2540 fs(isfr+isa,3,ipss)=fs(isfr+isa,3,ipss)+ 2541 + f(nax+jnum)*rwx(nax+jnum,3) 2542 fs(lssptr,1,ipss)=fs(lssptr,1,ipss)-f(nax+jnum)*rwx(nax+jnum,1) 2543 fs(lssptr,2,ipss)=fs(lssptr,2,ipss)-f(nax+jnum)*rwx(nax+jnum,2) 2544 fs(lssptr,3,ipss)=fs(lssptr,3,ipss)-f(nax+jnum)*rwx(nax+jnum,3) 2545 isf=ismf(isfr+isa) 2546 jsf=ismf(lssptr) 2547 fss(isf,jsf,1,ipss)=fss(isf,jsf,1,ipss)+ 2548 + f(nax+jnum)*rwx(nax+jnum,1) 2549 fss(isf,jsf,2,ipss)=fss(isf,jsf,2,ipss)+ 2550 + f(nax+jnum)*rwx(nax+jnum,2) 2551 fss(isf,jsf,3,ipss)=fss(isf,jsf,3,ipss)+ 2552 + f(nax+jnum)*rwx(nax+jnum,3) 2553#if defined(CAFE_POLARIZATION) 2554 fs(isfr+isa,1,ipss)=fs(isfr+isa,1,ipss)+fi(nax+jnum,1) 2555 fs(isfr+isa,2,ipss)=fs(isfr+isa,2,ipss)+fi(nax+jnum,2) 2556 fs(isfr+isa,3,ipss)=fs(isfr+isa,3,ipss)+fi(nax+jnum,3) 2557 fs(lssptr,1,ipss)=fs(lssptr,1,ipss)+fj(nax+jnum,1) 2558 fs(lssptr,2,ipss)=fs(lssptr,2,ipss)+fj(nax+jnum,2) 2559 fs(lssptr,3,ipss)=fs(lssptr,3,ipss)+fj(nax+jnum,3) 2560#endif 2561 37 continue 2562cx if(ihess.gt.0) then 2563cx do 137 jnum=1,lssin(isa,ipss) 2564cx lssptr=lssj(jsaptr+jnum) 2565cx hs(isfr+isa,1,ipss)=hs(isfr+isa,1,ipss)-f(nax+jnum)+ 2566cx + h(nax+jnum)**rwx(nax+jnum,1)*rwx(nax+jnum,1) 2567cx hs(isfr+isa,2,ipss)=hs(isfr+isa,2,ipss)+ 2568cx + h(nax+jnum)*rwx(nax+jnum,1)*rwx(nax+jnum,2) 2569cx hs(isfr+isa,3,ipss)=hs(isfr+isa,3,ipss)+ 2570cx + h(nax+jnum)*rwx(nax+jnum,1)*rwx(nax+jnum,3) 2571cx hs(isfr+isa,4,ipss)=hs(isfr+isa,4,ipss)-f(nax+jnum)+ 2572cx + h(nax+jnum)*rwx(nax+jnum,2)*rwx(nax+jnum,2) 2573cx hs(isfr+isa,5,ipss)=hs(isfr+isa,5,ipss)+ 2574cx + h(nax+jnum)*rwx(nax+jnum,2)*rwx(nax+jnum,3) 2575cx hs(isfr+isa,6,ipss)=hs(isfr+isa,6,ipss)-f(nax+jnum)+ 2576cx + h(nax+jnum)*rwx(nax+jnum,3)*rwx(nax+jnum,3) 2577cx hs(lssptr,1,ipss)=hs(lssptr,1,ipss)+f(nax+jnum)- 2578cx + h(nax+jnum)*rwx(nax+jnum,1)*rwx(nax+jnum,1) 2579cx hs(lssptr,2,ipss)=hs(lssptr,2,ipss)- 2580cx + h(nax+jnum)*rwx(nax+jnum,1)*rwx(nax+jnum,2) 2581cx hs(lssptr,3,ipss)=hs(lssptr,3,ipss)- 2582cx + h(nax+jnum)*rwx(nax+jnum,1)*rwx(nax+jnum,3) 2583cx hs(lssptr,4,ipss)=hs(lssptr,4,ipss)+f(nax+jnum)- 2584cx + h(nax+jnum)*rwx(nax+jnum,2)*rwx(nax+jnum,2) 2585cx hs(lssptr,5,ipss)=hs(lssptr,5,ipss)- 2586cx + h(nax+jnum)*rwx(nax+jnum,2)*rwx(nax+jnum,3) 2587cx hs(lssptr,6,ipss)=hs(lssptr,6,ipss)+f(nax+jnum)- 2588cx + h(nax+jnum)*rwx(nax+jnum,3)*rwx(nax+jnum,3) 2589cx 137 continue 2590cx endif 2591 nax=nax+lssin(isa,ipss) 2592 36 continue 2593c 2594c thermodynamic integration 2595c 2596 if(ithint) then 2597 if(ith(14)) then 2598 nax=0 2599 do 38 isa=lssndx(isslen-1,ipss)+1,lssndx(isslen,ipss) 2600 jsaptr=lssjpt(isa,ipss)-1 2601c 2602 if(.not.lssscl) then 2603 do 39 jnum=1,lssin(isa,ipss) 2604 jsa=lssj(jsaptr+jnum) 2605 dercon=(vdw(isat(isfr+isa),isat(jsa),3,4)*rwi6(nax+jnum) 2606 + -vdw(isat(isfr+isa),isat(jsa),1,4))*rwi6(nax+jnum) 2607 deriv(15,ipss)=deriv(15,ipss)+dercon 2608#if defined(CAFE_FORCES) 2609 if(npgdec.gt.1) then 2610 dera(3,isga(isa))=dera(3,isga(isa))+half*dercon 2611 dera(3,isga(jsa))=dera(3,isga(jsa))+half*dercon 2612 endif 2613#endif 2614 39 continue 2615 else 2616 do 40 jnum=1,lssin(isa,ipss) 2617 jsa=lssj(jsaptr+jnum) 2618 dercon=(vdw(isat(isfr+isa),isat(jsa),3,4)*rwi6(nax+jnum) 2619 + -vdw(isat(isfr+isa),isat(jsa),1,4))*rwi6(nax+jnum) 2620 if(isrx(nax+jnum).gt.0) then 2621 c64=three*vdw(isat(isfr+isa),isat(jsa),1,iset) 2622 c124=six*vdw(isat(isfr+isa),isat(jsa),3,iset) 2623 dercon=dercon+shift0(4)* 2624 + rwi2(nax+jnum)*rwi6(nax+jnum)*(c64-c124*rwi6(nax+jnum)) 2625 elseif(isrx(nax+jnum).lt.0) then 2626 c64=three*vdw(isat(isfr+isa),isat(jsa),1,iset) 2627 c124=six*vdw(isat(isfr+isa),isat(jsa),3,iset) 2628 dercon=dercon+shift1(4)* 2629 + rwi2(nax+jnum)*rwi6(nax+jnum)*(c64-c124*rwi6(nax+jnum)) 2630 endif 2631 deriv(15,ipss)=deriv(15,ipss)+dercon 2632c write(*,'(a,3i5,4f12.6)') 'gv ', 2633c + isga(isfr+isa),isga(jsa),isrx(nax+jnum),shift0(4),shift1(4), 2634c + dercon,deriv(15,ipss) 2635#if defined(CAFE_FORCES) 2636 if(npgdec.gt.1) then 2637 dera(3,isga(isfr+isa))=dera(3,isga(isfr+isa))+half*dercon 2638 dera(3,isga(jsa))=dera(3,isga(jsa))+half*dercon 2639 endif 2640#endif 2641 40 continue 2642 endif 2643c 2644 nax=nax+lssin(isa,ipss) 2645 38 continue 2646 endif 2647c 2648 if(ith(16)) then 2649 nax=0 2650 do 41 isa=lssndx(isslen-1,ipss)+1,lssndx(isslen,ipss) 2651 jsaptr=lssjpt(isa,ipss)-1 2652 ism=isml(isfr+isa) 2653 if(ipme.eq.0) then 2654 if(.not.lssscl) then 2655 do 42 jnum=1,lssin(isa,ipss) 2656 jsa=lssj(jsaptr+jnum) 2657 if(isml(jsa).ne.ism) then 2658 dercon=(chg(isq2(isfr+isa),1,iset)*chg(isq2(jsa),1,4) 2659 + +chg(isq2(isfr+isa),1,4)*chg(isq2(jsa),1,iset)) 2660 else 2661 dercon=(chg(isq3(isfr+isa),1,iset)*chg(isq3(jsa),1,4) 2662 + +chg(isq3(isfr+isa),1,4)*chg(isq3(jsa),1,iset)) 2663 endif 2664 deriv(17,ipss)=deriv(17,ipss)+dercon*rwi1(nax+jnum) 2665 if(ireact.ne.0) then 2666 deriv(17,ipss)=deriv(17,ipss)+dercon*rffss/rwi2(nax+jnum) 2667 endif 2668c write(*,'(a,3i5,4f12.6)') 'gq ', 2669c + isga(isfr+isa),isga(jsa),isrx(nax+jnum),shift0(4),shift1(4), 2670c + dercon,deriv(17,ipss) 2671#if defined(CAFE_FORCES) 2672 if(npgdec.gt.1) then 2673 dera(4,isga(isfr+isa))=dera(4,isga(isfr+isa))+ 2674 + half*dercon*rwi1(nax+jnum) 2675 dera(4,isga(jsa))=dera(4,isga(jsa))+half*dercon*rwi1(nax+jnum) 2676 endif 2677#endif 2678 42 continue 2679 else 2680 do 43 jnum=1,lssin(isa,ipss) 2681 jsa=lssj(jsaptr+jnum) 2682 if(isml(jsa).ne.ism) then 2683 dercon=(chg(isq2(isfr+isa),1,iset)*chg(isq2(jsa),1,4) 2684 + +chg(isq2(isfr+isa),1,4)*chg(isq2(jsa),1,iset)) 2685 if(isrx(nax+jnum).gt.0) then 2686 dercon=dercon-half*shift0(4)* 2687 + chg(isq2(isfr+isa),1,iset)*chg(isq2(jsa),1,iset)*rwi2(nax+jnum) 2688 elseif(isrx(nax+jnum).lt.0) then 2689 dercon=dercon-half*shift1(4)* 2690 + chg(isq2(isfr+isa),1,iset)*chg(isq2(jsa),1,iset)*rwi2(nax+jnum) 2691 endif 2692 else 2693 dercon=(chg(isq3(isfr+isa),1,iset)*chg(isq3(jsa),1,4) 2694 + +chg(isq3(isfr+isa),1,4)*chg(isq3(jsa),1,iset)) 2695 if(isrx(nax+jnum).gt.1) then 2696 dercon=dercon-half*shift0(4)* 2697 + chg(isq3(isfr+isa),1,iset)*chg(isq3(jsa),1,iset)*rwi2(nax+jnum) 2698 elseif(isrx(nax+jnum).lt.-1) then 2699 dercon=dercon-half*shift1(4)* 2700 + chg(isq3(isfr+isa),1,iset)*chg(isq3(jsa),1,iset)*rwi2(nax+jnum) 2701 endif 2702 endif 2703 deriv(17,ipss)=deriv(17,ipss)+dercon*rwi1(nax+jnum) 2704 if(ireact.ne.0) then 2705 deriv(17,ipss)=deriv(17,ipss)+dercon*rffss/rwi2(nax+jnum) 2706 endif 2707#if defined(CAFE_FORCES) 2708 if(npgdec.gt.1) then 2709 dera(4,isga(isfr+isa))=dera(4,isga(isfr+isa))+ 2710 + half*dercon*rwi1(nax+jnum) 2711 dera(4,isga(jsa))=dera(4,isga(jsa))+half*dercon*rwi1(nax+jnum) 2712 endif 2713#endif 2714 43 continue 2715 endif 2716 else 2717 if(.not.lssscl) then 2718 do 142 jnum=1,lssin(isa,ipss) 2719 jsa=lssj(jsaptr+jnum) 2720 if(isml(jsa).ne.ism) then 2721 dercon=(chg(isq2(isfr+isa),1,iset)*chg(isq2(jsa),1,4) 2722 + +chg(isq2(isfr+isa),1,4)*chg(isq2(jsa),1,iset)) 2723 else 2724 dercon=(chg(isq3(isfr+isa),1,iset)*chg(isq3(jsa),1,4) 2725 + +chg(isq3(isfr+isa),1,4)*chg(isq3(jsa),1,iset)) 2726 endif 2727 deriv(17,ipss)=deriv(17,ipss)+dercon*rwi1(nax+jnum) 2728 if(ireact.ne.0) then 2729 deriv(17,ipss)=deriv(17,ipss)+dercon*rffss/rwi2(nax+jnum) 2730 endif 2731#if defined(CAFE_FORCES) 2732 if(npgdec.gt.1) then 2733 dera(4,isga(isfr+isa))=dera(4,isga(isfr+isa))+ 2734 + half*dercon*rwi1(nax+jnum) 2735 dera(4,isga(jsa))=dera(4,isga(jsa))+half*dercon*rwi1(nax+jnum) 2736 endif 2737#endif 2738 142 continue 2739 else 2740 do 143 jnum=1,lssin(isa,ipss) 2741 jsa=lssj(jsaptr+jnum) 2742 if(isml(jsa).ne.ism) then 2743 dercon=(chg(isq2(isfr+isa),1,iset)*chg(isq2(jsa),1,4) 2744 + +chg(isq2(isfr+isa),1,4)*chg(isq2(jsa),1,iset)) 2745 if(isrx(nax+jnum).gt.0) then 2746 dercon=dercon-half*shift0(4)* 2747 + chg(isq2(isfr+isa),1,iset)*chg(isq2(jsa),1,iset)*rwi2(nax+jnum) 2748 elseif(isrx(nax+jnum).lt.0) then 2749 dercon=dercon-half*shift1(4)* 2750 + chg(isq2(isfr+isa),1,iset)*chg(isq2(jsa),1,iset)*rwi2(nax+jnum) 2751 endif 2752 else 2753 dercon=(chg(isq3(isfr+isa),1,iset)*chg(isq3(jsa),1,4) 2754 + +chg(isq3(isfr+isa),1,4)*chg(isq3(jsa),1,iset)) 2755 if(isrx(nax+jnum).gt.1) dercon=dercon-half*shift0(4)* 2756 + chg(isq3(isfr+isa),1,iset)*chg(isq3(jsa),1,iset)*rwi2(nax+jnum) 2757 if(isrx(nax+jnum).lt.-1) dercon=dercon-half*shift1(4)* 2758 + chg(isq3(isfr+isa),1,iset)*chg(isq3(jsa),1,iset)*rwi2(nax+jnum) 2759 endif 2760 deriv(17,ipss)=deriv(17,ipss)+dercon*rwi1(nax+jnum) 2761 if(ireact.ne.0) then 2762 deriv(17,ipss)=deriv(17,ipss)+dercon*rffss/rwi2(nax+jnum) 2763 endif 2764#if defined(CAFE_FORCES) 2765 if(npgdec.gt.1) then 2766 dera(4,isga(isfr+isa))=dera(4,isga(isfr+isa))+ 2767 + half*dercon*rwi1(nax+jnum) 2768 dera(4,isga(jsa))=dera(4,isga(jsa))+half*dercon*rwi1(nax+jnum) 2769 endif 2770#endif 2771 143 continue 2772 endif 2773 endif 2774 nax=nax+lssin(isa,ipss) 2775 41 continue 2776 endif 2777 endif 2778c 2779c thermodynamic perturbation 1 2780c 2781 if(ipert2) then 2782 if(ip2(14)) then 2783 if(.not.lssscl) then 2784 do 44 iax=1,nax 2785 isa=isal(iax) 2786 jsa=jsal(iax) 2787 ep2(ipss)=ep2(ipss) 2788 + +facu(iax)*(vdw(isat(isa),isat(jsa),3,2)*rwi6(iax) 2789 + -vdw(isat(isa),isat(jsa),1,2))*rwi6(iax) 2790 44 continue 2791 else 2792 do 45 iax=1,nax 2793 isa=isal(iax) 2794 jsa=jsal(iax) 2795 rwi6(iax)=rwi2(iax)**3 2796 if(isrx(iax).gt.0) then 2797 rwi6(iax)=(one/(one/rwi2(iax)-shift0(1)+shift0(2)))**3 2798 elseif(isrx(iax).lt.0) then 2799 rwi6(iax)=(one/(one/rwi2(iax)-shift1(1)+shift1(2)))**3 2800 endif 2801 ep2(ipss)=ep2(ipss) 2802 + +facu(iax)*(vdw(isat(isa),isat(jsa),3,2)*rwi6(iax) 2803 + -vdw(isat(isa),isat(jsa),1,2))*rwi6(iax) 2804 45 continue 2805 endif 2806 ep2(ipss)=ep2(ipss)-eterml 2807 endif 2808 if(ip2(16).or.ip2(17)) then 2809 if(ipme.eq.0) then 2810 if(.not.lssscl) then 2811 do 46 iax=1,nax 2812 isa=isal(iax) 2813 jsa=jsal(iax) 2814 if(jmal(iax).ne.0) then 2815 q14=chg(isq2(isa),1,2)*chg(isq2(jsa),1,2) 2816 else 2817 q14=chg(isq3(isa),1,2)*chg(isq3(jsa),1,2) 2818 endif 2819 rwx(iax,1)=xi(iax,1)-xj(iax,1) 2820 rwx(iax,2)=xi(iax,2)-xj(iax,2) 2821 rwx(iax,3)=xi(iax,3)-xj(iax,3) 2822 rwi2(iax)=one/(rwx(iax,1)**2+rwx(iax,2)**2+rwx(iax,3)**2) 2823 rwi1(iax)=sqrt(rwi2(iax)) 2824 ep2(ipss)=ep2(ipss)+facu(iax)*q14*rwi1(iax) 2825 if(ireact.ne.0) then 2826 ep2(ipss)=ep2(ipss)+facu(iax)*q14*rffss/rwi2(iax) 2827 endif 2828 46 continue 2829 else 2830 do 47 iax=1,nax 2831 isa=isal(iax) 2832 jsa=jsal(iax) 2833 if(jmal(iax).ne.0) then 2834 q14=chg(isq2(isa),1,2)*chg(isq2(jsa),1,2) 2835 istt=0 2836 else 2837 q14=chg(isq3(isa),1,2)*chg(isq3(jsa),1,2) 2838 istt=1 2839 endif 2840 rwx(iax,1)=xi(iax,1)-xj(iax,1) 2841 rwx(iax,2)=xi(iax,2)-xj(iax,2) 2842 rwx(iax,3)=xi(iax,3)-xj(iax,3) 2843 rwi6(iax)=one/(rwx(iax,1)**2+rwx(iax,2)**2+rwx(iax,3)**2) 2844 if(isrx(iax).gt.istt) then 2845 rwi6(iax)=one/(one/rwi6(iax)+shift0(2)) 2846 elseif(isrx(iax).lt.-istt) then 2847 rwi6(iax)=one/(one/rwi6(iax)+shift1(2)) 2848 endif 2849 rwi1(iax)=sqrt(rwi6(iax)) 2850 ep2(ipss)=ep2(ipss)+facu(iax)*q14*rwi1(iax) 2851 if(ireact.ne.0) then 2852 ep2(ipss)=ep2(ipss)+facu(iax)*q14*rffss/rwi2(iax) 2853 endif 2854 47 continue 2855 endif 2856 else 2857 if(.not.lssscl) then 2858 do 146 iax=1,nax 2859 isa=isal(iax) 2860 jsa=jsal(iax) 2861 if(jmal(iax).ne.0) then 2862 q14=chg(isq2(isa),1,2)*chg(isq2(jsa),1,2)* 2863 + erfc(ealpha/rwi1(iax)) 2864 else 2865 q14=chg(isq3(isa),1,2)*chg(isq3(jsa),1,2)* 2866 + erfc(ealpha/rwi1(iax)) 2867 endif 2868 rwx(iax,1)=xi(iax,1)-xj(iax,1) 2869 rwx(iax,2)=xi(iax,2)-xj(iax,2) 2870 rwx(iax,3)=xi(iax,3)-xj(iax,3) 2871 rwi2(iax)=one/(rwx(iax,1)**2+rwx(iax,2)**2+rwx(iax,3)**2) 2872 rwi1(iax)=sqrt(rwi2(iax)) 2873 ep2(ipss)=ep2(ipss)+facu(iax)*q14*rwi1(iax) 2874 if(ireact.ne.0) then 2875 ep2(ipss)=ep2(ipss)+facu(iax)*q14*rffss/rwi2(iax) 2876 endif 2877 146 continue 2878 else 2879 do 147 iax=1,nax 2880 isa=isal(iax) 2881 jsa=jsal(iax) 2882 if(jmal(iax).ne.0) then 2883 q14=chg(isq2(isa),1,2)*chg(isq2(jsa),1,2)* 2884 + erfc(ealpha/rwi1(iax)) 2885 istt=0 2886 else 2887 q14=chg(isq3(isa),1,2)*chg(isq3(jsa),1,2)* 2888 + erfc(ealpha/rwi1(iax)) 2889 istt=1 2890 endif 2891 rwx(iax,1)=xi(iax,1)-xj(iax,1) 2892 rwx(iax,2)=xi(iax,2)-xj(iax,2) 2893 rwx(iax,3)=xi(iax,3)-xj(iax,3) 2894 rwi6(iax)=one/(rwx(iax,1)**2+rwx(iax,2)**2+rwx(iax,3)**2) 2895 if(isrx(iax).gt.istt) then 2896 rwi6(iax)=one/(one/rwi6(iax)+shift0(2)) 2897 elseif(isrx(iax).lt.-istt) then 2898 rwi6(iax)=one/(one/rwi6(iax)+shift1(2)) 2899 endif 2900 rwi1(iax)=sqrt(rwi6(iax)) 2901 ep2(ipss)=ep2(ipss)+facu(iax)*q14*rwi1(iax) 2902 if(ireact.ne.0) then 2903 ep2(ipss)=ep2(ipss)+facu(iax)*q14*rffss/rwi2(iax) 2904 endif 2905 147 continue 2906 endif 2907 endif 2908 ep2(ipss)=ep2(ipss)-etermq 2909 endif 2910 endif 2911c 2912c thermodynamic perturbation 2 2913c 2914 if(ipert3) then 2915 if(ip3(14)) then 2916 if(.not.lssscl) then 2917 do 48 iax=1,nax 2918 isa=isal(iax) 2919 jsa=jsal(iax) 2920 ep3(ipss)=ep3(ipss) 2921 + +facu(iax)*(vdw(isat(isa),isat(jsa),3,3)*rwi6(iax) 2922 + -vdw(isat(isa),isat(jsa),1,3))*rwi6(iax) 2923 48 continue 2924 else 2925 do 49 iax=1,nax 2926 isa=isal(iax) 2927 jsa=jsal(iax) 2928 rwi6(iax)=rwi2(iax)**3 2929 if(isrx(iax).gt.0) then 2930 rwi6(iax)=(one/(one/rwi2(iax)-shift0(1)+shift0(3)))**3 2931 elseif(isrx(iax).lt.0) then 2932 rwi6(iax)=(one/(one/rwi2(iax)-shift1(1)+shift1(3)))**3 2933 endif 2934 ep3(ipss)=ep3(ipss) 2935 + +facu(iax)*(vdw(isat(isa),isat(jsa),3,3)*rwi6(iax) 2936 + -vdw(isat(isa),isat(jsa),1,3))*rwi6(iax) 2937 49 continue 2938 endif 2939 ep3(ipss)=ep3(ipss)-eterml 2940 endif 2941 if(ip2(16).or.ip2(17)) then 2942 if(ipme.eq.0) then 2943 if(.not.lssscl) then 2944 do 50 iax=1,nax 2945 isa=isal(iax) 2946 jsa=jsal(iax) 2947 if(jmal(iax).ne.0) then 2948 q14=chg(isq2(isa),1,3)*chg(isq2(jsa),1,3) 2949 else 2950 q14=chg(isq3(isa),1,3)*chg(isq3(jsa),1,3) 2951 endif 2952 rwx(iax,1)=xi(iax,1)-xj(iax,1) 2953 rwx(iax,2)=xi(iax,2)-xj(iax,2) 2954 rwx(iax,3)=xi(iax,3)-xj(iax,3) 2955 rwi2(iax)=one/(rwx(iax,1)**2+rwx(iax,2)**2+rwx(iax,3)**2) 2956 rwi1(iax)=sqrt(rwi2(iax)) 2957 ep3(ipss)=ep3(ipss)+facu(iax)*q14*rwi1(iax) 2958 if(ireact.ne.0) then 2959 ep3(ipss)=ep3(ipss)+facu(iax)*q14*rffss/rwi2(iax) 2960 endif 2961 50 continue 2962 else 2963 do 51 iax=1,nax 2964 isa=isal(iax) 2965 jsa=jsal(iax) 2966 if(jmal(iax).ne.0) then 2967 q14=chg(isq2(isa),1,3)*chg(isq2(jsa),1,3) 2968 istt=0 2969 else 2970 q14=chg(isq3(isa),1,3)*chg(isq3(jsa),1,3) 2971 istt=1 2972 endif 2973 rwx(iax,1)=xi(iax,1)-xj(iax,1) 2974 rwx(iax,2)=xi(iax,2)-xj(iax,2) 2975 rwx(iax,3)=xi(iax,3)-xj(iax,3) 2976 rwi6(iax)=one/(rwx(iax,1)**2+rwx(iax,2)**2+rwx(iax,3)**2) 2977 if(isrx(iax).gt.istt) then 2978 rwi6(iax)=one/(one/rwi6(iax)+shift0(3)) 2979 elseif(isrx(iax).lt.-istt) then 2980 rwi6(iax)=one/(one/rwi6(iax)+shift1(3)) 2981 endif 2982 rwi1(iax)=sqrt(rwi6(iax)) 2983 ep3(ipss)=ep3(ipss)+facu(iax)*q14*rwi1(iax) 2984 if(ireact.ne.0) then 2985 ep3(ipss)=ep3(ipss)+facu(iax)*q14*rffss/rwi2(iax) 2986 endif 2987 51 continue 2988 endif 2989 else 2990 if(.not.lssscl) then 2991 do 150 iax=1,nax 2992 isa=isal(iax) 2993 jsa=jsal(iax) 2994 if(jmal(iax).ne.0) then 2995 q14=chg(isq2(isa),1,3)*chg(isq2(jsa),1,3)* 2996 + erfc(ealpha/rwi1(iax)) 2997 else 2998 q14=chg(isq3(isa),1,3)*chg(isq3(jsa),1,3)* 2999 + erfc(ealpha/rwi1(iax)) 3000 endif 3001 rwx(iax,1)=xi(iax,1)-xj(iax,1) 3002 rwx(iax,2)=xi(iax,2)-xj(iax,2) 3003 rwx(iax,3)=xi(iax,3)-xj(iax,3) 3004 rwi2(iax)=one/(rwx(iax,1)**2+rwx(iax,2)**2+rwx(iax,3)**2) 3005 rwi1(iax)=sqrt(rwi2(iax)) 3006 ep3(ipss)=ep3(ipss)+facu(iax)*q14*rwi1(iax) 3007 if(ireact.ne.0) then 3008 ep3(ipss)=ep3(ipss)+facu(iax)*q14*rffss/rwi2(iax) 3009 endif 3010 150 continue 3011 else 3012 do 151 iax=1,nax 3013 isa=isal(iax) 3014 jsa=jsal(iax) 3015 if(jmal(iax).ne.0) then 3016 q14=chg(isq2(isa),1,3)*chg(isq2(jsa),1,3)* 3017 + erfc(ealpha/rwi1(iax)) 3018 istt=0 3019 else 3020 q14=chg(isq3(isa),1,3)*chg(isq3(jsa),1,3)* 3021 + erfc(ealpha/rwi1(iax)) 3022 istt=1 3023 endif 3024 rwx(iax,1)=xi(iax,1)-xj(iax,1) 3025 rwx(iax,2)=xi(iax,2)-xj(iax,2) 3026 rwx(iax,3)=xi(iax,3)-xj(iax,3) 3027 rwi6(iax)=one/(rwx(iax,1)**2+rwx(iax,2)**2+rwx(iax,3)**2) 3028 if(isrx(iax).gt.istt) then 3029 rwi6(iax)=one/(one/rwi6(iax)+shift0(3)) 3030 elseif(isrx(iax).lt.-istt) then 3031 rwi6(iax)=one/(one/rwi6(iax)+shift1(3)) 3032 endif 3033 rwi1(iax)=sqrt(rwi6(iax)) 3034 ep3(ipss)=ep3(ipss)+facu(iax)*q14*rwi1(iax) 3035 if(ireact.ne.0) then 3036 ep3(ipss)=ep3(ipss)+facu(iax)*q14*rffss/rwi2(iax) 3037 endif 3038 151 continue 3039 endif 3040 endif 3041 ep3(ipss)=ep3(ipss)-etermq 3042 endif 3043 endif 3044 13 continue 3045 11 continue 3046c 3047c accumulate radial distribution function contributions from 3048c the excluded pairlist 3049c 3050c if(ifstep-1.eq.((ifstep-1)/nfrdf)*nfrdf.and.ngrss.gt.0) then 3051c do 52 isx=1,nsx 3052c isa=idsx(isx) 3053c jsa=jdsx(isx) 3054c do 53 igc=1,ngc 3055c if(ngt(igc).eq.3) then 3056c if((isa.eq.iagc(igc).and.jsa.eq.jagc(igc)).or. 3057c + (isa.eq.iagc(igc).and.jsa.eq.jagc(igc))) then 3058c igr=igrc(igc) 3059c indx=int(sqrt((xs(isa,1)-xs(jsa,1))**2+(xs(isa,2)-xs(jsa,2))**2+ 3060c + (xs(isa,3)-xs(jsa,3))**2)/drdf) 3061c if(indx.gt.ngl) indx=ngl 3062c rdf(indx,igr)=rdf(indx,igr)+rdfvol 3063c endif 3064c endif 3065c 53 continue 3066c 52 continue 3067c endif 3068c 3069c 3070#if defined(CAFE_FORCES) 3071 return 3072 end 3073 subroutine cf_fsb(nbonds,indexl,msb,msp,ibnd,bnd,rbnd, 3074 + natoms,ndim,igan,isgm,imol,idyn,ichg,chg,xs,fs,ess,lpbc,lpbcs, 3075 + lupden,lupdti,dera,lseq) 3076c 3077c $Id$ 3078c 3079c cf_fsb returns forces and energies for solute bonds 3080c 3081c ===================================================== 3082c 3083c description of arguments 3084c ------------------------ 3085c 3086c in: integer nbonds = number of bonds to consider 3087c integer indexl = index list 3088c 3089c integer idsb(msb) = global atom id i 3090c integer jdsb(msb) = global atom id j 3091c integer isbs(msb) = bond type 3092c real*8 cdsb(msb,6) = bond force constants 3093c real*8 ddsb(msb,6) = bond reference value 3094c real*8 rdsb(msb) = bond value 3095c 3096c integer natoms = number of atoms in arrays 3097c integer ndim = leading dimension atom arrays 3098c integer igan(ndim) = global atom numbers 3099c integer imol(ndim) = atom molecule fraction 3100c integer idyn(ndim) = atom dynamics type 3101c real*8 qs(ndim) = atomic charges 3102c real*8 xs(ndim,3) = atom coordinates 3103c 3104c out: real*8 fs(ndim,3) = atom forces (ACCUMULATED) 3105c real*8 usb(msb) = bond energies 3106c 3107 implicit none 3108c 3109#include "cf_common.fh" 3110c 3111c declaration of arguments 3112c ------------------------ 3113c 3114 integer msb,msp 3115 integer ibnd(msb,3) 3116 real*8 bnd(msb,msp,mset),rbnd(msb,2) 3117 integer isgm(msa),lseq(mseq) 3118c 3119 integer nbonds 3120 integer indexl(nbonds) 3121c 3122 logical lpbc,lpbcs,lupden,lupdti 3123 real*8 dera(6,nsatot) 3124c 3125 integer natoms,ndim 3126 integer igan(ndim),imol(ndim),idyn(ndim),ichg(ndim) 3127 real*8 chg(mqt,mqp,mset) 3128 real*8 xs(ndim,3),fs(ndim,3) 3129 real*8 dx(3) 3130c 3131c declaration of local variables 3132c ------------------------------ 3133c 3134 integer i,j,isb,isa,jsa,isf,jsf,ibset 3135 real*8 factu,dercon,qij,ferfc,fderfc,qijp2,qijp3 3136 real*8 bond,dbond,for,dfor,dfs1,dfs2,dfs3,eterm 3137 real*8 xs1,xs2,xs3,rss,rss2,rssi,rss2i,ess(msf,msf,mpe,2) 3138c 3139#include "cf_funcs_dec.fh" 3140#include "bitops_decls.fh" 3141#include "cf_funcs_sfn.fh" 3142#include "bitops_funcs.fh" 3143c 3144c solute bonds 3145c ============ 3146c 3147cx write(*,'(4i7)') (i,(ibnd(i,j),j=1,3),i=1,msb) 3148c 3149cx write(*,'(10i7)') (igan(j),j=1,natoms) 3150cx write(*,'(a,i7)') 'bonds ',nbonds 3151cx write(*,'(10i7)') (indexl(j),j=1,nbonds) 3152c 3153 do 1 i=1,nbonds 3154c 3155c find index into list of bonds 3156c 3157 isb=indexl(i) 3158c 3159c find local atom numbers involved in this bond 3160c 3161 isa=0 3162 jsa=0 3163 do 2 j=1,natoms 3164 if(ibnd(isb,1).eq.igan(j)) isa=j 3165 if(ibnd(isb,2).eq.igan(j)) jsa=j 3166 2 continue 3167c 3168 if(nfhop.eq.0) then 3169 ibset=iset 3170 else 3171 ibset=lseq(isgm(isa)) 3172 endif 3173c 3174c write(*,'(a,5i5)') 'bond ',i,nbonds,isb,isa,jsa 3175c 3176c find solute molecule numbers involved in this constrained 3177c 3178 isf=imol(isa) 3179 jsf=imol(jsa) 3180c write(*,'(a,6i5)') 'bond ',i,nbonds,isa,jsa,isf,jsf 3181c 3182c determine actual distance between the atoms 3183c 3184 xs1=xs(isa,1)-xs(jsa,1) 3185 xs2=xs(isa,2)-xs(jsa,2) 3186 xs3=xs(isa,3)-xs(jsa,3) 3187c 3188c periodic boundary conditions 3189c 3190 if(lpbc.or.lpbcs) then 3191 dx(1)=xs1 3192 dx(2)=xs2 3193 dx(3)=xs3 3194 call cf_pbc(1,dx,1,dx,1,0,1,1) 3195 xs1=dx(1) 3196 xs2=dx(2) 3197 xs3=dx(3) 3198 endif 3199c 3200 rss2=xs1**2+xs2**2+xs3**2 3201 if(rss2.gt.tiny) then 3202 rss=sqrt(rss2) 3203 rssi=one/rss 3204 rss2i=rssi*rssi 3205 else 3206 rss=zero 3207 rssi=one 3208 rss2i=one 3209 endif 3210c 3211 rbnd(isb,1)=rss 3212c 3213c if bond not constrained or pme 3214c 3215 if(iand(ibnd(isb,3),icnstr).eq.0.or.ipme.ne.0) then 3216c 3217c if bond not constrained 3218c 3219 if(iand(ibnd(isb,3),icnstr).eq.0) then 3220c 3221c determine fraction of energy to be counted 3222c this depends on the atoms being dynamic or fixed 3223c 3224 factu=zero 3225 if(iand(idyn(isa),mdynam).eq.ldynam.or. 3226 + iand(idyn(jsa),mdynam).eq.ldynam) factu=one 3227c if((iand(idyn(isa),mdynam).eq.ldynam.and. 3228c + iand(idyn(jsa),mdynam).ne.ldynam) .or. 3229c + (iand(idyn(isa),mdynam).ne.ldynam.and. 3230c + iand(idyn(jsa),mdynam).eq.ldynam)) factu=half 3231 if(includ.eq.1) factu=one 3232c 3233c find reference bond length and force constant 3234c 3235 bond=bnd(isb,1,ibset) 3236 for=bnd(isb,2,ibset) 3237c 3238 dbond=rss-bond 3239c 3240c evaluate energies and forces 3241c 3242 rbnd(isb,2)=half*for*dbond*dbond 3243 eterm=zero 3244 if(lupden) then 3245 ess(isf,isf,1,1)=ess(isf,isf,1,1)+half*factu*rbnd(isb,2) 3246 ess(jsf,jsf,1,1)=ess(jsf,jsf,1,1)+half*factu*rbnd(isb,2) 3247 endif 3248 eterm=factu*rbnd(isb,2) 3249 dfor=for*dbond*rssi 3250 dfs1=dfor*xs1 3251 dfs2=dfor*xs2 3252 dfs3=dfor*xs3 3253 fs(isa,1)=fs(isa,1)-dfs1 3254 fs(jsa,1)=fs(jsa,1)+dfs1 3255 fs(isa,2)=fs(isa,2)-dfs2 3256 fs(jsa,2)=fs(jsa,2)+dfs2 3257 fs(isa,3)=fs(isa,3)-dfs3 3258 fs(jsa,3)=fs(jsa,3)+dfs3 3259c 3260c evaluate hessian 3261 3262cx if(ihess.gt.0) then 3263cx isag=igan(isa) 3264cx jsag=igan(jsa) 3265c 3266cx hess=for*(one-bond*rssi*(one+xs1*xs1*rss2i)) 3267cx hs(isa,1,1,isag)=hs(isa,1,1,isag)+hess 3268cx hs(isa,1,1,jsag)=hs(isa,1,1,jsag)-hess 3269cx hs(jsa,1,1,jsag)=hs(jsa,1,1,jsag)-hess 3270cx hs(jsa,1,1,isag)=hs(jsa,1,1,isag)+hess 3271c 3272cx hess=for*(one-bond*rssi*(one+xs2*xs2*rss2i)) 3273cx hs(isa,2,2,isag)=hs(isa,2,2,isag)+hess 3274cx hs(isa,2,2,jsag)=hs(isa,2,2,jsag)-hess 3275cx hs(jsa,2,2,jsag)=hs(jsa,2,2,jsag)-hess 3276cx hs(jsa,2,2,isag)=hs(jsa,2,2,isag)+hess 3277c 3278cx hess=for*(one-bond*rssi*(one+xs3*xs3*rss2i)) 3279cx hs(isa,3,3,isag)=hs(isa,3,3,isag)+hess 3280cx hs(isa,3,3,jsag)=hs(isa,3,3,jsag)-hess 3281cx hs(jsa,3,3,jsag)=hs(jsa,3,3,jsag)-hess 3282cx hs(jsa,3,3,isag)=hs(jsa,3,3,isag)+hess 3283c 3284cx hess=for*bond*xs1*xs2*rss2i*rssi 3285cx hs(isa,1,2,isag)=hs(isa,1,2,isag)+hess 3286cx hs(isa,2,1,isag)=hs(isa,2,1,isag)+hess 3287cx hs(isa,1,2,jsag)=hs(isa,1,2,jsag)-hess 3288cx hs(isa,2,1,jsag)=hs(isa,2,1,jsag)-hess 3289cx hs(jsa,1,2,jsag)=hs(jsa,1,2,jsag)-hess 3290cx hs(jsa,2,1,jsag)=hs(jsa,2,1,jsag)-hess 3291cx hs(jsa,1,2,isag)=hs(jsa,1,2,isag)+hess 3292cx hs(jsa,2,1,isag)=hs(jsa,2,1,isag)+hess 3293c 3294cx hess=for*bond*xs1*xs3*rss2i*rssi 3295cx hs(isa,1,3,isag)=hs(isa,1,3,isag)+hess 3296cx hs(isa,3,1,isag)=hs(isa,3,1,isag)+hess 3297cx hs(isa,1,3,jsag)=hs(isa,1,3,jsag)-hess 3298cx hs(isa,3,1,jsag)=hs(isa,3,1,jsag)-hess 3299cx hs(jsa,1,3,jsag)=hs(jsa,1,3,jsag)-hess 3300cx hs(jsa,3,1,jsag)=hs(jsa,3,1,jsag)-hess 3301cx hs(jsa,1,3,isag)=hs(jsa,1,3,isag)+hess 3302cx hs(jsa,3,1,isag)=hs(jsa,3,1,isag)+hess 3303c 3304cx hess=for*bond*xs2*xs3*rss2i*rssi 3305cx hs(isa,2,3,isag)=hs(isa,2,3,isag)+hess 3306cx hs(isa,3,2,isag)=hs(isa,3,2,isag)+hess 3307cx hs(isa,2,3,jsag)=hs(isa,2,3,jsag)-hess 3308cx hs(isa,3,2,jsag)=hs(isa,3,2,jsag)-hess 3309cx hs(jsa,2,3,jsag)=hs(jsa,2,3,jsag)-hess 3310cx hs(jsa,3,2,jsag)=hs(jsa,3,2,jsag)-hess 3311cx hs(jsa,2,3,isag)=hs(jsa,2,3,isag)+hess 3312cx hs(jsa,3,2,isag)=hs(jsa,3,2,isag)+hess 3313c 3314cx endif 3315c 3316 if(lupdti) then 3317c 3318c for thermodynamic perturbations evaluate the energies using 3319c the 'perturbed' parameters in set 2 and/or 3 3320c 3321 if(ip2(18)) 3322 + ep2(1)=ep2(1)-eterm+factu*half*bnd(isb,2,2)*(rss-bnd(isb,1,2))**2 3323 if(ip3(18)) 3324 + ep3(1)=ep3(1)-eterm+factu*half*bnd(isb,2,3)*(rss-bnd(isb,1,3))**2 3325c 3326c for thermodynamic integrations evaluate the derivative 3327c 3328 if(ith(18)) then 3329 dercon=dbond*(half*dbond*bnd(isb,2,4)-for*bnd(isb,1,4)) 3330 deriv(18,1)=deriv(18,1)+dercon 3331 if(npgdec.gt.1) then 3332 dera(5,ibnd(isb,1))=dera(5,ibnd(isb,1))+half*dercon 3333 dera(5,ibnd(isb,2))=dera(5,ibnd(isb,2))+half*dercon 3334 endif 3335 endif 3336c 3337 endif 3338 endif 3339c 3340 if(ipme.ne.0) then 3341 qij=chg(ichg(isa),1,ibset)*chg(ichg(jsa),1,ibset) 3342 ferfc=one-erfc(ealpha*rss) 3343 fderfc=-(ealpha*derfc(ealpha*rss)) 3344 epmecs=epmecs-ferfc*qij*rssi 3345 if(lupden) then 3346 ess(isf,isf,9,1)=ess(isf,isf,9,1)-half*ferfc*qij*rssi 3347 ess(jsf,jsf,9,1)=ess(jsf,jsf,9,1)-half*ferfc*qij*rssi 3348 if(ipert2) then 3349 qijp2=chg(ichg(isa),1,2)*chg(ichg(jsa),1,2) 3350 ess(isf,isf,10,1)=ess(isf,isf,10,1)-half*ferfc*qijp2*rssi 3351 ess(jsf,jsf,10,1)=ess(jsf,jsf,10,1)-half*ferfc*qijp2*rssi 3352 endif 3353 if(ipert3) then 3354 qijp3=chg(ichg(isa),1,3)*chg(ichg(jsa),1,3) 3355 ess(isf,isf,11,1)=ess(isf,isf,11,1)-half*ferfc*qijp3*rssi 3356 ess(jsf,jsf,11,1)=ess(jsf,jsf,11,1)-half*ferfc*qijp3*rssi 3357 endif 3358 endif 3359 dfor=-(qij*rssi*rssi*(ferfc*rssi-fderfc)) 3360 dfs1=dfor*xs1 3361 dfs2=dfor*xs2 3362 dfs3=dfor*xs3 3363 fs(isa,1)=fs(isa,1)-dfs1 3364 fs(jsa,1)=fs(jsa,1)+dfs1 3365 fs(isa,2)=fs(isa,2)-dfs2 3366 fs(jsa,2)=fs(jsa,2)+dfs2 3367 fs(isa,3)=fs(isa,3)-dfs3 3368 fs(jsa,3)=fs(jsa,3)+dfs3 3369 vpmeb(1)=vpmeb(1)+dfs1*xs1 3370 vpmeb(2)=vpmeb(2)+dfs2*xs1 3371 vpmeb(3)=vpmeb(3)+dfs3*xs1 3372 vpmeb(4)=vpmeb(4)+dfs2*xs2 3373 vpmeb(5)=vpmeb(5)+dfs3*xs2 3374 vpmeb(6)=vpmeb(6)+dfs3*xs3 3375 endif 3376c 3377 endif 3378c 3379 1 continue 3380c 3381 return 3382 end 3383 subroutine cf_fsh(nangls,indexl,msh,msp,iang,ang,rang,rub, 3384 + natoms,ndim,igan,isgm,imol,idyn,ichg,chg,xs,fs,ess,lpbc,lpbcs, 3385 + lupden,lupdti,dera,lseq) 3386c 3387c $Id$ 3388c 3389c cf_fsh returns forces and energies for solute angles 3390c 3391c ======================================================= 3392c 3393c description of arguments 3394c ------------------------ 3395c 3396c in: integer nangls = number of angles to consider 3397c integer indexl = index list 3398c 3399c integer idsh(msh) = global atom id i 3400c integer jdsh(msh) = global atom id j 3401c integer kdsh(msh) = global atom id k 3402c real*8 cdsh(msh,6) = angle force constants 3403c real*8 ddsh(msh,6) = angle reference value 3404c real*8 rdsh(msh) = angle value 3405c 3406c integer natoms = number of atoms in arrays 3407c integer ndim = leading dimension atom arrays 3408c integer igan(ndim) = global atom numbers 3409c integer imol(ndim) = atom molecule fraction 3410c integer idyn(ndim) = atom dynamics type 3411c real*8 qs(ndim) = atomic charges 3412c real*8 xs(ndim,3) = atom coordinates 3413c 3414c logical lupden = if .true. energies are updated 3415c 3416c out: real*8 fs(ndim,3) = atom forces (ACCUMULATED) 3417c real*8 ush(msh) = angle energies 3418c 3419 implicit none 3420c 3421#include "cf_common.fh" 3422c 3423c declaration of arguments 3424c ------------------------ 3425c 3426 integer msh,msp 3427 integer iang(msh,4) 3428 real*8 ang(msh,msp,mset),rang(msh,2),rub(msh,2) 3429 integer isgm(msa),lseq(mseq) 3430c 3431 integer nangls 3432 integer indexl(nangls) 3433c 3434c integer idsh(msh),jdsh(msh),kdsh(msh) 3435c real*8 cdsh(msh,6),ddsh(msh,6),rdsh(msh),ush(msh) 3436c 3437 integer natoms,ndim 3438 integer igan(ndim),imol(ndim),idyn(ndim),ichg(ndim) 3439 real*8 chg(mqt,mqp,mset) 3440 real*8 xs(ndim,3),fs(ndim,3),ess(msf,msf,mpe,2) 3441c 3442 logical lpbc,lpbcs,lupden,lupdti 3443 real*8 dera(6,nsatot) 3444c 3445c declaration of local variables 3446c ------------------------------ 3447c 3448 integer i,j,ish,isa,jsa,ksa,isf,jsf,ksf,ibset 3449 integer ifacu 3450 real*8 angle,dangle,for,dfor,dfs,phi,cphi,sphi,factu,dercon 3451 real*8 xsijx,xskjx,xsijy,xskjy,xsijz,xskjz 3452 real*8 rsij2,rskj2,rsij2i,rskj2i,rsikji,dx(3),eterm 3453 real*8 qij,xs1,xs2,xs3,rss,rsi,ferfc,fderfc,dfs1,dfs2,dfs3 3454 real*8 qijp2,qijp3 3455 real*8 rb,bond,rss2,rssi,rss2i,dbond 3456c 3457#include "cf_funcs_dec.fh" 3458#include "bitops_decls.fh" 3459#include "cf_funcs_sfn.fh" 3460#include "bitops_funcs.fh" 3461c 3462c solute angles 3463c ============= 3464c 3465 do 1 i=1,nangls 3466c 3467c find index into list of angles 3468c ------------------------------ 3469c 3470 ish=indexl(i) 3471c 3472c find local atom numbers involved in this angle 3473c ---------------------------------------------- 3474c 3475 isa=0 3476 jsa=0 3477 ksa=0 3478c 3479 do 2 j=1,natoms 3480 if(iang(ish,1).eq.igan(j)) isa=j 3481 if(iang(ish,2).eq.igan(j)) jsa=j 3482 if(iang(ish,3).eq.igan(j)) ksa=j 3483 2 continue 3484c 3485c get solute molecule numbers involved in this angle 3486c -------------------------------------------------- 3487c 3488 isf=imol(isa) 3489 jsf=imol(jsa) 3490 ksf=imol(ksa) 3491c 3492c determine the factor for the energies depending on 3493c atoms being dynamic or fixed 3494c -------------------------------------------------- 3495c 3496 ifacu=0 3497 if(iand(idyn(isa),mdynam).eq.ldynam) ifacu=ifacu+1 3498 if(iand(idyn(jsa),mdynam).eq.ldynam) ifacu=ifacu+1 3499 if(iand(idyn(ksa),mdynam).eq.ldynam) ifacu=ifacu+1 3500c factu=dble(ifacu)/three 3501 factu=one 3502 if(ifacu.eq.0) factu=zero 3503 if(includ.eq.1) factu=one 3504c 3505c get reference angle and force constant 3506c -------------------------------------- 3507c 3508 if(nfhop.eq.0) then 3509 angle=ang(ish,1,iset) 3510 for=ang(ish,2,iset) 3511 else 3512 angle=ang(ish,1,lseq(isgm(jsa))) 3513 for=ang(ish,2,lseq(isgm(jsa))) 3514 endif 3515c 3516c determine the angle 3517c ------------------- 3518c 3519 xsijx=xs(isa,1)-xs(jsa,1) 3520 xskjx=xs(ksa,1)-xs(jsa,1) 3521 xsijy=xs(isa,2)-xs(jsa,2) 3522 xskjy=xs(ksa,2)-xs(jsa,2) 3523 xsijz=xs(isa,3)-xs(jsa,3) 3524 xskjz=xs(ksa,3)-xs(jsa,3) 3525c 3526c periodic boundary conditions 3527c 3528 if(lpbc.or.lpbcs) then 3529 dx(1)=xsijx 3530 dx(2)=xsijy 3531 dx(3)=xsijz 3532 call cf_pbc(1,dx,1,dx,1,0,1,1) 3533 xsijx=dx(1) 3534 xsijy=dx(2) 3535 xsijz=dx(3) 3536 dx(1)=xskjx 3537 dx(2)=xskjy 3538 dx(3)=xskjz 3539 call cf_pbc(1,dx,1,dx,1,0,1,1) 3540 xskjx=dx(1) 3541 xskjy=dx(2) 3542 xskjz=dx(3) 3543 endif 3544c 3545 rsij2=xsijx*xsijx+xsijy*xsijy+xsijz*xsijz 3546 rskj2=xskjx*xskjx+xskjy*xskjy+xskjz*xskjz 3547 cphi=xsijx*xskjx+xsijy*xskjy+xsijz*xskjz 3548 rsij2i=one/rsij2 3549 rskj2i=one/rskj2 3550 rsikji=one/sqrt(rsij2*rskj2) 3551 cphi=cphi*rsikji 3552 if(cphi.lt.-one) cphi=-one 3553 if(cphi.gt. one) cphi= one 3554 phi=acos(cphi) 3555 rang(ish,1)=phi 3556 dangle=phi-angle 3557c 3558c evaluate energies and forces 3559c ---------------------------- 3560c 3561 rang(ish,2)=half*for*dangle*dangle 3562 eterm=zero 3563 if(lupden) then 3564 ess(isf,isf,2,1)=ess(isf,isf,2,1)+third*factu*rang(ish,2) 3565 ess(jsf,jsf,2,1)=ess(jsf,jsf,2,1)+third*factu*rang(ish,2) 3566 ess(ksf,ksf,2,1)=ess(ksf,ksf,2,1)+third*factu*rang(ish,2) 3567 endif 3568 eterm=factu*rang(ish,2) 3569 sphi=sin(phi) 3570 if(abs(sphi).lt.small) sphi=small 3571 dfor=for*dangle/sphi 3572 dfs=dfor*(xskjx*rsikji-xsijx*rsij2i*cphi) 3573 fs(isa,1)=fs(isa,1)+dfs 3574 fs(jsa,1)=fs(jsa,1)-dfs 3575 dfs=dfor*(xsijx*rsikji-xskjx*rskj2i*cphi) 3576 fs(ksa,1)=fs(ksa,1)+dfs 3577 fs(jsa,1)=fs(jsa,1)-dfs 3578 dfs=dfor*(xskjy*rsikji-xsijy*rsij2i*cphi) 3579 fs(isa,2)=fs(isa,2)+dfs 3580 fs(jsa,2)=fs(jsa,2)-dfs 3581 dfs=dfor*(xsijy*rsikji-xskjy*rskj2i*cphi) 3582 fs(ksa,2)=fs(ksa,2)+dfs 3583 fs(jsa,2)=fs(jsa,2)-dfs 3584 dfs=dfor*(xskjz*rsikji-xsijz*rsij2i*cphi) 3585 fs(isa,3)=fs(isa,3)+dfs 3586 fs(jsa,3)=fs(jsa,3)-dfs 3587 dfs=dfor*(xsijz*rsikji-xskjz*rskj2i*cphi) 3588 fs(ksa,3)=fs(ksa,3)+dfs 3589 fs(jsa,3)=fs(jsa,3)-dfs 3590c 3591c evaluate the hessian 3592c ------------------- 3593c 3594cx if(ihess.gt.0) then 3595cx endif 3596c 3597 if(lupdti) then 3598c 3599c for thermodynamic perturbations evaluate the energies 3600c using 'perturbed' parameters of set 2 and/or set 3 3601c ----------------------------------------------------- 3602c 3603 if(ip2(20)) 3604 + ep2(1)=ep2(1)-eterm+factu*half*ang(ish,2,2)*(phi-ang(ish,1,2))**2 3605 if(ip3(20)) 3606 + ep3(1)=ep3(1)-eterm+factu*half*ang(ish,2,3)*(phi-ang(ish,1,3))**2 3607c 3608c for thermodynamic integrations evaluate the derivative 3609c ------------------------------------------------------ 3610c 3611 if(ith(20)) then 3612 dercon=dangle*(half*dangle*ang(ish,2,4)-for*ang(ish,1,4)) 3613 deriv(20,1)=deriv(20,1)+dercon 3614 if(npgdec.gt.1) then 3615 dera(5,iang(ish,1))=dera(5,iang(ish,1))+third*dercon 3616 dera(5,iang(ish,2))=dera(5,iang(ish,2))+third*dercon 3617 dera(5,iang(ish,3))=dera(5,iang(ish,3))+third*dercon 3618 endif 3619 endif 3620 endif 3621c 3622c particle-mesh Ewald correction energy and forces 3623c ------------------------------------------------ 3624c 3625 if(ipme.ne.0) then 3626 isf=imol(isa) 3627 ksf=imol(ksa) 3628 qij=chg(ichg(isa),1,1)*chg(ichg(ksa),1,1) 3629 xs1=xs(isa,1)-xs(ksa,1) 3630 xs2=xs(isa,2)-xs(ksa,2) 3631 xs3=xs(isa,3)-xs(ksa,3) 3632 rss=sqrt(xs1**2+xs2**2+xs3**2) 3633 rsi=one/rss 3634 ferfc=one-erfc(ealpha*rss) 3635 fderfc=-(ealpha*derfc(ealpha*rss)) 3636 epmecs=epmecs-ferfc*qij*rsi 3637 if(lupden) then 3638 ess(isf,isf,9,1)=ess(isf,isf,9,1)-half*ferfc*qij*rsi 3639 ess(ksf,ksf,9,1)=ess(ksf,ksf,9,1)-half*ferfc*qij*rsi 3640 if(ipert2) then 3641 qijp2=chg(ichg(isa),1,2)*chg(ichg(ksa),1,2) 3642 ess(isf,isf,10,1)=ess(isf,isf,10,1)-half*ferfc*qijp2*rsi 3643 ess(ksf,ksf,10,1)=ess(ksf,ksf,10,1)-half*ferfc*qijp2*rsi 3644 endif 3645 if(ipert2) then 3646 qijp3=chg(ichg(isa),1,3)*chg(ichg(ksa),1,3) 3647 ess(isf,isf,11,1)=ess(isf,isf,11,1)-half*ferfc*qijp3*rsi 3648 ess(ksf,ksf,11,1)=ess(ksf,ksf,11,1)-half*ferfc*qijp3*rsi 3649 endif 3650 endif 3651 dfor=-(qij*rsi*rsi*(ferfc*rsi-fderfc)) 3652 dfs1=dfor*xs1 3653 dfs2=dfor*xs2 3654 dfs3=dfor*xs3 3655 fs(isa,1)=fs(isa,1)-dfs1 3656 fs(ksa,1)=fs(ksa,1)+dfs1 3657 fs(isa,2)=fs(isa,2)-dfs2 3658 fs(ksa,2)=fs(ksa,2)+dfs2 3659 fs(isa,3)=fs(isa,3)-dfs3 3660 fs(ksa,3)=fs(ksa,3)+dfs3 3661 vpmeb(1)=vpmeb(1)+dfs1*xs1 3662 vpmeb(2)=vpmeb(2)+dfs2*xs1 3663 vpmeb(3)=vpmeb(3)+dfs3*xs1 3664 vpmeb(4)=vpmeb(4)+dfs2*xs2 3665 vpmeb(5)=vpmeb(5)+dfs3*xs2 3666 vpmeb(6)=vpmeb(6)+dfs3*xs3 3667 endif 3668c 3669 1 continue 3670c 3671 if(iffld.eq.2) then 3672c 3673c Urey-Bradley solute angles 3674c ========================== 3675c 3676 do 3 i=1,nangls 3677c 3678c find index into list of angles 3679c ------------------------------ 3680c 3681 ish=indexl(i) 3682c 3683c find local atom numbers involved in this angle 3684c ---------------------------------------------- 3685c 3686 isa=0 3687 ksa=0 3688c 3689 do 4 j=1,natoms 3690 if(iang(ish,1).eq.igan(j)) isa=j 3691 if(iang(ish,3).eq.igan(j)) ksa=j 3692 4 continue 3693 isf=imol(isa) 3694 ksf=imol(ksa) 3695c 3696 if(nfhop.eq.0) then 3697 ibset=iset 3698 else 3699 ibset=lseq(isgm(isa)) 3700 endif 3701c 3702c find reference bond length and force constant 3703c 3704 bond=ang(ish,3,ibset) 3705 for=ang(ish,4,ibset) 3706c 3707 if(for.gt.0.0d0) then 3708c 3709c determine actual distance between the atoms 3710c 3711 xs1=xs(isa,1)-xs(ksa,1) 3712 xs2=xs(isa,2)-xs(ksa,2) 3713 xs3=xs(isa,3)-xs(ksa,3) 3714c 3715c periodic boundary conditions 3716c 3717 if(lpbc.or.lpbcs) then 3718 dx(1)=xs1 3719 dx(2)=xs2 3720 dx(3)=xs3 3721 call cf_pbc(1,dx,1,dx,1,0,1,1) 3722 xs1=dx(1) 3723 xs2=dx(2) 3724 xs3=dx(3) 3725 endif 3726c 3727 rss2=xs1**2+xs2**2+xs3**2 3728 if(rss2.gt.tiny) then 3729 rss=sqrt(rss2) 3730 rssi=one/rss 3731 rss2i=rssi*rssi 3732 else 3733 rss=zero 3734 rssi=one 3735 rss2i=one 3736 endif 3737c 3738c determine fraction of energy to be counted 3739c this depends on the atoms being dynamic or fixed 3740c 3741 factu=zero 3742 if(iand(idyn(isa),mdynam).eq.ldynam.or. 3743 + iand(idyn(ksa),mdynam).eq.ldynam) factu=one 3744c if((iand(idyn(isa),mdynam).eq.ldynam.and. 3745c + iand(idyn(ksa),mdynam).ne.ldynam) .or. 3746c + (iand(idyn(isa),mdynam).ne.ldynam.and. 3747c + iand(idyn(ksa),mdynam).eq.ldynam)) factu=half 3748 if(includ.eq.1) factu=one 3749c 3750 dbond=rss-bond 3751c 3752c evaluate energies and forces 3753c 3754 rb=half*for*dbond*dbond 3755 eterm=zero 3756 if(lupden) then 3757 ess(isf,isf,13,1)=ess(isf,isf,13,1)+half*factu*rb 3758 ess(ksf,ksf,13,1)=ess(ksf,ksf,13,1)+half*factu*rb 3759 endif 3760 eterm=factu*rb 3761 dfor=for*dbond*rssi 3762 dfs1=dfor*xs1 3763 dfs2=dfor*xs2 3764 dfs3=dfor*xs3 3765 fs(isa,1)=fs(isa,1)-dfs1 3766 fs(ksa,1)=fs(ksa,1)+dfs1 3767 fs(isa,2)=fs(isa,2)-dfs2 3768 fs(ksa,2)=fs(ksa,2)+dfs2 3769 fs(isa,3)=fs(isa,3)-dfs3 3770 fs(ksa,3)=fs(ksa,3)+dfs3 3771c 3772 rub(ish,1)=rss 3773 rub(ish,2)=eterm 3774c 3775 if(lupdti) then 3776c 3777c for thermodynamic perturbations evaluate the energies using 3778c the 'perturbed' parameters in set 2 and/or 3 3779c 3780 if(ip2(18)) 3781 + ep2(1)=ep2(1)-eterm+factu*half*ang(ish,4,2)*(rss-ang(ish,3,2))**2 3782 if(ip3(18)) 3783 + ep3(1)=ep3(1)-eterm+factu*half*ang(ish,4,3)*(rss-ang(ish,3,3))**2 3784c 3785c for thermodynamic integrations evaluate the derivative 3786c 3787 if(ith(18)) then 3788 dercon=dbond*(half*dbond*ang(ish,4,4)-for*ang(ish,3,4)) 3789 deriv(20,1)=deriv(20,1)+dercon 3790 if(npgdec.gt.1) then 3791 dera(5,iang(ish,1))=dera(5,iang(ish,1))+half*dercon 3792 dera(5,iang(ish,3))=dera(5,iang(ish,3))+half*dercon 3793 endif 3794 endif 3795c 3796 endif 3797c 3798 endif 3799c 3800 3 continue 3801c 3802 endif 3803c 3804 return 3805 end 3806 subroutine cf_fsd(ndihes,indexl,msd,msp,idih,dih,rdih, 3807 + natoms,ndim,igan,isgm,imol,idyn,xs,fs,ess,lpbc,lpbcs,lupden, 3808 + lupdti,dera,lseq) 3809c 3810c $Id$ 3811c 3812c cf_fsd returns forces and energies for solute angles 3813c 3814c ======================================================= 3815c 3816c description of arguments 3817c ------------------------ 3818c 3819c in: integer ndihes = number of angles to consider 3820c integer indexl = index list 3821c 3822c integer idsd(msd) = global atom id i 3823c integer jdsd(msd) = global atom id j 3824c integer kdsd(msd) = global atom id k 3825c integer ldsd(msd) = global atom id l 3826c real*8 cdsd(msd,6) = dihedral angle force constants 3827c real*8 ddsd(msd,6) = dihedral angle reference value 3828c real*8 edsd(msd,6) = dihedral angle multiplicity 3829c real*8 rdsd(msd) = dihedral angle value 3830c 3831c integer natoms = number of atoms in arrays 3832c integer ndim = leading dimension atom arrays 3833c integer igan(ndim) = global atom numbers 3834c integer imol(ndim) = atom molecule fraction 3835c integer idyn(ndim) = atom dynamics type 3836c real*8 xs(ndim,3) = atom coordinates 3837c 3838c logical lupden = if .true. energies are updated 3839c 3840c out: real*8 fs(ndim,3) = atom forces (ACCUMULATED) 3841c real*8 usd(msd) = dihedral angle energies 3842c 3843 implicit none 3844c 3845#include "cf_common.fh" 3846c 3847c declaration of arguments 3848c ------------------------ 3849c 3850 integer msd,msp 3851 integer idih(msd,5) 3852 real*8 dih(msd,msp,mset),rdih(msd,2) 3853 integer isgm(msa),lseq(mseq) 3854c 3855 integer ndihes 3856 integer indexl(ndihes) 3857c 3858 integer natoms,ndim 3859 integer igan(ndim),imol(ndim),idyn(ndim) 3860 real*8 xs(ndim,3),fs(ndim,3),ess(msf,msf,mpe,2) 3861c 3862 logical lpbc,lpbcs,lupden,lupdti 3863 real*8 dera(6,nsatot) 3864c 3865c declaration of local variables 3866c ------------------------------ 3867c 3868 integer i,j,isd,isa,jsa,ksa,lsa,isf,jsf,ksf,lsf 3869 integer ifacu 3870 real*8 ang,for,dfor,phi,cphi,cphii,sphi,sphii 3871 real*8 rmul,factu,dercon 3872 real*8 xsijx,xskjx,xsijy,xskjy,xsijz,xskjz 3873 real*8 xsklx,xsjlx,xskly,xsjly,xsklz,xsjlz 3874 real*8 xsikx,xsiky,xsikz,xmx,xmy,xmz,xnx,xny,xnz,xdx,xdy,xdz 3875 real*8 xex,xey,xez,xox,xoy,xoz,xpx,xpy,xpz 3876 real*8 dfsix,dfsiy,dfsiz,dfsjx,dfsjy,dfsjz 3877 real*8 dfskx,dfsky,dfskz,dfslx,dfsly,dfslz 3878 real*8 rm2i,rn2i,rmni,s,rpa,dx(3),eterm 3879 real*8 rkj,rkjo,rkjp 3880c 3881c#include "cf_funcs_dec.fh" 3882#include "bitops_decls.fh" 3883c#include "cf_funcs_sfn.fh" 3884#include "bitops_funcs.fh" 3885c 3886 do 1 i=1,ndihes 3887c 3888c find index into list of dihedrals 3889c --------------------------------- 3890c 3891 isd=indexl(i) 3892c 3893c find local atom numbers involved in dihedral 3894c -------------------------------------------- 3895c 3896 isa=0 3897 jsa=0 3898 ksa=0 3899 lsa=0 3900c 3901 do 2 j=1,natoms 3902 if(idih(isd,1).eq.igan(j)) isa=j 3903 if(idih(isd,2).eq.igan(j)) jsa=j 3904 if(idih(isd,3).eq.igan(j)) ksa=j 3905 if(idih(isd,4).eq.igan(j)) lsa=j 3906 2 continue 3907c 3908c find solute molecule numbers involved in dihedral 3909c ------------------------------------------------- 3910c 3911 isf=imol(isa) 3912 jsf=imol(jsa) 3913 ksf=imol(ksa) 3914 lsf=imol(lsa) 3915c 3916c find energy factor that depends on the atoms involved 3917c being dynamic or fixed 3918c ----------------------------------------------------- 3919c 3920 ifacu=0 3921 if(iand(idyn(isa),mdynam).eq.ldynam) ifacu=ifacu+1 3922 if(iand(idyn(jsa),mdynam).eq.ldynam) ifacu=ifacu+1 3923 if(iand(idyn(ksa),mdynam).eq.ldynam) ifacu=ifacu+1 3924 if(iand(idyn(lsa),mdynam).eq.ldynam) ifacu=ifacu+1 3925c factu=dble(ifacu)/four 3926 factu=one 3927 if(ifacu.eq.0) factu=zero 3928 if(includ.eq.1) factu=one 3929c 3930c find reference angle and force constants 3931c ---------------------------------------- 3932c 3933 if(nfhop.eq.0) then 3934 ang=dih(isd,2,iset) 3935 for=dih(isd,3,iset) 3936 rmul=dih(isd,1,iset) 3937 else 3938 ang=dih(isd,2,lseq(isgm(jsa))) 3939 for=dih(isd,3,lseq(isgm(jsa))) 3940 rmul=dih(isd,1,lseq(isgm(jsa))) 3941 endif 3942c 3943c determine the dihedral angle 3944c ---------------------------- 3945c 3946 xsijx=xs(isa,1)-xs(jsa,1) 3947 xskjx=xs(ksa,1)-xs(jsa,1) 3948 xsklx=xs(ksa,1)-xs(lsa,1) 3949 xsikx=xsijx-xskjx 3950 xsjlx=xsklx-xskjx 3951 xsijy=xs(isa,2)-xs(jsa,2) 3952 xskjy=xs(ksa,2)-xs(jsa,2) 3953 xskly=xs(ksa,2)-xs(lsa,2) 3954 xsiky=xsijy-xskjy 3955 xsjly=xskly-xskjy 3956 xsijz=xs(isa,3)-xs(jsa,3) 3957 xskjz=xs(ksa,3)-xs(jsa,3) 3958 xsklz=xs(ksa,3)-xs(lsa,3) 3959 xsikz=xsijz-xskjz 3960 xsjlz=xsklz-xskjz 3961c 3962c periodic boundary conditions 3963c 3964 if(lpbc.or.lpbcs) then 3965 dx(1)=xsijx 3966 dx(2)=xsijy 3967 dx(3)=xsijz 3968 call cf_pbc(1,dx,1,dx,1,0,1,1) 3969 xsijx=dx(1) 3970 xsijy=dx(2) 3971 xsijz=dx(3) 3972 dx(1)=xsikx 3973 dx(2)=xsiky 3974 dx(3)=xsikz 3975 call cf_pbc(1,dx,1,dx,1,0,1,1) 3976 xsikx=dx(1) 3977 xsiky=dx(2) 3978 xsikz=dx(3) 3979 dx(1)=xskjx 3980 dx(2)=xskjy 3981 dx(3)=xskjz 3982 call cf_pbc(1,dx,1,dx,1,0,1,1) 3983 xskjx=dx(1) 3984 xskjy=dx(2) 3985 xskjz=dx(3) 3986 dx(1)=xsklx 3987 dx(2)=xskly 3988 dx(3)=xsklz 3989 call cf_pbc(1,dx,1,dx,1,0,1,1) 3990 xsklx=dx(1) 3991 xskly=dx(2) 3992 xsklz=dx(3) 3993 dx(1)=xsjlx 3994 dx(2)=xsjly 3995 dx(3)=xsjlz 3996 call cf_pbc(1,dx,1,dx,1,0,1,1) 3997 xsjlx=dx(1) 3998 xsjly=dx(2) 3999 xsjlz=dx(3) 4000 endif 4001c 4002 xmx=xsijy*xskjz-xskjy*xsijz 4003 xmy=xsijz*xskjx-xskjz*xsijx 4004 xmz=xsijx*xskjy-xskjx*xsijy 4005 xnx=xskjy*xsklz-xskly*xskjz 4006 xny=xskjz*xsklx-xsklz*xskjx 4007 xnz=xskjx*xskly-xsklx*xskjy 4008 rm2i=one/(xmx*xmx+xmy*xmy+xmz*xmz) 4009 rn2i=one/(xnx*xnx+xny*xny+xnz*xnz) 4010 rmni=sqrt(rm2i*rn2i) 4011 cphi=(xmx*xnx+xmy*xny+xmz*xnz)*rmni 4012 if(cphi.lt.-one) cphi=-one 4013 if(cphi.gt. one) cphi= one 4014 phi=acos(cphi) 4015 s=xskjx*(xmy*xnz-xmz*xny) +xskjy*(xmz*xnx-xmx*xnz) 4016 + +xskjz*(xmx*xny-xmy*xnx) 4017 if(s.lt.zero) phi=-phi 4018 rdih(isd,1)=phi 4019 sphi=sin(phi) 4020 rpa=rmul*phi-ang 4021c 4022c evaluate energies 4023c ----------------- 4024c 4025 rdih(isd,2)=for*(one+cos(rpa)) 4026c 4027 eterm=zero 4028 if(lupden) then 4029 ess(isf,isf,3,1)=ess(isf,isf,3,1)+fourth*factu*rdih(isd,2) 4030 ess(jsf,jsf,3,1)=ess(jsf,jsf,3,1)+fourth*factu*rdih(isd,2) 4031 ess(ksf,ksf,3,1)=ess(ksf,ksf,3,1)+fourth*factu*rdih(isd,2) 4032 ess(lsf,lsf,3,1)=ess(lsf,lsf,3,1)+fourth*factu*rdih(isd,2) 4033 endif 4034 eterm=factu*rdih(isd,2) 4035c 4036 dfor=(-for)*rmul*sin(rpa) 4037c 4038c for thermodynamic perturbations evaluate the energies using 4039c the 'perturbed' parameters in set 2 and/or set 3 4040c ----------------------------------------------------------- 4041c 4042 if(ip2(21)) ep2(1)=ep2(1)-eterm+ 4043 + factu*dih(isd,3,2)*(one+cos(dih(isd,1,2)*phi-dih(isd,2,2))) 4044 if(ip3(21)) ep3(1)=ep3(1)-eterm+ 4045 + factu*dih(isd,3,3)*(one+cos(dih(isd,1,3)*phi-dih(isd,2,3))) 4046c 4047c for normal angles use cosine equation to get the forces 4048c ------------------------------------------------------- 4049c 4050 if(abs(sphi).gt.small) then 4051 sphii=one/sphi 4052 xdx=(-dfor)*sphii*(rmni*xnx-cphi*rm2i*xmx) 4053 xex=(-dfor)*sphii*(rmni*xmx-cphi*rn2i*xnx) 4054 xdy=(-dfor)*sphii*(rmni*xny-cphi*rm2i*xmy) 4055 xey=(-dfor)*sphii*(rmni*xmy-cphi*rn2i*xny) 4056 xdz=(-dfor)*sphii*(rmni*xnz-cphi*rm2i*xmz) 4057 xez=(-dfor)*sphii*(rmni*xmz-cphi*rn2i*xnz) 4058 dfsix=xskjy*xdz-xskjz*xdy 4059 dfsiy=xskjz*xdx-xskjx*xdz 4060 dfsiz=xskjx*xdy-xskjy*xdx 4061 dfsjx=xsiky*xdz-xsikz*xdy-xskly*xez+xsklz*xey 4062 dfsjy=xsikz*xdx-xsikx*xdz-xsklz*xex+xsklx*xez 4063 dfsjz=xsikx*xdy-xsiky*xdx-xsklx*xey+xskly*xex 4064 dfskx=xsjly*xez-xsjlz*xey-xsijy*xdz+xsijz*xdy 4065 dfsky=xsjlz*xex-xsjlx*xez-xsijz*xdx+xsijx*xdz 4066 dfskz=xsjlx*xey-xsjly*xex-xsijx*xdy+xsijy*xdx 4067 dfslx=xskjy*xez-xskjz*xey 4068 dfsly=xskjz*xex-xskjx*xez 4069 dfslz=xskjx*xey-xskjy*xex 4070 else 4071c 4072c for small angles use the sine equations to get forces 4073c ----------------------------------------------------- 4074c 4075 cphii=one/cphi 4076 rkj=sqrt(xskjx*xskjx+xskjy*xskjy+xskjz*xskjz) 4077 xox=xskly*xsikz-xsklz*xsiky 4078 xoy=xsklz*xsikx-xsklx*xsikz 4079 xoz=xsklx*xsiky-xskly*xsikx 4080 rkjo=(xskjx*xox+xskjy*xoy+xskjz*xoz)/rkj 4081 xpx=xsijy*xsjlz-xsijz*xsjly 4082 xpy=xsijz*xsjlx-xsijx*xsjlz 4083 xpz=xsijx*xsjly-xsijy*xsjlx 4084 rkjp=(xskjx*xpx+xskjy*xpy+xskjz*xpz)/rkj 4085 dfsix=dfor*cphii* (rkj*rmni*xnx-sphi*rm2i*(xskjy*xmz-xskjz*xmy)) 4086 dfsiy=dfor*cphii* (rkj*rmni*xny-sphi*rm2i*(xskjz*xmx-xskjx*xmz)) 4087 dfsiz=dfor*cphii* (rkj*rmni*xnz-sphi*rm2i*(xskjx*xmy-xskjy*xmx)) 4088 dfsjx=dfor*cphii*((-rmni)*(rkjo*xskjx+rkj*xox)- 4089 + sphi*rm2i*(xsiky*xmz-xsikz*xmy)+ 4090 + sphi*rn2i*(xskly*xnz-xsklz*xny)) 4091 dfsjy=dfor*cphii*((-rmni)*(rkjo*xskjy+rkj*xoy)- 4092 + sphi*rm2i*(xsikz*xmx-xsikx*xmz)+ 4093 + sphi*rn2i*(xsklz*xnx-xsklx*xnz)) 4094 dfsjz=dfor*cphii*((-rmni)*(rkjo*xskjz+rkj*xoz)- 4095 + sphi*rm2i*(xsikx*xmy-xsiky*xmx)+ 4096 + sphi*rn2i*(xsklx*xny-xskly*xnx)) 4097 dfskx=dfor*cphii*((-rmni)*(rkjp*xskjx+rkj*xpx)- 4098 + sphi*rn2i*(xsjly*xnz-xsjlz*xny)+ 4099 + sphi*rm2i*(xsijy*xmz-xsijz*xmy)) 4100 dfsky=dfor*cphii*((-rmni)*(rkjp*xskjy+rkj*xpy)- 4101 + sphi*rn2i*(xsjlz*xnx-xsjlx*xnz)+ 4102 + sphi*rm2i*(xsijz*xmx-xsijx*xmz)) 4103 dfskz=dfor*cphii*((-rmni)*(rkjp*xskjz+rkj*xpz)- 4104 + sphi*rn2i*(xsjlx*xny-xsjly*xnx)+ 4105 + sphi*rm2i*(xsijx*xmy-xsijy*xmx)) 4106 dfslx=dfor*cphii* 4107 + ((-rkj)*rmni*xmx-sphi*rn2i*(xskjy*xnz-xskjz*xny)) 4108 dfsly=dfor*cphii* 4109 + ((-rkj)*rmni*xmy-sphi*rn2i*(xskjz*xnx-xskjx*xnz)) 4110 dfslz=dfor*cphii* 4111 + ((-rkj)*rmni*xmz-sphi*rn2i*(xskjx*xny-xskjy*xnx)) 4112 endif 4113c 4114c accumulate the forces 4115c --------------------- 4116c 4117 fs(isa,1)=fs(isa,1)-dfsix 4118 fs(jsa,1)=fs(jsa,1)-dfsjx 4119 fs(ksa,1)=fs(ksa,1)-dfskx 4120 fs(lsa,1)=fs(lsa,1)-dfslx 4121 fs(isa,2)=fs(isa,2)-dfsiy 4122 fs(jsa,2)=fs(jsa,2)-dfsjy 4123 fs(ksa,2)=fs(ksa,2)-dfsky 4124 fs(lsa,2)=fs(lsa,2)-dfsly 4125 fs(isa,3)=fs(isa,3)-dfsiz 4126 fs(jsa,3)=fs(jsa,3)-dfsjz 4127 fs(ksa,3)=fs(ksa,3)-dfskz 4128 fs(lsa,3)=fs(lsa,3)-dfslz 4129c 4130 if(lupdti) then 4131c 4132c for thermodynamic integration evaluate the derivative 4133c ----------------------------------------------------- 4134c 4135 if(ith(21)) then 4136 dercon=(one+cos(rpa))*dih(isd,3,4) 4137 + -for*sin(rpa)*(phi*dih(isd,1,4)-dih(isd,2,4)) 4138 deriv(21,1)=deriv(21,1)+dercon 4139 if(npgdec.gt.1) then 4140 dera(5,idih(isd,1))=dera(5,idih(isd,1))+fourth*dercon 4141 dera(5,idih(isd,2))=dera(5,idih(isd,2))+fourth*dercon 4142 dera(5,idih(isd,3))=dera(5,idih(isd,3))+fourth*dercon 4143 dera(5,idih(isd,4))=dera(5,idih(isd,4))+fourth*dercon 4144 endif 4145 endif 4146 endif 4147c 4148 1 continue 4149c 4150 return 4151 end 4152 subroutine cf_fso(nimprs,indexl,mso,msp,iimp,dimp,rimp, 4153 + natoms,ndim,igan,isgm,imol,idyn,xs,fs,ess,lpbc,lpbcs,lupden, 4154 + lupdti,dera,lseq) 4155c 4156c $Id$ 4157c 4158c cf_fso returns forces and energies for solute improper dihedral angles 4159c 4160c ========================================================================= 4161c 4162c description of arguments 4163c ------------------------ 4164c 4165c in: integer ndihes = number of angles to consider 4166c integer indexl = index list 4167c 4168c integer idso(mso) = global atom id i 4169c integer jdso(mso) = global atom id j 4170c integer kdso(mso) = global atom id k 4171c integer ldso(mso) = global atom id l 4172c real*8 cdso(mso,6) = dihedral angle force constants 4173c real*8 ddso(mso,6) = dihedral angle reference value 4174c real*8 rdso(mso) = dihedral angle value 4175c 4176c integer natoms = number of atoms in arrays 4177c integer ndim = leading dimension atom arrays 4178c integer igan(ndim) = global atom numbers 4179c integer imol(ndim) = atom molecule fraction 4180c integer idyn(ndim) = atom dynamics type 4181c real*8 qs(ndim) = atomic charges 4182c real*8 xs(ndim,3) = atom coordinates 4183c 4184c logical lupden = if .true. energies are updated 4185c 4186c out: real*8 fs(ndim,3) = atom forces (ACCUMULATED) 4187c real*8 uso(mso) = dihedral angle energies 4188c 4189 implicit none 4190c 4191#include "cf_common.fh" 4192c 4193c declaration of arguments 4194c ------------------------ 4195c 4196 integer mso,msp 4197 integer iimp(mso,5) 4198 real*8 dimp(mso,msp,mset),rimp(mso,2) 4199 integer isgm(msa),lseq(mseq) 4200c 4201 integer nimprs 4202 integer indexl(nimprs) 4203c 4204 integer natoms,ndim 4205 integer igan(ndim),imol(ndim),idyn(ndim) 4206 real*8 xs(ndim,3),fs(ndim,3),ess(msf,msf,mpe,2) 4207c 4208 logical lpbc,lpbcs,lupden,lupdti 4209 real*8 dera(6,nsatot) 4210c 4211c declaration of local variables 4212c ----------------------------- 4213c 4214 integer i,j,iso,isa,jsa,ksa,lsa,isf,jsf,ksf,lsf 4215 integer ifacu 4216 real*8 ang,dang,dangp,for,dfor,phi,cphi,cphii,sphi,sphii 4217 real*8 factu,dercon 4218 real*8 xsijx,xskjx,xsijy,xskjy,xsijz,xskjz 4219 real*8 xsklx,xsjlx,xskly,xsjly,xsklz,xsjlz 4220 real*8 xsikx,xsiky,xsikz,xmx,xmy,xmz,xnx,xny,xnz,xdx,xdy,xdz 4221 real*8 xex,xey,xez,xox,xoy,xoz,xpx,xpy,xpz 4222 real*8 dfsix,dfsiy,dfsiz,dfsjx,dfsjy,dfsjz 4223 real*8 dfskx,dfsky,dfskz,dfslx,dfsly,dfslz 4224 real*8 rm2i,rn2i,rmni,s,dx(3),eterm 4225 real*8 rkj,rkjo,rkjp 4226c 4227c#include "cf_funcs_dec.fh" 4228#include "bitops_decls.fh" 4229c#include "cf_funcs_sfn.fh" 4230#include "bitops_funcs.fh" 4231c 4232 do 1 i=1,nimprs 4233c 4234c find index into improper torsion list 4235c 4236 iso=indexl(i) 4237c 4238c find local atom numbers involved in improper dihedral 4239c 4240 isa=0 4241 jsa=0 4242 ksa=0 4243 lsa=0 4244 do 2 j=1,natoms 4245 if(iimp(iso,1).eq.igan(j)) isa=j 4246 if(iimp(iso,2).eq.igan(j)) jsa=j 4247 if(iimp(iso,3).eq.igan(j)) ksa=j 4248 if(iimp(iso,4).eq.igan(j)) lsa=j 4249 2 continue 4250c 4251c find solute molecules involved in this improper 4252c 4253 isf=imol(isa) 4254 jsf=imol(jsa) 4255 ksf=imol(ksa) 4256 lsf=imol(lsa) 4257c 4258c determine the energy factor depending on atoms being 4259c dynamic or fixed 4260c 4261 ifacu=0 4262 if(iand(idyn(isa),mdynam).eq.ldynam) ifacu=ifacu+1 4263 if(iand(idyn(jsa),mdynam).eq.ldynam) ifacu=ifacu+1 4264 if(iand(idyn(ksa),mdynam).eq.ldynam) ifacu=ifacu+1 4265 if(iand(idyn(lsa),mdynam).eq.ldynam) ifacu=ifacu+1 4266c factu=dble(ifacu)/four 4267 factu=one 4268 if(ifacu.eq.0) factu=zero 4269 if(includ.eq.1) factu=one 4270c 4271c get reference angle and force constant 4272c 4273 if(nfhop.eq.0) then 4274 ang=dimp(iso,2,iset) 4275 for=dimp(iso,3,iset) 4276 else 4277 ang=dimp(iso,2,lseq(isgm(jsa))) 4278 for=dimp(iso,3,lseq(isgm(jsa))) 4279 endif 4280c 4281c determine the angle 4282c 4283 xsijx=xs(isa,1)-xs(jsa,1) 4284 xskjx=xs(ksa,1)-xs(jsa,1) 4285 xsklx=xs(ksa,1)-xs(lsa,1) 4286 xsikx=xsijx-xskjx 4287 xsjlx=xsklx-xskjx 4288 xsijy=xs(isa,2)-xs(jsa,2) 4289 xskjy=xs(ksa,2)-xs(jsa,2) 4290 xskly=xs(ksa,2)-xs(lsa,2) 4291 xsiky=xsijy-xskjy 4292 xsjly=xskly-xskjy 4293 xsijz=xs(isa,3)-xs(jsa,3) 4294 xskjz=xs(ksa,3)-xs(jsa,3) 4295 xsklz=xs(ksa,3)-xs(lsa,3) 4296 xsikz=xsijz-xskjz 4297 xsjlz=xsklz-xskjz 4298c 4299c periodic boundary conditions 4300c 4301 if(lpbc.or.lpbcs) then 4302 dx(1)=xsijx 4303 dx(2)=xsijy 4304 dx(3)=xsijz 4305 call cf_pbc(1,dx,1,dx,1,0,1,1) 4306 xsijx=dx(1) 4307 xsijy=dx(2) 4308 xsijz=dx(3) 4309 dx(1)=xsikx 4310 dx(2)=xsiky 4311 dx(3)=xsikz 4312 call cf_pbc(1,dx,1,dx,1,0,1,1) 4313 xsikx=dx(1) 4314 xsiky=dx(2) 4315 xsikz=dx(3) 4316 dx(1)=xskjx 4317 dx(2)=xskjy 4318 dx(3)=xskjz 4319 call cf_pbc(1,dx,1,dx,1,0,1,1) 4320 xskjx=dx(1) 4321 xskjy=dx(2) 4322 xskjz=dx(3) 4323 dx(1)=xsklx 4324 dx(2)=xskly 4325 dx(3)=xsklz 4326 call cf_pbc(1,dx,1,dx,1,0,1,1) 4327 xsklx=dx(1) 4328 xskly=dx(2) 4329 xsklz=dx(3) 4330 dx(1)=xsjlx 4331 dx(2)=xsjly 4332 dx(3)=xsjlz 4333 call cf_pbc(1,dx,1,dx,1,0,1,1) 4334 xsjlx=dx(1) 4335 xsjly=dx(2) 4336 xsjlz=dx(3) 4337 endif 4338c 4339 xmx=xsijy*xskjz-xskjy*xsijz 4340 xmy=xsijz*xskjx-xskjz*xsijx 4341 xmz=xsijx*xskjy-xskjx*xsijy 4342 xnx=xskjy*xsklz-xskly*xskjz 4343 xny=xskjz*xsklx-xsklz*xskjx 4344 xnz=xskjx*xskly-xsklx*xskjy 4345 rm2i=one/(xmx*xmx+xmy*xmy+xmz*xmz) 4346 rn2i=one/(xnx*xnx+xny*xny+xnz*xnz) 4347 rmni=sqrt(rm2i*rn2i) 4348 cphi=(xmx*xnx+xmy*xny+xmz*xnz)*rmni 4349 if(cphi.lt.-one) cphi=-one 4350 if(cphi.gt. one) cphi= one 4351 phi=acos(cphi) 4352 s=xskjx*(xmy*xnz-xmz*xny) +xskjy*(xmz*xnx-xmx*xnz) 4353 + +xskjz*(xmx*xny-xmy*xnx) 4354 if(s.lt.zero) phi=-phi 4355 rimp(iso,1)=phi 4356 sphi=sin(phi) 4357 dang=(phi-ang)-nint((phi-ang)/twopi)*twopi 4358 dfor=for*dang 4359c uso(iso)=half*for*dang*dang 4360 rimp(iso,2)=half*for*dang*dang 4361 eterm=zero 4362 if(lupden) then 4363 ess(isf,isf,4,1)=ess(isf,isf,4,1)+fourth*factu*rimp(iso,2) 4364 ess(jsf,jsf,4,1)=ess(jsf,jsf,4,1)+fourth*factu*rimp(iso,2) 4365 ess(ksf,ksf,4,1)=ess(ksf,ksf,4,1)+fourth*factu*rimp(iso,2) 4366 ess(lsf,lsf,4,1)=ess(lsf,lsf,4,1)+fourth*factu*rimp(iso,2) 4367 endif 4368 eterm=factu*rimp(iso,2) 4369c 4370c for thermodynamic perturbations evaluate the energies 4371c using the 'perturbed' parameters of set 2 and/or set 3 4372c 4373 if(ip2(22)) then 4374 dangp=(phi-dimp(iso,2,2))-nint((phi-dimp(iso,2,2))/twopi)*twopi 4375 ep2(1)=ep2(1)-eterm+factu*half*dimp(iso,3,2)*dangp**2 4376 endif 4377 if(ip3(22)) then 4378 dangp=(phi-dimp(iso,2,3))-nint((phi-dimp(iso,2,3))/twopi)*twopi 4379 ep3(1)=ep3(1)-eterm+factu*half*dimp(iso,3,3)*dangp**2 4380 endif 4381c 4382c for normal angles use the cosine equation 4383c 4384 if(abs(sphi).gt.small) then 4385 sphii=one/sphi 4386 xdx=(-dfor)*sphii*(rmni*xnx-cphi*rm2i*xmx) 4387 xex=(-dfor)*sphii*(rmni*xmx-cphi*rn2i*xnx) 4388 xdy=(-dfor)*sphii*(rmni*xny-cphi*rm2i*xmy) 4389 xey=(-dfor)*sphii*(rmni*xmy-cphi*rn2i*xny) 4390 xdz=(-dfor)*sphii*(rmni*xnz-cphi*rm2i*xmz) 4391 xez=(-dfor)*sphii*(rmni*xmz-cphi*rn2i*xnz) 4392 dfsix=xskjy*xdz-xskjz*xdy 4393 dfsiy=xskjz*xdx-xskjx*xdz 4394 dfsiz=xskjx*xdy-xskjy*xdx 4395 dfsjx=xsiky*xdz-xsikz*xdy-xskly*xez+xsklz*xey 4396 dfsjy=xsikz*xdx-xsikx*xdz-xsklz*xex+xsklx*xez 4397 dfsjz=xsikx*xdy-xsiky*xdx-xsklx*xey+xskly*xex 4398 dfskx=xsjly*xez-xsjlz*xey-xsijy*xdz+xsijz*xdy 4399 dfsky=xsjlz*xex-xsjlx*xez-xsijz*xdx+xsijx*xdz 4400 dfskz=xsjlx*xey-xsjly*xex-xsijx*xdy+xsijy*xdx 4401 dfslx=xskjy*xez-xskjz*xey 4402 dfsly=xskjz*xex-xskjx*xez 4403 dfslz=xskjx*xey-xskjy*xex 4404 else 4405c 4406c for small angles use the sine equation 4407c 4408 cphii=one/cphi 4409 rkj=sqrt(xskjx*xskjx+xskjy*xskjy+xskjz*xskjz) 4410 xox=xskly*xsikz-xsklz*xsiky 4411 xoy=xsklz*xsikx-xsklx*xsikz 4412 xoz=xsklx*xsiky-xskly*xsikx 4413 rkjo=(xskjx*xox+xskjy*xoy+xskjz*xoz)/rkj 4414 xpx=xsijy*xsjlz-xsijz*xsjly 4415 xpy=xsijz*xsjlx-xsijx*xsjlz 4416 xpz=xsijx*xsjly-xsijy*xsjlx 4417 rkjp=(xskjx*xpx+xskjy*xpy+xskjz*xpz)/rkj 4418 dfsix=dfor*cphii* (rkj*rmni*xnx-sphi*rm2i*(xskjy*xmz-xskjz*xmy)) 4419 dfsiy=dfor*cphii* (rkj*rmni*xny-sphi*rm2i*(xskjz*xmx-xskjx*xmz)) 4420 dfsiz=dfor*cphii* (rkj*rmni*xnz-sphi*rm2i*(xskjx*xmy-xskjy*xmx)) 4421 dfsjx=dfor*cphii*((-rmni)*(rkjo*xskjx+rkj*xox)- 4422 + sphi*rm2i*(xsiky*xmz-xsikz*xmy)+ 4423 + sphi*rn2i*(xskly*xnz-xsklz*xny)) 4424 dfsjy=dfor*cphii*((-rmni)*(rkjo*xskjy+rkj*xoy)- 4425 + sphi*rm2i*(xsikz*xmx-xsikx*xmz)+ 4426 + sphi*rn2i*(xsklz*xnx-xsklx*xnz)) 4427 dfsjz=dfor*cphii*((-rmni)*(rkjo*xskjz+rkj*xoz)- 4428 + sphi*rm2i*(xsikx*xmy-xsiky*xmx)+ 4429 + sphi*rn2i*(xsklx*xny-xskly*xnx)) 4430 dfskx=dfor*cphii*((-rmni)*(rkjp*xskjx+rkj*xpx)- 4431 + sphi*rn2i*(xsjly*xnz-xsjlz*xny)+ 4432 + sphi*rm2i*(xsijy*xmz-xsijz*xmy)) 4433 dfsky=dfor*cphii*((-rmni)*(rkjp*xskjy+rkj*xpy)- 4434 + sphi*rn2i*(xsjlz*xnx-xsjlx*xnz)+ 4435 + sphi*rm2i*(xsijz*xmx-xsijx*xmz)) 4436 dfskz=dfor*cphii*((-rmni)*(rkjp*xskjz+rkj*xpz)- 4437 + sphi*rn2i*(xsjlx*xny-xsjly*xnx)+ 4438 + sphi*rm2i*(xsijx*xmy-xsijy*xmx)) 4439 dfslx=dfor*cphii* 4440 + ((-rkj)*rmni*xmx-sphi*rn2i*(xskjy*xnz-xskjz*xny)) 4441 dfsly=dfor*cphii* 4442 + ((-rkj)*rmni*xmy-sphi*rn2i*(xskjz*xnx-xskjx*xnz)) 4443 dfslz=dfor*cphii* 4444 + ((-rkj)*rmni*xmz-sphi*rn2i*(xskjx*xny-xskjy*xnx)) 4445 endif 4446c 4447c accumulate the forces 4448c 4449 fs(isa,1)=fs(isa,1)-dfsix 4450 fs(jsa,1)=fs(jsa,1)-dfsjx 4451 fs(ksa,1)=fs(ksa,1)-dfskx 4452 fs(lsa,1)=fs(lsa,1)-dfslx 4453 fs(isa,2)=fs(isa,2)-dfsiy 4454 fs(jsa,2)=fs(jsa,2)-dfsjy 4455 fs(ksa,2)=fs(ksa,2)-dfsky 4456 fs(lsa,2)=fs(lsa,2)-dfsly 4457 fs(isa,3)=fs(isa,3)-dfsiz 4458 fs(jsa,3)=fs(jsa,3)-dfsjz 4459 fs(ksa,3)=fs(ksa,3)-dfskz 4460 fs(lsa,3)=fs(lsa,3)-dfslz 4461c 4462 if(lupdti) then 4463c 4464c for thermodynamic integrations evaluate the derivative 4465c 4466 if(ith(22)) then 4467 dercon=dang*(half*dang*dimp(iso,3,4)-for*dimp(iso,2,4)) 4468 deriv(22,1)=deriv(22,1)+dercon 4469 if(npgdec.gt.1) then 4470 dera(5,iimp(iso,1))=dera(5,iimp(iso,1))+fourth*dercon 4471 dera(5,iimp(iso,2))=dera(5,iimp(iso,2))+fourth*dercon 4472 dera(5,iimp(iso,3))=dera(5,iimp(iso,3))+fourth*dercon 4473 dera(5,iimp(iso,4))=dera(5,iimp(iso,4))+fourth*dercon 4474 endif 4475 endif 4476 endif 4477c 4478 1 continue 4479c 4480 return 4481 end 4482 subroutine cf_fst(nthrds,indexl,mst,idtn,vdw,chg,natoms,ndim, 4483 + iatt,igan,isgm,imol,idyn,ichg,isss,xs,fs,ess,lpbc,lpbcs,dera, 4484 + esa,lseq) 4485c 4486c $Id$ 4487c 4488c cf_fst returns forces and energies for solute third neighbors 4489c 4490c ================================================================ 4491c 4492c description of arguments 4493c ------------------------ 4494c 4495c in: integer nthrds = number of third neighbor pairs to consider 4496c integer indexl = index list 4497c 4498c integer idst(mst) = global atom id i 4499c integer jdst(mst) = global atom id j 4500c 4501c real*8 cb6(matt,matt,3) 4502c real*8 cb12(matt,matt,3) 4503c 4504c real*8 cdso(mso,6) = dihedral angle force constants 4505c real*8 ddso(mso,6) = dihedral angle reference value 4506c real*8 rdso(mso) = dihedral angle value 4507c 4508c integer natoms = number of atoms in arrays 4509c integer ndim = leading dimension atom arrays 4510c integer igan(ndim) = global atom numbers 4511c integer imol(ndim) = atom molecule fraction 4512c integer idyn(ndim) = atom dynamics type 4513c real*8 qs(ndim,4) = atomic charges 4514c real*8 xs(ndim,3) = atom coordinates 4515c 4516c out: real*8 fs(ndim,3) = atom forces (ACCUMULATED) 4517c real*8 uso(mso) = dihedral angle energies 4518c 4519 implicit none 4520c 4521#include "cf_common.fh" 4522c 4523c declaration of arguments 4524c ------------------------ 4525c 4526 integer nthrds 4527 integer indexl(nthrds) 4528 integer isgm(msa),lseq(mseq) 4529c 4530 integer mst 4531 integer idtn(0:mst,2) 4532c integer idst(mst),jdst(mst) 4533c real*8 cb6(mat,mat,6),cb12(mat,mat,6) 4534c 4535 integer natoms,ndim 4536 real*8 vdw(mat,mat,map,mset),chg(mqt,mqp,mset) 4537 integer iatt(ndim),igan(ndim),imol(ndim),idyn(ndim),ichg(ndim) 4538 integer isss(msa) 4539 real*8 xs(ndim,3),fs(ndim,3) 4540 real*8 ess(msf,msf,mpe,2),esa(nsa) 4541c 4542#if defined(CAFE_FORCES) 4543 real*8 dera(6,nsatot) 4544#endif 4545c 4546 logical lpbc,lpbcs 4547c 4548c declaration of local variables 4549c ------------------------------ 4550c 4551 integer i,j,ist,isa,jsa,isf,jsf,isad,istt,jstt,isrx 4552 real*8 factu,etermq,eterml 4553 real*8 rxx,rxy,rxz,r2,r2i,r1i,dfs,dfsu,r6i,c6,c12,cf6,cf12,q 4554 real*8 ferfc,fderfc,qij,dfsp,c64,c124,dercon,qi,qi4,qj,qj4,q14 4555 real*8 dx(3) 4556c 4557c real*8 ang,dang,dangp,for,dfor,dfs,phi,cphi,cphii,sphi,sphii 4558c real*8 rmul,factu,dercon 4559c real*8 xsijx,xskjx,xsijy,xskjy,xsijz,xskjz 4560c real*8 xsklx,xsjlx,xskly,xsjly,xsklz,xsjlz 4561c real*8 xsikx,xsiky,xsikz,xmx,xmy,xmz,xnx,xny,xnz,xdx,xdy,xdz 4562c real*8 xex,xey,xez,xox,xoy,xoz,xpx,xpy,xpz 4563c real*8 dfsix,dfsiy,dfsiz,dfsjx,dfsjy,dfsjz 4564c real*8 dfskx,dfsky,dfskz,dfslx,dfsly,dfslz 4565c real*8 rm2i,rn2i,rmni,s,rpa 4566c real*8 rsij2,rskj2,rsij2i,rskj2i,rsikji,rkj,rkjo,rkjp 4567c real*8 qij,xs1,xs2,xs3,rss,rsi,ferfc,fderfc,dfs1,dfs2,dfs3 4568c 4569#include "cf_funcs_dec.fh" 4570#include "bitops_decls.fh" 4571#include "cf_funcs_sfn.fh" 4572#include "bitops_funcs.fh" 4573c 4574 isad=0 4575 dfsp=zero 4576 etermq=zero 4577c 4578 do 1 i=1,nthrds 4579c 4580c find index into third neighbor list 4581c 4582 ist=indexl(i) 4583c 4584 3 continue 4585 if(ist.gt.idtn(isad,1)) then 4586 isad=isad+1 4587 goto 3 4588 endif 4589c 4590c find local atoms involved 4591c 4592 isa=0 4593 jsa=0 4594 do 2 j=1,natoms 4595 if(isad.eq.igan(j)) isa=j 4596 if(idtn(ist,2).eq.igan(j)) jsa=j 4597 2 continue 4598c 4599c find solute molecule numbers involved 4600c 4601 isf=imol(isa) 4602 jsf=imol(jsa) 4603c 4604 if(lssscl) then 4605c 4606 istt=iand(isss(isa),48) 4607 jstt=iand(isss(jsa),48) 4608 if(isf.ne.jsf) then 4609 if(istt.eq.16.or.jstt.eq.16) isrx=-1 4610 if(istt.eq.32.or.jstt.eq.32) isrx=1 4611 endif 4612c 4613 istt=iand(isss(isa),384) 4614 jstt=iand(isss(jsa),384) 4615 if(istt.eq.128.or.jstt.eq.128) isrx=-2 4616 if(istt.eq.256.or.jstt.eq.256) isrx=2 4617c 4618 istt=iand(isss(isa),384) 4619 jstt=iand(isss(jsa),384) 4620 if(istt.eq.128.and.jstt.eq.256) isrx=999 4621 if(istt.eq.256.and.jstt.eq.128) isrx=999 4622c 4623c write(*,'(5i5)') 4624c + isga(isfr+isa),isga(lssptr),istt,jstt,isrx(nax+jnum) 4625c 4626 endif 4627c 4628c determine energy factor depending on atoms being dynamic 4629c or fixed 4630c 4631 factu=zero 4632 if(iand(idyn(isa),mdynam).eq.ldynam.or. 4633 + iand(idyn(jsa),mdynam).eq.ldynam) factu=one 4634c if((iand(idyn(isa),mdynam).eq.ldynam.and. 4635c + iand(idyn(jsa),mdynam).ne.ldynam) .or. 4636c + (iand(idyn(isa),mdynam).ne.ldynam.and. 4637c + iand(idyn(jsa),mdynam).eq.ldynam) ) factu=half 4638 if(includ.eq.1) factu=one 4639c 4640c evaluate the distance 4641c 4642 rxx=xs(isa,1)-xs(jsa,1) 4643 rxy=xs(isa,2)-xs(jsa,2) 4644 rxz=xs(isa,3)-xs(jsa,3) 4645c 4646c periodic boundary conditions 4647c 4648 if(lpbc.or.lpbcs) then 4649 dx(1)=rxx 4650 dx(2)=rxy 4651 dx(3)=rxz 4652 call cf_pbc(1,dx,1,dx,1,0,1,1) 4653 rxx=dx(1) 4654 rxy=dx(2) 4655 rxz=dx(3) 4656 endif 4657c 4658 r2=rxx*rxx+rxy*rxy+rxz*rxz 4659 r2i=one/r2 4660c 4661 if(lssscl) then 4662 if(isrx.eq.999) then 4663 r2i=zero 4664 isrx=0 4665 endif 4666 if(isrx.gt.0) then 4667 r2i=one/(one/r2i+shift0(1)) 4668 elseif(isrx.lt.0) then 4669 r2i=one/(one/r2i+shift1(1)) 4670 endif 4671 endif 4672c 4673 r1i=sqrt(r2i) 4674 dfs=zero 4675 dfsu=zero 4676 r6i=r2i*r2i*r2i 4677c 4678c get force constants 4679c 4680c c6=cb6(iatt(isa),iatt(jsa),iset) 4681c c12=cb12(iatt(isa),iatt(jsa),iset) 4682 if(nfhop.eq.0) then 4683 c6=vdw(iatt(isa),iatt(jsa),2,iset) 4684 c12=vdw(iatt(isa),iatt(jsa),4,iset) 4685 else 4686 c6=vdw(iatt(isa),iatt(jsa),2,lseq(isgm(jsa))) 4687 c12=vdw(iatt(isa),iatt(jsa),4,lseq(isgm(jsa))) 4688 endif 4689 cf6=six*c6 4690 cf12=twelve*c12 4691c 4692c calculate the Lennard-Jones force contribution 4693c 4694 dfs=(cf12*r6i-cf6)*r6i*r2i 4695 dfsu=(c12*r6i-c6)*r6i 4696c 4697c calculate the Lennard-Jones energies 4698c 4699 eterml=factu*dfsu 4700 ess(isf,jsf,7,1)=ess(isf,jsf,7,1)+eterml 4701 if(ipme.eq.0.or.isolvo.ne.0) then 4702c 4703c calculate the electrostatic energies 4704c 4705c q=q14fac*qs(isa,iset)*qs(jsa,iset) 4706 if(nfhop.eq.0) then 4707 q=q14fac*chg(ichg(isa),1,iset)*chg(ichg(jsa),1,iset) 4708 else 4709 q=q14fac*chg(ichg(isa),1,lseq(isgm(isa)))* 4710 + chg(ichg(jsa),1,lseq(isgm(jsa))) 4711 endif 4712 etermq=factu*q*r1i 4713 ess(isf,jsf,8,1)=ess(isf,jsf,8,1)+etermq 4714 if(npener.gt.0) then 4715 esa(igan(isa))=esa(igan(isa))+half*(eterml+etermq) 4716 esa(igan(jsa))=esa(igan(jsa))+half*(eterml+etermq) 4717 endif 4718c 4719c calculate the electrostatic force contribution 4720c 4721 dfs=dfs+q*r1i*r2i 4722 else 4723 ferfc=erfc(ealpha/r1i) 4724 fderfc=ealpha*derfc(ealpha/r1i) 4725c 4726c calculate the electrostatic energies 4727c 4728 if(nfhop.eq.0) then 4729 q=q14fac*chg(ichg(isa),1,iset)*chg(ichg(jsa),1,iset) 4730 else 4731 q=q14fac*chg(ichg(isa),1,lseq(isgm(isa)))* 4732 + chg(ichg(jsa),1,lseq(isgm(jsa))) 4733 endif 4734 qij=(one-q14fac)*q 4735 epmecs=epmecs-(one-ferfc)*qij*r1i*factu 4736 ess(isf,isf,8,1)=ess(isf,isf,8,1)-half*(one-ferfc)*q*r1i*factu 4737 ess(isf,jsf,8,1)=ess(jsf,jsf,8,1)-half*(one-ferfc)*q*r1i*factu 4738 etermq=ferfc*factu*q*r1i 4739 if(npener.gt.0) then 4740 esa(igan(isa))=esa(igan(isa))+half*(one-ferfc)*q*r1i*factu 4741 esa(igan(jsa))=esa(igan(jsa))+half*(one-ferfc)*q*r1i*factu 4742 endif 4743c 4744c calculate the electrostatic force contribution 4745c 4746 dfsp=-(qij*r2i*((one-ferfc)*r1i+fderfc)) 4747 dfs=dfs+q*r2i*(ferfc*r1i-fderfc)-dfsp 4748 endif 4749c 4750c reaction field contributions 4751c 4752 if(ireact.ne.0) then 4753 ess(isf,jsf,8,1)=ess(isf,jsf,8,1)+factu*q*rffss/r2i 4754 if(npener.gt.0) then 4755 esa(igan(isa))=esa(igan(isa))+half*factu*q*rffss/r2i 4756 esa(igan(jsa))=esa(igan(jsa))+half*factu*q*rffss/r2i 4757 endif 4758 dfs=dfs-two*q*rffss 4759 endif 4760c 4761c accumulate the forces 4762c 4763 fs(isa,1)=fs(isa,1)+dfs*rxx 4764 fs(jsa,1)=fs(jsa,1)-dfs*rxx 4765 fs(isa,2)=fs(isa,2)+dfs*rxy 4766 fs(jsa,2)=fs(jsa,2)-dfs*rxy 4767 fs(isa,3)=fs(isa,3)+dfs*rxz 4768 fs(jsa,3)=fs(jsa,3)-dfs*rxz 4769c 4770 if(ipme.ne.0) then 4771 vpmeb(1)=vpmeb(1)+dfsp*rxx*rxx 4772 vpmeb(2)=vpmeb(2)+dfsp*rxy*rxx 4773 vpmeb(3)=vpmeb(3)+dfsp*rxz*rxx 4774 vpmeb(4)=vpmeb(4)+dfsp*rxy*rxy 4775 vpmeb(5)=vpmeb(5)+dfsp*rxz*rxy 4776 vpmeb(6)=vpmeb(6)+dfsp*rxz*rxz 4777 endif 4778c 4779c for thermodynamic integration evaluate the derivatives 4780c 4781 if(ithint) then 4782 if(ith(14)) then 4783c c64=cb6(iatt(isa),iatt(jsa),4) 4784c c124=cb12(iatt(isa),iatt(jsa),4) 4785 c64=vdw(iatt(isa),iatt(jsa),2,4) 4786 c124=vdw(iatt(isa),iatt(jsa),4,4) 4787 dercon=(c124*r6i-c64)*r6i 4788 if(isrx.gt.0) then 4789 c64=three*vdw(iatt(isa),iatt(jsa),1,iset) 4790 c124=six*vdw(iatt(isa),iatt(jsa),3,iset) 4791 dercon=dercon+shift0(4)*r2i*r6i*(c64-c124*r6i) 4792 elseif(isrx.lt.0) then 4793 c64=three*vdw(iatt(isa),iatt(jsa),1,iset) 4794 c124=six*vdw(iatt(isa),iatt(jsa),3,iset) 4795 dercon=dercon+shift1(4)*r2i*r6i*(c64-c124*r6i) 4796 endif 4797 deriv(15,1)=deriv(15,1)+dercon 4798#if defined(CAFE_FORCES) 4799 if(npgdec.gt.1) then 4800 dera(3,igan(isa))=dera(3,igan(isa))+half*dercon 4801 dera(3,igan(jsa))=dera(3,igan(jsa))+half*dercon 4802 endif 4803#endif 4804 endif 4805 if(ith(16)) then 4806c qi=qs(isa,iset) 4807c qi4=qs(isa,4) 4808c qj=qs(jsa,iset) 4809c qj4=qs(jsa,4) 4810 qi=chg(ichg(isa),1,iset) 4811 qi4=chg(ichg(isa),1,4) 4812 qj=chg(ichg(jsa),1,iset) 4813 qj4=chg(ichg(jsa),1,4) 4814 if(ipme.eq.0) then 4815 dercon=q14fac*(qi*qj4+qj*qi4)*r1i 4816 else 4817 dercon=q14fac*(qi*qj4+qj*qi4)*r1i 4818 endif 4819 if(isrx.gt.1) then 4820 dercon=dercon-half*shift0(4)* 4821 + chg(ichg(isa),1,iset)*chg(ichg(jsa),1,iset)*r2i 4822 elseif(isrx.lt.-1) then 4823 dercon=dercon-half*shift1(4)* 4824 + chg(ichg(isa),1,iset)*chg(ichg(jsa),1,iset)*r2i 4825 endif 4826 deriv(17,1)=deriv(17,1)+dercon 4827 if(ireact.ne.0) then 4828 deriv(17,1)=deriv(17,1)+q14fac*(qi*qj4+qj*qi4)*rffss/r2i 4829 endif 4830#if defined(CAFE_FORCES) 4831 if(npgdec.gt.1) then 4832 dera(4,igan(isa))=dera(4,igan(isa))+half*dercon 4833 dera(4,igan(jsa))=dera(4,igan(jsa))+half*dercon 4834 endif 4835#endif 4836 endif 4837 endif 4838c 4839c thermodynamic perturbation 1 4840c 4841 if(ipert2) then 4842 if(ip2(14)) then 4843 ep2(1)=ep2(1)-eterml+factu* 4844 + (vdw(iatt(isa),iatt(jsa),4,2)*r6i- 4845 + vdw(iatt(isa),iatt(jsa),2,2))*r6i 4846 endif 4847 if(ip2(16).or.ip2(17)) then 4848 rxx=xs(isa,1)-xs(jsa,1) 4849 rxy=xs(isa,2)-xs(jsa,2) 4850 rxz=xs(isa,3)-xs(jsa,3) 4851 r2=rxx*rxx+rxy*rxy+rxz*rxz 4852 r2i=one/r2 4853 r1i=sqrt(r2i) 4854 if(ipme.eq.0) then 4855 q14=chg(ichg(isa),1,2)*chg(ichg(jsa),1,2)*q14fac 4856c q14=qs(isa,2)*qs(jsa,2)*q14fac 4857 else 4858 q14=chg(ichg(isa),1,2)*chg(ichg(jsa),1,2)*q14fac*erfc(ealpha/r1i) 4859c q14=qs(isa,2)*qs(jsa,2)*q14fac*erfc(ealpha/r1i) 4860 endif 4861 ep2(1)=ep2(1)-etermq+factu*q14*r1i 4862 if(ireact.ne.0) then 4863 ep2(1)=ep2(1)-etermq+factu*q14*rffss/r2i 4864 endif 4865 endif 4866 endif 4867c 4868c thermodynamic perturbation 2 4869c 4870 if(ipert3) then 4871 if(ip3(14)) then 4872 ep3(1)=ep3(1)-eterml+factu* 4873 + (vdw(iatt(isa),iatt(jsa),4,3)*r6i- 4874 + vdw(iatt(isa),iatt(jsa),2,3))*r6i 4875 endif 4876 if(ip2(16).or.ip2(17)) then 4877 rxx=xs(isa,1)-xs(jsa,1) 4878 rxy=xs(isa,2)-xs(jsa,2) 4879 rxz=xs(isa,3)-xs(jsa,3) 4880 r2=rxx*rxx+rxy*rxy+rxz*rxz 4881 r2i=one/r2 4882 r1i=sqrt(r2i) 4883 if(ipme.eq.0) then 4884 q14=chg(ichg(isa),1,3)*chg(ichg(jsa),1,3)*q14fac 4885 else 4886 q14=chg(ichg(isa),1,3)*chg(ichg(jsa),1,3)*q14fac*erfc(ealpha/r1i) 4887 endif 4888 ep3(1)=ep3(1)-etermq+factu*q14*r1i 4889 if(ireact.ne.0) then 4890 ep3(1)=ep3(1)-etermq+factu*q14*rffss/r2i 4891 endif 4892 endif 4893 endif 4894 1 continue 4895c 4896 return 4897 end 4898 subroutine cf_fw(iwfr,iwto,xw,fw,iwdt,iwatm,iwq,lpbc,eww,vdw,chg, 4899 + mwb,nwb,nbp,ibnd,bnd,rbnd,mwh,nwh,nhp,iang,ang,rang,rub, 4900 + mwd,nwd,ndp,idih,dih,rdih,mwo,nwo,nop,iimp,dimp,rimp, 4901 + mwt,nwt,idwt,mwn,nwn,idwn) 4902c 4903c $Id$ 4904c 4905 implicit none 4906c 4907#include "cf_common.fh" 4908c 4909 integer iwfr,iwto 4910 integer mwb,mwh,mwd,mwo,nbp,nhp,ndp,nop,mwt,mwn 4911 integer nwb,nwh,nwd,nwo,nwt,nwn 4912 real*8 xw(mwm,3,mwa),fw(mwm,3,mwa,2) 4913 integer iwdt(mwm),iwq(mwa),iwatm(mwa) 4914 logical lpbc 4915 real*8 vdw(mat,mat,map,mset),chg(mqt,mqp,mset) 4916 integer ibnd(mwb,3),iang(mwh,4),idih(mwd,5),iimp(mwo,5) 4917 real*8 bnd(mwb,nbp,mset),ang(mwh,nhp,mset) 4918 real*8 dih(mwd,ndp,mset),dimp(mwo,nop,mset) 4919 real*8 rbnd(mwb,2),rang(mwh,2),rub(mwh,2),rdih(mwd,2),rimp(mwo,2) 4920c 4921c real*8 ca6(mat,mat,6),ca12(mat,mat,6) 4922c real*8 cb6(mat,mat,6),cb12(mat,mat,6) 4923c integer iwl(mwm,miw2), 4924c 4925 integer idwt(0:mwt,2),idwn(0:mwn,2) 4926c 4927c real*8 cdwb(mwb,6),ddwb(mwb,6) 4928c integer iwbs(mwb),idwb(mwb),jdwb(mwb),iwatm(mwa) 4929c real*8 cdwh(mwh,6),ddwh(mwh,6) 4930c integer idwh(mwh),jdwh(mwh),kdwh(mwh) 4931c real*8 cdwd(mwd,6),ddwd(mwd,6),edwd(mwd,6) 4932c integer idwd(mwd),jdwd(mwd),kdwd(mwd),ldwd(mwd) 4933c real*8 cdwo(mwo,6),ddwo(mwo,6) 4934c integer idwo(mwo),jdwo(mwo),kdwo(mwo),ldwo(mwo) 4935c real*8 uwb(mwb),uwh(mwh),uwd(mwd),uwo(mwo) 4936c 4937 integer iwb,iwa,jwa,iwm,iwh,kwa,iwd,lwa,iwo,iwt,iwn 4938 real*8 bond,for,rwx1,rwx2,rwx3,rww,rwwi,dbond,dfor,dfw1,dfw2,dfw3 4939 real*8 angle,xwij1,xwij2,xwij3,xwkj1,xwkj2,xwkj3,rwij2,rwij2i 4940 real*8 rwkj2,rwkj2i,cphi,phi,dangle,sphi,rmul 4941 real*8 xwkl1,xwkl2,xwkl3,xwik1,xwik2,xwik3,xwjl1,xwjl2,xwjl3 4942 real*8 xm1,xm2,xm3,xn1,xn2,xn3,rm2i,rn2i,rmni,s,rpa 4943 real*8 xd1,xd2,xd3,xe1,xe2,xe3,dfwi1,dfwi2,dfwi3 4944 real*8 dfwj1,dfwj2,dfwj3,dfwk1,dfwk2,dfwk3,dfwl1,dfwl2,dfwl3 4945 real*8 danglep,c6p1,c12p1,c6p2,c12p2,qip1,qjp1,qip2,qjp2 4946 real*8 c6,c12,c6t,c12t,qit,qjt,cf6,cf12,qi,qj,q,qp1,qp2 4947 real*8 ep2l,ep3l,ep2q,ep3q,rxx,rxy,rxz,r2,r2i,r1i,r6i,dfw 4948 real*8 rwikji,sphii,qij,rwi,ferfc,fderfc,eww(mpe,2) 4949 real*8 etermq,eterml,eub 4950c 4951#include "cf_funcs_dec.fh" 4952#include "bitops_decls.fh" 4953#include "cf_funcs_sfn.fh" 4954#include "bitops_funcs.fh" 4955c 4956 c6t=zero 4957 c12t=zero 4958 qit=zero 4959 qjt=zero 4960 qp1=zero 4961 qp2=zero 4962c 4963 do 10 iwb=1,nwb 4964 if(iand(ibnd(iwb,3),icnstr).eq.0) then 4965 iwa=ibnd(iwb,1) 4966 jwa=ibnd(iwb,2) 4967 bond=bnd(iwb,1,iset) 4968 for=bnd(iwb,2,iset) 4969 rbnd(iwb,2)=zero 4970 do 20 iwm=iwfr,iwto 4971 rwx1=xw(iwm,1,iwa)-xw(iwm,1,jwa) 4972 rwx2=xw(iwm,2,iwa)-xw(iwm,2,jwa) 4973 rwx3=xw(iwm,3,iwa)-xw(iwm,3,jwa) 4974 rww=sqrt(rwx1**2+rwx2**2+rwx3**2) 4975 if(rww.lt.tiny) then 4976 rwwi=one 4977 else 4978 rwwi=one/rww 4979 endif 4980 dbond=rww-bond 4981 if(iand(iwdt(iwm),mdynam).eq.ldynam) 4982 + rbnd(iwb,2)=rbnd(iwb,2)+half*for*(rww-bond)**2 4983 dfor=for*dbond*rwwi 4984 dfw1=dfor*rwx1 4985 dfw2=dfor*rwx2 4986 dfw3=dfor*rwx3 4987 fw(iwm,1,iwa,1)=fw(iwm,1,iwa,1)-dfw1 4988 fw(iwm,1,jwa,1)=fw(iwm,1,jwa,1)+dfw1 4989 fw(iwm,2,iwa,1)=fw(iwm,2,iwa,1)-dfw2 4990 fw(iwm,2,jwa,1)=fw(iwm,2,jwa,1)+dfw2 4991 fw(iwm,3,iwa,1)=fw(iwm,3,iwa,1)-dfw3 4992 fw(iwm,3,jwa,1)=fw(iwm,3,jwa,1)+dfw3 4993 if(ip2(6)) 4994 + ep2(1)=ep2(1)+half*bnd(iwb,2,2)*(rww-bnd(iwb,1,2))**2 4995 if(ip3(6)) 4996 + ep3(1)=ep3(1)+half*bnd(iwb,2,3)*(rww-bnd(iwb,1,3))**2 4997 if(ith(6)) then 4998 deriv(6,1)=deriv(6,1)+ 4999 + dbond*(half*dbond*bnd(iwb,2,4)-for*bnd(iwb,1,4)) 5000 endif 5001 20 continue 5002 eww(1,1)=eww(1,1)+rbnd(iwb,2) 5003 if(ip2(6)) ep2(1)=ep2(1)-rbnd(iwb,2) 5004 if(ip3(6)) ep3(1)=ep3(1)-rbnd(iwb,2) 5005 endif 5006 if(ipme.ne.0) then 5007 iwa=ibnd(iwb,1) 5008 jwa=ibnd(iwb,2) 5009 qij=chg(iwq(iwa),1,iset)*chg(iwq(jwa),1,iset) 5010 do 21 iwm=iwfr,iwto 5011 rwx1=xw(iwm,1,iwa)-xw(iwm,1,jwa) 5012 rwx2=xw(iwm,2,iwa)-xw(iwm,2,jwa) 5013 rwx3=xw(iwm,3,iwa)-xw(iwm,3,jwa) 5014 rww=sqrt(rwx1**2+rwx2**2+rwx3**2) 5015 rwi=one/rww 5016 ferfc=one-erfc(ealpha*rww) 5017 fderfc=-(ealpha*derfc(ealpha*rww)) 5018 epmecw=epmecw-ferfc*qij*rwi 5019 eww(9,1)=eww(9,1)-ferfc*qij*rwi 5020 dfor=-(qij*rwi*rwi*(ferfc*rwi-fderfc)) 5021 dfw1=dfor*rwx1 5022 dfw2=dfor*rwx2 5023 dfw3=dfor*rwx3 5024 fw(iwm,1,iwa,1)=fw(iwm,1,iwa,1)-dfw1 5025 fw(iwm,1,jwa,1)=fw(iwm,1,jwa,1)+dfw1 5026 fw(iwm,2,iwa,1)=fw(iwm,2,iwa,1)-dfw2 5027 fw(iwm,2,jwa,1)=fw(iwm,2,jwa,1)+dfw2 5028 fw(iwm,3,iwa,1)=fw(iwm,3,iwa,1)-dfw3 5029 fw(iwm,3,jwa,1)=fw(iwm,3,jwa,1)+dfw3 5030 vpmeb(1)=vpmeb(1)+dfw1*rwx1 5031 vpmeb(2)=vpmeb(2)+dfw2*rwx1 5032 vpmeb(3)=vpmeb(3)+dfw3*rwx1 5033 vpmeb(4)=vpmeb(4)+dfw2*rwx2 5034 vpmeb(5)=vpmeb(5)+dfw3*rwx2 5035 vpmeb(6)=vpmeb(6)+dfw3*rwx3 5036 21 continue 5037 endif 5038 10 continue 5039 do 40 iwh=1,nwh 5040 iwa=iang(iwh,1) 5041 jwa=iang(iwh,2) 5042 kwa=iang(iwh,3) 5043 angle=ang(iwh,1,iset) 5044 for=ang(iwh,2,iset) 5045 rang(iwh,2)=zero 5046 do 50 iwm=iwfr,iwto 5047 xwij1=xw(iwm,1,iwa)-xw(iwm,1,jwa) 5048 xwij2=xw(iwm,2,iwa)-xw(iwm,2,jwa) 5049 xwij3=xw(iwm,3,iwa)-xw(iwm,3,jwa) 5050 xwkj1=xw(iwm,1,kwa)-xw(iwm,1,jwa) 5051 xwkj2=xw(iwm,2,kwa)-xw(iwm,2,jwa) 5052 xwkj3=xw(iwm,3,kwa)-xw(iwm,3,jwa) 5053 rwij2=xwij1**2+xwij2**2+xwij3**2 5054 rwkj2=xwkj1**2+xwkj2**2+xwkj3**2 5055 rwij2i=one/rwij2 5056 rwkj2i=one/rwkj2 5057 rwikji=one/sqrt(rwij2*rwkj2) 5058 cphi=rwikji*(xwij1*xwkj1+xwij2*xwkj2+xwij3*xwkj3) 5059 if(cphi.lt.-one) cphi=-one 5060 if(cphi.gt. one) cphi= one 5061 phi=acos(cphi) 5062 dangle=phi-angle 5063 if(iand(iwdt(iwm),mdynam).eq.ldynam) 5064 + rang(iwh,2)=rang(iwh,2)+half*for*dangle*dangle 5065 sphi=sin(phi) 5066 if(abs(sphi).lt.small) sphi=small 5067 dfor=for*dangle/sphi 5068 dfw1=dfor*(xwkj1*rwikji-xwij1*rwij2i*cphi) 5069 dfw2=dfor*(xwkj2*rwikji-xwij2*rwij2i*cphi) 5070 dfw3=dfor*(xwkj3*rwikji-xwij3*rwij2i*cphi) 5071 fw(iwm,1,iwa,1)=fw(iwm,1,iwa,1)+dfw1 5072 fw(iwm,1,jwa,1)=fw(iwm,1,jwa,1)-dfw1 5073 fw(iwm,2,iwa,1)=fw(iwm,2,iwa,1)+dfw2 5074 fw(iwm,2,jwa,1)=fw(iwm,2,jwa,1)-dfw2 5075 fw(iwm,3,iwa,1)=fw(iwm,3,iwa,1)+dfw3 5076 fw(iwm,3,jwa,1)=fw(iwm,3,jwa,1)-dfw3 5077 dfw1=dfor*(xwij1*rwikji-xwkj1*rwkj2i*cphi) 5078 dfw2=dfor*(xwij2*rwikji-xwkj2*rwkj2i*cphi) 5079 dfw3=dfor*(xwij3*rwikji-xwkj3*rwkj2i*cphi) 5080 fw(iwm,1,kwa,1)=fw(iwm,1,kwa,1)+dfw1 5081 fw(iwm,1,jwa,1)=fw(iwm,1,jwa,1)-dfw1 5082 fw(iwm,2,kwa,1)=fw(iwm,2,kwa,1)+dfw2 5083 fw(iwm,2,jwa,1)=fw(iwm,2,jwa,1)-dfw2 5084 fw(iwm,3,kwa,1)=fw(iwm,3,kwa,1)+dfw3 5085 fw(iwm,3,jwa,1)=fw(iwm,3,jwa,1)-dfw3 5086 if(ip2(8)) 5087 + ep2(1)=ep2(1)+half*ang(iwh,2,2)*(phi-ang(iwh,1,2))**2 5088 if(ip3(8)) 5089 + ep3(1)=ep3(1)+half*ang(iwh,2,3)*(phi-ang(iwh,1,3))**2 5090 if(ith(8)) then 5091 deriv(8,1)=deriv(8,1)+ 5092 + dangle*(half*dangle*ang(iwh,2,4)-for*ang(iwh,1,4)) 5093 endif 5094 50 continue 5095 eww(2,1)=eww(2,1)+rang(iwh,2) 5096 if(ip2(8)) ep2(1)=ep2(1)-rang(iwh,2) 5097 if(ip3(8)) ep3(1)=ep3(1)-rang(iwh,2) 5098 if(ipme.ne.0) then 5099 iwa=iang(iwh,1) 5100 jwa=iang(iwh,3) 5101 qij=chg(iwq(iwa),1,iset)*chg(iwq(jwa),1,iset) 5102 do 41 iwm=iwfr,iwto 5103 rwx1=xw(iwm,1,iwa)-xw(iwm,1,jwa) 5104 rwx2=xw(iwm,2,iwa)-xw(iwm,2,jwa) 5105 rwx3=xw(iwm,3,iwa)-xw(iwm,3,jwa) 5106 rww=sqrt(rwx1**2+rwx2**2+rwx3**2) 5107 rwi=one/rww 5108 ferfc=one-erfc(ealpha*rww) 5109 fderfc=-(ealpha*derfc(ealpha*rww)) 5110 epmecw=epmecw-ferfc*qij*rwi 5111 eww(9,1)=eww(9,1)-ferfc*qij*rwi 5112 dfor=-(qij*rwi*rwi*(ferfc*rwi-fderfc)) 5113 dfw1=dfor*rwx1 5114 dfw2=dfor*rwx2 5115 dfw3=dfor*rwx3 5116 fw(iwm,1,iwa,1)=fw(iwm,1,iwa,1)-dfw1 5117 fw(iwm,1,jwa,1)=fw(iwm,1,jwa,1)+dfw1 5118 fw(iwm,2,iwa,1)=fw(iwm,2,iwa,1)-dfw2 5119 fw(iwm,2,jwa,1)=fw(iwm,2,jwa,1)+dfw2 5120 fw(iwm,3,iwa,1)=fw(iwm,3,iwa,1)-dfw3 5121 fw(iwm,3,jwa,1)=fw(iwm,3,jwa,1)+dfw3 5122 vpmeb(1)=vpmeb(1)+dfw1*rwx1 5123 vpmeb(2)=vpmeb(2)+dfw2*rwx1 5124 vpmeb(3)=vpmeb(3)+dfw3*rwx1 5125 vpmeb(4)=vpmeb(4)+dfw2*rwx2 5126 vpmeb(5)=vpmeb(5)+dfw3*rwx2 5127 vpmeb(6)=vpmeb(6)+dfw3*rwx3 5128 41 continue 5129 endif 5130 40 continue 5131 if(iffld.eq.2) then 5132 do 1140 iwh=1,nwh 5133 iwa=iang(iwh,1) 5134 kwa=iang(iwh,3) 5135 bond=ang(iwb,3,iset) 5136 for=ang(iwb,4,iset) 5137 eub=zero 5138 do 150 iwm=iwfr,iwto 5139 rwx1=xw(iwm,1,iwa)-xw(iwm,1,kwa) 5140 rwx2=xw(iwm,2,iwa)-xw(iwm,2,kwa) 5141 rwx3=xw(iwm,3,iwa)-xw(iwm,3,kwa) 5142 rww=sqrt(rwx1**2+rwx2**2+rwx3**2) 5143 if(rww.lt.tiny) then 5144 rwwi=one 5145 else 5146 rwwi=one/rww 5147 endif 5148 dbond=rww-bond 5149 if(iand(iwdt(iwm),mdynam).eq.ldynam) 5150 + eub=eub+half*for*(rww-bond)**2 5151 dfor=for*dbond*rwwi 5152 dfw1=dfor*rwx1 5153 dfw2=dfor*rwx2 5154 dfw3=dfor*rwx3 5155 fw(iwm,1,iwa,1)=fw(iwm,1,iwa,1)-dfw1 5156 fw(iwm,1,kwa,1)=fw(iwm,1,kwa,1)+dfw1 5157 fw(iwm,2,iwa,1)=fw(iwm,2,iwa,1)-dfw2 5158 fw(iwm,2,kwa,1)=fw(iwm,2,kwa,1)+dfw2 5159 fw(iwm,3,iwa,1)=fw(iwm,3,iwa,1)-dfw3 5160 fw(iwm,3,kwa,1)=fw(iwm,3,kwa,1)+dfw3 5161 if(ip2(8)) 5162 + ep2(1)=ep2(1)+half*ang(iwh,4,2)*(rww-ang(iwh,3,2))**2 5163 if(ip3(8)) 5164 + ep3(1)=ep3(1)+half*ang(iwh,4,3)*(rww-ang(iwh,3,3))**2 5165 if(ith(8)) then 5166 deriv(8,1)=deriv(8,1)+ 5167 + dbond*(half*dbond*ang(iwh,4,4)-for*ang(iwh,3,4)) 5168 endif 5169 150 continue 5170 rub(iwh,2)=rub(iwh,2)+eub 5171 eww(13,1)=eww(13,1)+eub 5172 if(ip2(8)) ep2(1)=ep2(1)-eub 5173 if(ip3(8)) ep3(1)=ep3(1)-eub 5174 1140 continue 5175 endif 5176 do 70 iwd=1,nwd 5177 iwa=idih(iwd,1) 5178 jwa=idih(iwd,2) 5179 kwa=idih(iwd,3) 5180 lwa=idih(iwd,4) 5181 angle=dih(iwd,2,iset) 5182 for=dih(iwd,3,iset) 5183 rmul=dih(iwd,1,iset) 5184 rdih(iwd,2)=zero 5185 do 80 iwm=iwfr,iwto 5186 xwij1=xw(iwm,1,iwa)-xw(iwm,1,jwa) 5187 xwij2=xw(iwm,2,iwa)-xw(iwm,2,jwa) 5188 xwij3=xw(iwm,3,iwa)-xw(iwm,3,jwa) 5189 xwkj1=xw(iwm,1,kwa)-xw(iwm,1,jwa) 5190 xwkj2=xw(iwm,2,kwa)-xw(iwm,2,jwa) 5191 xwkj3=xw(iwm,3,kwa)-xw(iwm,3,jwa) 5192 xwkl1=xw(iwm,1,kwa)-xw(iwm,1,lwa) 5193 xwkl2=xw(iwm,2,kwa)-xw(iwm,2,lwa) 5194 xwkl3=xw(iwm,3,kwa)-xw(iwm,3,lwa) 5195 xwik1=xwij1-xwkj1 5196 xwik2=xwij2-xwkj2 5197 xwik3=xwij3-xwkj3 5198 xwjl1=xwkl1-xwkj1 5199 xwjl2=xwkl2-xwkj2 5200 xwjl3=xwkl3-xwkj3 5201 xm1=xwij2*xwkj3-xwkj2*xwij3 5202 xm2=xwij3*xwkj1-xwkj3*xwij1 5203 xm3=xwij1*xwkj2-xwkj1*xwij2 5204 xn1=xwkj2*xwkl3-xwkl2*xwkj3 5205 xn2=xwkj3*xwkl1-xwkl3*xwkj1 5206 xn3=xwkj1*xwkl2-xwkl1*xwkj2 5207 rm2i=one/(xm1**2+xm2**2+xm3**2) 5208 rn2i=one/(xn1**2+xn2**2+xn3**2) 5209 rmni=sqrt(rm2i*rn2i) 5210 cphi=(xm1*xn1+xm2*xn2+xm3*xn3)*rmni 5211 if(cphi.lt.-one) cphi=-one 5212 if(cphi.gt. one) cphi= one 5213 phi=acos(cphi) 5214 s=xwkj1*(xm2*xn3-xm3*xn2) +xwkj2*(xm3*xn1-xm1*xn3) 5215 + +xwkj3*(xm1*xn2-xm2*xn1) 5216 if(s.lt.zero) phi=-phi 5217 sphi=sin(phi) 5218 rpa=rmul*phi-angle 5219 if(iand(iwdt(iwm),mdynam).eq.ldynam) 5220 + rdih(iwd,2)=rdih(iwd,2)+for*(one+cos(rpa)) 5221 dfor=(-for)*rmul*sin(rpa) 5222 if(ip2(8)) ep2(1)=ep2(1)+ 5223 + dih(iwd,3,2)*(one+cos(dih(iwd,1,2)*phi-dih(iwd,2,2))) 5224 if(ip3(8)) ep3(1)=ep3(1)+ 5225 + dih(iwd,3,3)*(one+cos(dih(iwd,1,3)*phi-dih(iwd,2,3))) 5226 if(abs(sphi).lt.small) sphi=sign(small,sphi) 5227 sphii=one/sphi 5228 xd1=(-dfor)*sphii*(rmni*xn1-cphi*rm2i*xm1) 5229 xe1=(-dfor)*sphii*(rmni*xm1-cphi*rn2i*xn1) 5230 xd2=(-dfor)*sphii*(rmni*xn2-cphi*rm2i*xm2) 5231 xe2=(-dfor)*sphii*(rmni*xm2-cphi*rn2i*xn2) 5232 xd3=(-dfor)*sphii*(rmni*xn3-cphi*rm2i*xm3) 5233 xe3=(-dfor)*sphii*(rmni*xm3-cphi*rn2i*xn3) 5234 dfwi1=xwkj2*xd3-xwkj3*xd2 5235 dfwi2=xwkj3*xd1-xwkj1*xd3 5236 dfwi3=xwkj1*xd2-xwkj2*xd1 5237 dfwj1=xwik2*xd3-xwik3*xd2-xwkl2*xe3+xwkl3*xe2 5238 dfwj2=xwik3*xd1-xwik1*xd3-xwkl3*xe1+xwkl1*xe3 5239 dfwj3=xwik1*xd2-xwik2*xd1-xwkl1*xe2+xwkl2*xe1 5240 dfwk1=xwjl2*xe3-xwjl3*xe2-xwij2*xd3+xwij3*xd2 5241 dfwk2=xwjl3*xe1-xwjl1*xe3-xwij3*xd1+xwij1*xd3 5242 dfwk3=xwjl1*xe2-xwjl2*xe1-xwij1*xd2+xwij2*xd1 5243 dfwl1=xwkj2*xe3-xwkj3*xe2 5244 dfwl2=xwkj3*xe1-xwkj1*xe3 5245 dfwl3=xwkj1*xe2-xwkj2*xe1 5246 fw(iwm,1,iwa,1)=fw(iwm,1,iwa,1)-dfwi1 5247 fw(iwm,2,iwa,1)=fw(iwm,2,iwa,1)-dfwi2 5248 fw(iwm,3,iwa,1)=fw(iwm,3,iwa,1)-dfwi3 5249 fw(iwm,1,jwa,1)=fw(iwm,1,jwa,1)-dfwj1 5250 fw(iwm,2,jwa,1)=fw(iwm,2,jwa,1)-dfwj2 5251 fw(iwm,3,jwa,1)=fw(iwm,3,jwa,1)-dfwj3 5252 fw(iwm,1,kwa,1)=fw(iwm,1,kwa,1)-dfwk1 5253 fw(iwm,2,kwa,1)=fw(iwm,2,kwa,1)-dfwk2 5254 fw(iwm,3,kwa,1)=fw(iwm,3,kwa,1)-dfwk3 5255 fw(iwm,1,lwa,1)=fw(iwm,1,lwa,1)-dfwl1 5256 fw(iwm,2,lwa,1)=fw(iwm,2,lwa,1)-dfwl2 5257 fw(iwm,3,lwa,1)=fw(iwm,3,lwa,1)-dfwl3 5258 if(ith(9)) then 5259 deriv(9,1)=deriv(9,1)+(one+cos(rpa))*dih(iwd,3,4) 5260 + -for*sin(rpa)*(phi*dih(iwd,1,4)-dih(iwd,2,4)) 5261 endif 5262 80 continue 5263 eww(3,1)=eww(3,1)+rdih(iwd,2) 5264 if(ip2(8)) ep2(1)=ep2(1)-rdih(iwd,2) 5265 if(ip3(8)) ep3(1)=ep3(1)-rdih(iwd,2) 5266 70 continue 5267 do 90 iwo=1,nwo 5268 iwa=iimp(iwo,1) 5269 jwa=iimp(iwo,2) 5270 kwa=iimp(iwo,3) 5271 lwa=iimp(iwo,4) 5272 angle=dimp(iwo,2,iset) 5273 for=dimp(iwo,3,iset) 5274 rimp(iwo,2)=zero 5275 do 100 iwm=iwfr,iwto 5276 xwij1=xw(iwm,1,iwa)-xw(iwm,1,jwa) 5277 xwij2=xw(iwm,2,iwa)-xw(iwm,2,jwa) 5278 xwij3=xw(iwm,3,iwa)-xw(iwm,3,jwa) 5279 xwkj1=xw(iwm,1,kwa)-xw(iwm,1,jwa) 5280 xwkj2=xw(iwm,2,kwa)-xw(iwm,2,jwa) 5281 xwkj3=xw(iwm,3,kwa)-xw(iwm,3,jwa) 5282 xwkl1=xw(iwm,1,kwa)-xw(iwm,1,lwa) 5283 xwkl2=xw(iwm,2,kwa)-xw(iwm,2,lwa) 5284 xwkl3=xw(iwm,3,kwa)-xw(iwm,3,lwa) 5285 xwik1=xwij1-xwkj1 5286 xwik2=xwij2-xwkj2 5287 xwik3=xwij3-xwkj3 5288 xwjl1=xwkl1-xwkj1 5289 xwjl2=xwkl2-xwkj2 5290 xwjl3=xwkl3-xwkj3 5291 xm1=xwij2*xwkj3-xwkj2*xwij3 5292 xm2=xwij3*xwkj1-xwkj3*xwij1 5293 xm3=xwij1*xwkj2-xwkj1*xwij2 5294 xn1=xwkj2*xwkl3-xwkl2*xwkj3 5295 xn2=xwkj3*xwkl1-xwkl3*xwkj1 5296 xn3=xwkj1*xwkl2-xwkl1*xwkj2 5297 rm2i=one/(xm1**2+xm2**2+xm3**2) 5298 rn2i=one/(xn1**2+xn2**2+xn3**2) 5299 rmni=sqrt(rm2i*rn2i) 5300 cphi=(xm1*xn1+xm2*xn2+xm3*xn3) 5301 if(cphi.lt.-one) cphi=-one 5302 if(cphi.gt. one) cphi= one 5303 phi=acos(cphi) 5304 s=xwkj1*(xm2*xn3-xm3*xn2) +xwkj2*(xm3*xn1-xm1*xn3) 5305 + +xwkj3*(xm1*xn2-xm2*xn1) 5306 if(s.lt.zero) phi=-phi 5307 sphi=sin(phi) 5308 dangle=(phi-angle)-nint((phi-angle)/twopi)*twopi 5309 dfor=for*dangle 5310 if(iand(iwdt(iwm),mdynam).eq.ldynam) rimp(iwo,2)=half*dfor*dangle 5311 if(ip2(9)) then 5312 danglep=(phi-dimp(iwo,2,2))-nint((phi-dimp(iwo,2,2))/twopi)*twopi 5313 ep2(1)=ep2(1)+half*dimp(iwo,3,2)*danglep**2 5314 endif 5315 if(ip3(9)) then 5316 danglep=(phi-dimp(iwo,2,3))-nint((phi-dimp(iwo,2,3))/twopi)*twopi 5317 ep3(1)=ep3(1)+half*dimp(iwo,3,3)*danglep**2 5318 endif 5319 if(abs(sphi).lt.small) sphi=sign(small,sphi) 5320 sphii=one/sphi 5321 xd1=(-dfor)*sphii*(rmni*xn1-cphi*rm2i*xm1) 5322 xe1=(-dfor)*sphii*(rmni*xm1-cphi*rn2i*xn1) 5323 xd2=(-dfor)*sphii*(rmni*xn2-cphi*rm2i*xm2) 5324 xe2=(-dfor)*sphii*(rmni*xm2-cphi*rn2i*xn2) 5325 xd3=(-dfor)*sphii*(rmni*xn3-cphi*rm2i*xm3) 5326 xe3=(-dfor)*sphii*(rmni*xm3-cphi*rn2i*xn3) 5327 dfwi1=xwkj2*xd3-xwkj3*xd2 5328 dfwi2=xwkj3*xd1-xwkj1*xd3 5329 dfwi3=xwkj1*xd2-xwkj2*xd1 5330 dfwj1=xwik2*xd3-xwik3*xd2-xwkl2*xe3+xwkl3*xe2 5331 dfwj2=xwik3*xd1-xwik1*xd3-xwkl3*xe1+xwkl1*xe3 5332 dfwj3=xwik1*xd2-xwik2*xd1-xwkl1*xe2+xwkl2*xe1 5333 dfwk1=xwjl2*xe3-xwjl3*xe2-xwij2*xd3+xwij3*xd2 5334 dfwk2=xwjl3*xe1-xwjl1*xe3-xwij3*xd1+xwij1*xd3 5335 dfwk3=xwjl1*xe2-xwjl2*xe1-xwij1*xd2+xwij2*xd1 5336 dfwl1=xwkj2*xe3-xwkj3*xe2 5337 dfwl2=xwkj3*xe1-xwkj1*xe3 5338 dfwl3=xwkj1*xe2-xwkj2*xe1 5339 fw(iwm,1,iwa,1)=fw(iwm,1,iwa,1)-dfwi1 5340 fw(iwm,2,iwa,1)=fw(iwm,2,iwa,1)-dfwi2 5341 fw(iwm,3,iwa,1)=fw(iwm,3,iwa,1)-dfwi3 5342 fw(iwm,1,jwa,1)=fw(iwm,1,jwa,1)-dfwj1 5343 fw(iwm,2,jwa,1)=fw(iwm,2,jwa,1)-dfwj2 5344 fw(iwm,3,jwa,1)=fw(iwm,3,jwa,1)-dfwj3 5345 fw(iwm,1,kwa,1)=fw(iwm,1,kwa,1)-dfwk1 5346 fw(iwm,2,kwa,1)=fw(iwm,2,kwa,1)-dfwk2 5347 fw(iwm,3,kwa,1)=fw(iwm,3,kwa,1)-dfwk3 5348 fw(iwm,1,lwa,1)=fw(iwm,1,lwa,1)-dfwl1 5349 fw(iwm,2,lwa,1)=fw(iwm,2,lwa,1)-dfwl2 5350 fw(iwm,3,lwa,1)=fw(iwm,3,lwa,1)-dfwl3 5351 if(ith(10)) then 5352 deriv(10,1)=deriv(10,1)+ 5353 + dangle*(half*dangle*dimp(iwo,3,4)-for*dimp(iwo,2,4)) 5354 endif 5355 100 continue 5356 eww(4,1)=eww(4,1)+rimp(iwo,2) 5357 if(ip2(9)) ep2(1)=ep2(1)-rimp(iwo,2) 5358 if(ip3(9)) ep3(1)=ep3(1)-rimp(iwo,2) 5359 90 continue 5360 c6p1=zero 5361 c12p1=zero 5362 c6p2=zero 5363 c12p2=zero 5364 qip1=zero 5365 qjp1=zero 5366 qip2=zero 5367 qjp2=zero 5368 do 110 iwt=1,nwt 5369 iwa=idwt(iwt,1) 5370 jwa=idwt(iwt,2) 5371 c6=vdw(iwatm(iwa),iwatm(jwa),2,iset) 5372 c12=vdw(iwatm(iwa),iwatm(jwa),4,iset) 5373 if(ip2(2)) then 5374 c6p1=vdw(iwatm(iwa),iwatm(jwa),2,2) 5375 c12p1=vdw(iwatm(iwa),iwatm(jwa),4,2) 5376 endif 5377 if(ip3(2)) then 5378 c6p2=vdw(iwatm(iwa),iwatm(jwa),2,3) 5379 c12p2=vdw(iwatm(iwa),iwatm(jwa),4,3) 5380 endif 5381 if(ith(2).or.ith(4)) then 5382 c6t=vdw(iwatm(iwa),iwatm(jwa),2,4) 5383 c12t=vdw(iwatm(iwa),iwatm(jwa),4,4) 5384 qit=chg(iwq(iwa),1,4)*q14fac 5385 qjt=chg(iwq(jwa),1,4) 5386 endif 5387 cf6=six*c6 5388 cf12=twelve*c12 5389 qi=chg(iwq(iwa),1,iset)*q14fac 5390 qj=chg(iwq(jwa),1,iset) 5391 q=qi*qj 5392 if(ip2(4)) then 5393 qip1=chg(iwq(iwa),1,2)*q14fac 5394 qjp1=chg(iwq(jwa),1,2) 5395 qp1=qip1*qjp1 5396 endif 5397 if(ip3(4)) then 5398 qip2=chg(iwq(iwa),1,3)*q14fac 5399 qjp2=chg(iwq(jwa),1,3) 5400 qp2=qip2*qjp2 5401 endif 5402 ep2l=zero 5403 ep3l=zero 5404 ep2q=zero 5405 ep3q=zero 5406 do 120 iwm=iwfr,iwto 5407 rxx=xw(iwm,1,iwa)-xw(iwm,1,jwa) 5408 rxy=xw(iwm,2,iwa)-xw(iwm,2,jwa) 5409 rxz=xw(iwm,3,iwa)-xw(iwm,3,jwa) 5410 r2=rxx*rxx+rxy*rxy+rxz*rxz 5411 r2i=one/r2 5412 r1i=sqrt(r2i) 5413 r6i=r2i*r2i*r2i 5414 eterml=(c12*r6i-c6)*r6i 5415 etermq=q*r1i 5416 if(iand(iwdt(iwm),mdynam).eq.ldynam) eww(5,1)=eww(5,1)+eterml 5417 if(iand(iwdt(iwm),mdynam).eq.ldynam) eww(6,1)=eww(6,1)+etermq 5418 if(ip2(2)) ep2l=ep2l-eterml+(c12p1*r6i-c6p1)*r6i 5419 if(ip3(2)) ep3l=ep3l-eterml+(c12p2*r6i-c6p2)*r6i 5420 if(ip2(4)) ep2q=ep2q-etermq+qp1*r1i 5421 if(ip3(4)) ep3q=ep3q-etermq+qp2*r1i 5422 dfw=((cf12*r6i-cf6)*r6i+q*r1i)*r2i 5423 fw(iwm,1,iwa,1)=fw(iwm,1,iwa,1)+dfw*rxx 5424 fw(iwm,2,iwa,1)=fw(iwm,2,iwa,1)+dfw*rxy 5425 fw(iwm,3,iwa,1)=fw(iwm,3,iwa,1)+dfw*rxz 5426 fw(iwm,1,jwa,1)=fw(iwm,1,jwa,1)-dfw*rxx 5427 fw(iwm,2,jwa,1)=fw(iwm,2,jwa,1)-dfw*rxy 5428 fw(iwm,3,jwa,1)=fw(iwm,3,jwa,1)-dfw*rxz 5429 if(ith(2)) then 5430 deriv(2,1)=deriv(2,1)+(c12t*r6i-c6t)*r6i 5431 endif 5432 if(ith(4)) then 5433 deriv(4,1)=deriv(4,1)+(qi*qjt+qj*qit)*r1i 5434 endif 5435 120 continue 5436 ep2(1)=ep2(1)+ep2l+ep2q 5437 ep3(1)=ep3(1)+ep3l+ep3q 5438 if(ipme.ne.0) then 5439 qij=(one-q14fac)*chg(iwq(iwa),1,iset)*chg(iwq(jwa),1,iset) 5440 do 111 iwm=iwfr,iwto 5441 rwx1=xw(iwm,1,iwa)-xw(iwm,1,jwa) 5442 rwx2=xw(iwm,2,iwa)-xw(iwm,2,jwa) 5443 rwx3=xw(iwm,3,iwa)-xw(iwm,3,jwa) 5444 rww=sqrt(rwx1**2+rwx2**2+rwx3**2) 5445 rwi=one/rww 5446 ferfc=one-erfc(ealpha*rww) 5447 fderfc=-(ealpha*derfc(ealpha*rww)) 5448 epmecw=epmecw-ferfc*qij*rwi 5449 eww(6,1)=eww(6,1)-ferfc*qij*rwi 5450 dfor=-(qij*rwi*rwi*(ferfc*rwi-fderfc)) 5451 dfw1=dfor*rwx1 5452 dfw2=dfor*rwx2 5453 dfw3=dfor*rwx3 5454 fw(iwm,1,iwa,1)=fw(iwm,1,iwa,1)-dfw1 5455 fw(iwm,1,jwa,1)=fw(iwm,1,jwa,1)+dfw1 5456 fw(iwm,2,iwa,1)=fw(iwm,2,iwa,1)-dfw2 5457 fw(iwm,2,jwa,1)=fw(iwm,2,jwa,1)+dfw2 5458 fw(iwm,3,iwa,1)=fw(iwm,3,iwa,1)-dfw3 5459 fw(iwm,3,jwa,1)=fw(iwm,3,jwa,1)+dfw3 5460 vpmeb(1)=vpmeb(1)+dfw1*rwx1 5461 vpmeb(2)=vpmeb(2)+dfw2*rwx1 5462 vpmeb(3)=vpmeb(3)+dfw3*rwx1 5463 vpmeb(4)=vpmeb(4)+dfw2*rwx2 5464 vpmeb(5)=vpmeb(5)+dfw3*rwx2 5465 vpmeb(6)=vpmeb(6)+dfw3*rwx3 5466 111 continue 5467 endif 5468 110 continue 5469 do 130 iwn=1,nwn 5470 iwa=idwn(iwn,1) 5471 jwa=idwn(iwn,2) 5472 c6=vdw(iwatm(iwa),iwatm(jwa),1,iset) 5473 c12=vdw(iwatm(iwa),iwatm(jwa),3,iset) 5474 if(ip2(2)) then 5475 c6p1=vdw(iwatm(iwa),iwatm(jwa),1,2) 5476 c12p1=vdw(iwatm(iwa),iwatm(jwa),3,2) 5477 endif 5478 if(ip3(2)) then 5479 c6p2=vdw(iwatm(iwa),iwatm(jwa),1,3) 5480 c12p2=vdw(iwatm(iwa),iwatm(jwa),3,3) 5481 endif 5482 if(ith(2).or.ith(4)) then 5483 c6t=vdw(iwatm(iwa),iwatm(jwa),1,4) 5484 c12t=vdw(iwatm(iwa),iwatm(jwa),3,4) 5485 qit=chg(iwq(iwa),1,4) 5486 qjt=chg(iwq(jwa),1,4) 5487 endif 5488 cf6=six*c6 5489 cf12=twelve*c12 5490 qi=chg(iwq(iwa),1,iset) 5491 qj=chg(iwq(jwa),1,iset) 5492 q=qi*qj 5493 if(ip2(4)) then 5494 qip1=chg(iwq(iwa),1,2) 5495 qjp1=chg(iwq(jwa),1,2) 5496 qp1=qip1*qjp1 5497 endif 5498 if(ip3(4)) then 5499 qip2=chg(iwq(iwa),1,3) 5500 qjp2=chg(iwq(jwa),1,3) 5501 qp2=qip2*qjp2 5502 endif 5503 ep2l=zero 5504 ep3l=zero 5505 ep2q=zero 5506 ep3q=zero 5507 do 140 iwm=iwfr,iwto 5508 rxx=xw(iwm,1,iwa)-xw(iwm,1,jwa) 5509 rxy=xw(iwm,2,iwa)-xw(iwm,2,jwa) 5510 rxz=xw(iwm,3,iwa)-xw(iwm,3,jwa) 5511 r2=rxx*rxx+rxy*rxy+rxz*rxz 5512 r2i=one/r2 5513 r1i=sqrt(r2i) 5514 r6i=r2i*r2i*r2i 5515 ferfc=one 5516 fderfc=zero 5517 if(ipme.ne.0) then 5518 ferfc=erfc(ealpha/r1i) 5519 fderfc=ealpha+derfc(ealpha/r1i) 5520 endif 5521 eterml=(c12*r6i-c6)*r6i 5522 etermq=ferfc*q*r1i 5523 if(iand(iwdt(iwm),mdynam).eq.ldynam) then 5524 eww(5,1)=eww(5,1)+eterml 5525 eww(6,1)=eww(6,1)+etermq 5526 endif 5527 if(ip2(2)) ep2l=ep2l-eterml+(c12p1*r6i-c6p1)*r6i 5528 if(ip3(2)) ep3l=ep3l-eterml+(c12p2*r6i-c6p2)*r6i 5529 if(ip2(4)) ep2q=ep2q-etermq+qp1*r1i 5530 if(ip3(4)) ep3q=ep3q-etermq+qp2*r1i 5531 dfw=((cf12*r6i-cf6)*r6i+q*(ferfc*r1i-fderfc))*r2i 5532 fw(iwm,1,iwa,1)=fw(iwm,1,iwa,1)+dfw*rxx 5533 fw(iwm,2,iwa,1)=fw(iwm,2,iwa,1)+dfw*rxy 5534 fw(iwm,3,iwa,1)=fw(iwm,3,iwa,1)+dfw*rxz 5535 fw(iwm,1,jwa,1)=fw(iwm,1,jwa,1)-dfw*rxx 5536 fw(iwm,2,jwa,1)=fw(iwm,2,jwa,1)-dfw*rxy 5537 fw(iwm,3,jwa,1)=fw(iwm,3,jwa,1)-dfw*rxz 5538 if(ith(2)) deriv(2,1)=deriv(2,1)+(c12t*r6i-c6t)*r6i 5539 if(ith(4)) deriv(4,1)=deriv(4,1)+(qi*qjt+qj*qit)*r1i 5540 140 continue 5541 ep2(1)=ep2(1)+ep2l+ep2q 5542 ep3(1)=ep3(1)+ep3l+ep3q 5543 130 continue 5544c 5545#endif 5546 return 5547 end 5548