source/unres/src_MD-NEWSC-NEWC/energy_p_new_barrier_v3ok1.F

   1       SUBROUTINE etotal(energia)\r
   2       implicit real*8 (a-h,o-z)\r
   3       include 'DIMENSIONS'\r
   4 #ifndef ISNAN\r
   5       external proc_proc\r
   6 #ifdef WINPGI\r
   7 cMS$ATTRIBUTES C ::  proc_proc\r
   8 #endif\r
   9 #endif\r
  10 #ifdef MPI\r
  11       include "mpif.h"\r
  12       double precision weights_(n_ene)\r
  13 #endif\r
  14       include 'COMMON.SETUP'\r
  15       include 'COMMON.IOUNITS'\r
  16       double precision energia(0:n_ene)\r
  17       include 'COMMON.LOCAL'\r
  18       include 'COMMON.FFIELD'\r
  19       include 'COMMON.DERIV'\r
  20       include 'COMMON.INTERACT'\r
  21       include 'COMMON.SBRIDGE'\r
  22       include 'COMMON.CHAIN'\r
  23       include 'COMMON.VAR'\r
  24       include 'COMMON.MD'\r
  25       include 'COMMON.CONTROL'\r
  26       include 'COMMON.TIME1'\r
  27 #ifdef MPI      \r
  28 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,\r
  29 c     & " nfgtasks",nfgtasks\r
  30       if (nfgtasks.gt.1) then\r
  31 #ifdef MPI\r
  32         time00=MPI_Wtime()\r
  33 #else\r
  34         time00=tcpu()\r
  35 #endif\r
  36 C FG slaves call the following matching MPI_Bcast in ERGASTULUM\r
  37         if (fg_rank.eq.0) then\r
  38           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)\r
  39 c          print *,"Processor",myrank," BROADCAST iorder"\r
  40 C FG master sets up the WEIGHTS_ array which will be broadcast to the \r
  41 C FG slaves as WEIGHTS array.\r
  42           weights_(1)=wsc\r
  43           weights_(2)=wscp\r
  44           weights_(3)=welec\r
  45           weights_(4)=wcorr\r
  46           weights_(5)=wcorr5\r
  47           weights_(6)=wcorr6\r
  48           weights_(7)=wel_loc\r
  49           weights_(8)=wturn3\r
  50           weights_(9)=wturn4\r
  51           weights_(10)=wturn6\r
  52           weights_(11)=wang\r
  53           weights_(12)=wscloc\r
  54           weights_(13)=wtor\r
  55           weights_(14)=wtor_d\r
  56           weights_(15)=wstrain\r
  57           weights_(16)=wvdwpp\r
  58           weights_(17)=wbond\r
  59           weights_(18)=scal14\r
  60           weights_(21)=wsccor\r
  61           weights_(22)=wsct\r
  62 C FG Master broadcasts the WEIGHTS_ array\r
  63           call MPI_Bcast(weights_(1),n_ene,\r
  64      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)\r
  65         else\r
  66 C FG slaves receive the WEIGHTS array\r
  67           call MPI_Bcast(weights(1),n_ene,\r
  68      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)\r
  69           wsc=weights(1)\r
  70           wscp=weights(2)\r
  71           welec=weights(3)\r
  72           wcorr=weights(4)\r
  73           wcorr5=weights(5)\r
  74           wcorr6=weights(6)\r
  75           wel_loc=weights(7)\r
  76           wturn3=weights(8)\r
  77           wturn4=weights(9)\r
  78           wturn6=weights(10)\r
  79           wang=weights(11)\r
  80           wscloc=weights(12)\r
  81           wtor=weights(13)\r
  82           wtor_d=weights(14)\r
  83           wstrain=weights(15)\r
  84           wvdwpp=weights(16)\r
  85           wbond=weights(17)\r
  86           scal14=weights(18)\r
  87           wsccor=weights(21)\r
  88           wsct=weights(22)\r
  89         endif\r
  90         time_Bcast=time_Bcast+MPI_Wtime()-time00\r
  91         time_Bcastw=time_Bcastw+MPI_Wtime()-time00\r
  92 c        call chainbuild_cart\r
  93       endif\r
  94 c      print *,'Processor',myrank,' calling etotal ipot=',ipot\r
  95 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct\r
  96 #else\r
  97 c      if (modecalc.eq.12.or.modecalc.eq.14) then\r
  98 c        call int_from_cart1(.false.)\r
  99 c      endif\r
 100 #endif     \r
 101 #ifdef TIMING\r
 102 #ifdef MPI\r
 103       time00=MPI_Wtime()\r
 104 #else\r
 105       time00=tcpu()\r
 106 #endif\r
 107 #endif\r
 108 C \r
 109 C Compute the side-chain and electrostatic interaction energy\r
 110 C\r
 111       goto (101,102,103,104,105,106,107) ipot\r
 112 C Lennard-Jones potential.\r
 113   101 call elj(evdw,evdw_p,evdw_m)\r
 114 cd    print '(a)','Exit ELJ'\r
 115       goto 108\r
 116 C Lennard-Jones-Kihara potential (shifted).\r
 117   102 call eljk(evdw,evdw_p,evdw_m)\r
 118       goto 108\r
 119 C Berne-Pechukas potential (dilated LJ, angular dependence).\r
 120   103 call ebp(evdw,evdw_p,evdw_m)\r
 121       goto 108\r
 122 C Gay-Berne potential (shifted LJ, angular dependence).\r
 123   104 call egb(evdw,evdw_p,evdw_m)\r
 124       goto 108\r
 125 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).\r
 126   105 call egbv(evdw,evdw_p,evdw_m)\r
 127       goto 108\r
 128 C New SC-SC potential\r
 129   106 call emomo(evdw,evdw_p,evdw_m)\r
 130       goto 108\r
 131 C Soft-sphere potential\r
 132   107 call e_softsphere(evdw)\r
 133 C\r
 134 C Calculate electrostatic (H-bonding) energy of the main chain.\r
 135 C\r
 136   108 continue\r
 137 c      print *,"Processor",myrank," computed USCSC"\r
 138 #ifdef TIMING\r
 139 #ifdef MPI\r
 140       time01=MPI_Wtime() \r
 141 #else\r
 142       time00=tcpu()\r
 143 #endif\r
 144 #endif\r
 145       call vec_and_deriv\r
 146 #ifdef TIMING\r
 147 #ifdef MPI\r
 148       time_vec=time_vec+MPI_Wtime()-time01\r
 149 #else\r
 150       time_vec=time_vec+tcpu()-time01\r
 151 #endif\r
 152 #endif\r
 153 c      print *,"Processor",myrank," left VEC_AND_DERIV"\r
 154       IF (ipot.lt.7) THEN\r
 155 #ifdef SPLITELE\r
 156          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.\r
 157      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0\r
 158      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0\r
 159      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then\r
 160 #else\r
 161          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.\r
 162      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0\r
 163      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 \r
 164      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then\r
 165 #endif\r
 166             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)\r
 167          else\r
 168             ees=0.0d0\r
 169             evdw1=0.0d0\r
 170             eel_loc=0.0d0\r
 171             eello_turn3=0.0d0\r
 172             eello_turn4=0.0d0\r
 173          endif\r
 174       else\r
 175 c        write (iout,*) "Soft-spheer ELEC potential"\r
 176         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,\r
 177      &   eello_turn4)\r
 178       endif\r
 179 c      print *,"Processor",myrank," computed UELEC"\r
 180 C\r
 181 C Calculate excluded-volume interaction energy between peptide groups\r
 182 C and side chains.\r
 183 C\r
 184       if (ipot.lt.7) then\r
 185        if(wscp.gt.0d0) then\r
 186         call escp(evdw2,evdw2_14)\r
 187        else\r
 188         evdw2=0\r
 189         evdw2_14=0\r
 190        endif\r
 191       else\r
 192 c        write (iout,*) "Soft-sphere SCP potential"\r
 193         call escp_soft_sphere(evdw2,evdw2_14)\r
 194       endif\r
 195 c\r
 196 c Calculate the bond-stretching energy\r
 197 c\r
 198       call ebond(estr)\r
 199 C \r
 200 C Calculate the disulfide-bridge and other energy and the contributions\r
 201 C from other distance constraints.\r
 202 cd    print *,'Calling EHPB'\r
 203       call edis(ehpb)\r
 204 cd    print *,'EHPB exitted succesfully.'\r
 205 C\r
 206 C Calculate the virtual-bond-angle energy.\r
 207 C\r
 208       if (wang.gt.0d0) then\r
 209         call ebend(ebe)\r
 210       else\r
 211         ebe=0\r
 212       endif\r
 213 c      print *,"Processor",myrank," computed UB"\r
 214 C\r
 215 C Calculate the SC local energy.\r
 216 C\r
 217       call esc(escloc)\r
 218 c      print *,"Processor",myrank," computed USC"\r
 219 C\r
 220 C Calculate the virtual-bond torsional energy.\r
 221 C\r
 222 cd    print *,'nterm=',nterm\r
 223       if (wtor.gt.0) then\r
 224        call etor(etors,edihcnstr)\r
 225       else\r
 226        etors=0\r
 227        edihcnstr=0\r
 228       endif\r
 229 c      print *,"Processor",myrank," computed Utor"\r
 230 C\r
 231 C 6/23/01 Calculate double-torsional energy\r
 232 C\r
 233       if (wtor_d.gt.0) then\r
 234        call etor_d(etors_d)\r
 235       else\r
 236        etors_d=0\r
 237       endif\r
 238 c      print *,"Processor",myrank," computed Utord"\r
 239 C\r
 240 C 21/5/07 Calculate local sicdechain correlation energy\r
 241 C\r
 242       write (*,*) "eback_sc_corr XX"\r
 243       if (wsccor.gt.0.0d0) then\r
 244       write (*,*) "eback_sc_corr 00a"\r
 245         call eback_sc_corr(esccor)\r
 246       else\r
 247       write (*,*) "eback_sc_corr 00b"\r
 248         esccor=0.0d0\r
 249       END IF\r
 250 c      print *,"Processor",myrank," computed Usccorr"\r
 251 C \r
 252 C 12/1/95 Multi-body terms\r
 253 C\r
 254       n_corr=0\r
 255       n_corr1=0\r
 256       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 \r
 257      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.7) then\r
 258          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)\r
 259 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,\r
 260 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6\r
 261       else\r
 262          ecorr=0.0d0\r
 263          ecorr5=0.0d0\r
 264          ecorr6=0.0d0\r
 265          eturn6=0.0d0\r
 266       end if\r
 267       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.7) then\r
 268          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)\r
 269 cd         write (iout,*) "multibody_hb ecorr",ecorr\r
 270       end if\r
 271 c      print *,"Processor",myrank," computed Ucorr"\r
 272 C \r
 273 C If performing constraint dynamics, call the constraint energy\r
 274 C  after the equilibration time\r
 275       IF(usampl.and.totT.gt.eq_time) THEN\r
 276          call EconstrQ   \r
 277          call Econstr_back\r
 278       ELSE\r
 279          Uconst=0.0d0\r
 280          Uconst_back=0.0d0\r
 281       ENDIF\r
 282 #ifdef TIMING\r
 283 #ifdef MPI\r
 284       time_enecalc=time_enecalc+MPI_Wtime()-time00\r
 285 #else\r
 286       time_enecalc=time_enecalc+tcpu()-time00\r
 287 #endif\r
 288 #endif\r
 289 c      print *,"Processor",myrank," computed Uconstr"\r
 290 #ifdef TIMING\r
 291 #ifdef MPI\r
 292       time00=MPI_Wtime()\r
 293 #else\r
 294       time00=tcpu()\r
 295 #endif\r
 296 #endif\r
 297 c\r
 298 C Sum the energies\r
 299 C\r
 300       energia(1)=evdw\r
 301 #ifdef SCP14\r
 302       energia(2)=evdw2-evdw2_14\r
 303       energia(18)=evdw2_14\r
 304 #else\r
 305       energia(2)=evdw2\r
 306       energia(18)=0.0d0\r
 307 #endif\r
 308 #ifdef SPLITELE\r
 309       energia(3)=ees\r
 310       energia(16)=evdw1\r
 311 #else\r
 312       energia(3)=ees+evdw1\r
 313       energia(16)=0.0d0\r
 314 #endif\r
 315       energia(4)=ecorr\r
 316       energia(5)=ecorr5\r
 317       energia(6)=ecorr6\r
 318       energia(7)=eel_loc\r
 319       energia(8)=eello_turn3\r
 320       energia(9)=eello_turn4\r
 321       energia(10)=eturn6\r
 322       energia(11)=ebe\r
 323       energia(12)=escloc\r
 324       energia(13)=etors\r
 325       energia(14)=etors_d\r
 326       energia(15)=ehpb\r
 327       energia(19)=edihcnstr\r
 328       energia(17)=estr\r
 329       energia(20)=Uconst+Uconst_back\r
 330       energia(21)=esccor\r
 331       energia(22)=evdw_p\r
 332       energia(23)=evdw_m\r
 333 c      print *," Processor",myrank," calls SUM_ENERGY"\r
 334       call sum_energy(energia,.true.)\r
 335 c      print *," Processor",myrank," left SUM_ENERGY"\r
 336 #ifdef TIMING\r
 337 #ifdef MPI\r
 338       time_sumene=time_sumene+MPI_Wtime()-time00\r
 339 #else\r
 340       time_sumene=time_sumene+tcpu()-time00\r
 341 #endif\r
 342 #endif\r
 343        RETURN\r
 344       END SUBROUTINE etotal\r
 345 \r
 346 \r
 347 c-------------------------------------------------------------------------------\r
 348 \r
 349 \r
 350       subroutine sum_energy(energia,reduce)\r
 351       implicit real*8 (a-h,o-z)\r
 352       include 'DIMENSIONS'\r
 353 #ifndef ISNAN\r
 354       external proc_proc\r
 355 #ifdef WINPGI\r
 356 cMS$ATTRIBUTES C ::  proc_proc\r
 357 #endif\r
 358 #endif\r
 359 #ifdef MPI\r
 360       include "mpif.h"\r
 361 #endif\r
 362       include 'COMMON.SETUP'\r
 363       include 'COMMON.IOUNITS'\r
 364       double precision energia(0:n_ene),enebuff(0:n_ene+1)\r
 365       include 'COMMON.FFIELD'\r
 366       include 'COMMON.DERIV'\r
 367       include 'COMMON.INTERACT'\r
 368       include 'COMMON.SBRIDGE'\r
 369       include 'COMMON.CHAIN'\r
 370       include 'COMMON.VAR'\r
 371       include 'COMMON.CONTROL'\r
 372       include 'COMMON.TIME1'\r
 373       logical reduce\r
 374 #ifdef MPI\r
 375       if (nfgtasks.gt.1 .and. reduce) then\r
 376 #ifdef DEBUG\r
 377         write (iout,*) "energies before REDUCE"\r
 378         call enerprint(energia)\r
 379         call flush(iout)\r
 380 #endif\r
 381         do i=0,n_ene\r
 382           enebuff(i)=energia(i)\r
 383         enddo\r
 384         time00=MPI_Wtime()\r
 385         call MPI_Barrier(FG_COMM,IERR)\r
 386         time_barrier_e=time_barrier_e+MPI_Wtime()-time00\r
 387         time00=MPI_Wtime()\r
 388         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,\r
 389      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)\r
 390 #ifdef DEBUG\r
 391         write (iout,*) "energies after REDUCE"\r
 392         call enerprint(energia)\r
 393         call flush(iout)\r
 394 #endif\r
 395         time_Reduce=time_Reduce+MPI_Wtime()-time00\r
 396       endif\r
 397       if (fg_rank.eq.0) then\r
 398 #endif\r
 399 #ifdef TSCSC\r
 400       evdw=energia(22)+wsct*energia(23)\r
 401 #else\r
 402       evdw=energia(1)\r
 403 #endif\r
 404 #ifdef SCP14\r
 405       evdw2=energia(2)+energia(18)\r
 406       evdw2_14=energia(18)\r
 407 #else\r
 408       evdw2=energia(2)\r
 409 #endif\r
 410 #ifdef SPLITELE\r
 411       ees=energia(3)\r
 412       evdw1=energia(16)\r
 413 #else\r
 414       ees=energia(3)\r
 415       evdw1=0.0d0\r
 416 #endif\r
 417       ecorr=energia(4)\r
 418       ecorr5=energia(5)\r
 419       ecorr6=energia(6)\r
 420       eel_loc=energia(7)\r
 421       eello_turn3=energia(8)\r
 422       eello_turn4=energia(9)\r
 423       eturn6=energia(10)\r
 424       ebe=energia(11)\r
 425       escloc=energia(12)\r
 426       etors=energia(13)\r
 427       etors_d=energia(14)\r
 428       ehpb=energia(15)\r
 429       edihcnstr=energia(19)\r
 430       estr=energia(17)\r
 431       Uconst=energia(20)\r
 432       esccor=energia(21)\r
 433 #ifdef SPLITELE\r
 434       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1\r
 435      & +wang*ebe+wtor*etors+wscloc*escloc\r
 436      & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5\r
 437      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3\r
 438      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d\r
 439      & +wbond*estr+Uconst+wsccor*esccor\r
 440 #else\r
 441       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)\r
 442      & +wang*ebe+wtor*etors+wscloc*escloc\r
 443      & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5\r
 444      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3\r
 445      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d\r
 446      & +wbond*estr+Uconst+wsccor*esccor\r
 447 #endif\r
 448       energia(0)=etot\r
 449 c detecting NaNQ\r
 450 #ifdef ISNAN\r
 451 #ifdef AIX\r
 452       if (isnan(etot).ne.0) energia(0)=1.0d+99\r
 453 #else\r
 454       if (isnan(etot)) energia(0)=1.0d+99\r
 455 #endif\r
 456 #else\r
 457       i=0\r
 458 #ifdef WINPGI\r
 459       idumm=proc_proc(etot,i)\r
 460 #else\r
 461       call proc_proc(etot,i)\r
 462 #endif\r
 463       if(i.eq.1)energia(0)=1.0d+99\r
 464 #endif\r
 465 #ifdef MPI\r
 466       endif\r
 467 #endif\r
 468       return\r
 469       end\r
 470 \r
 471 \r
 472 c-------------------------------------------------------------------------------\r
 473 \r
 474 \r
 475       subroutine sum_gradient\r
 476       implicit real*8 (a-h,o-z)\r
 477       include 'DIMENSIONS'\r
 478 #ifndef ISNAN\r
 479       external proc_proc\r
 480 #ifdef WINPGI\r
 481 cMS$ATTRIBUTES C ::  proc_proc\r
 482 #endif\r
 483 #endif\r
 484 #ifdef MPI\r
 485       include 'mpif.h'\r
 486 #endif\r
 487       double precision gradbufc(3,maxres),gradbufx(3,maxres),\r
 488      &  glocbuf(4*maxres),gradbufc_sum(3,maxres)\r
 489       include 'COMMON.SETUP'\r
 490       include 'COMMON.IOUNITS'\r
 491       include 'COMMON.FFIELD'\r
 492       include 'COMMON.DERIV'\r
 493       include 'COMMON.INTERACT'\r
 494       include 'COMMON.SBRIDGE'\r
 495       include 'COMMON.CHAIN'\r
 496       include 'COMMON.VAR'\r
 497       include 'COMMON.CONTROL'\r
 498       include 'COMMON.TIME1'\r
 499       include 'COMMON.MAXGRAD'\r
 500 #ifdef TIMING\r
 501 #ifdef MPI\r
 502       time01=MPI_Wtime()\r
 503 #else\r
 504       time01=tcpu()\r
 505 #endif\r
 506 #endif\r
 507 #ifdef DEBUG\r
 508       write (iout,*) "sum_gradient gvdwc, gvdwx"\r
 509       do i=1,nres\r
 510         write (iout,'(i3,3f10.5,5x,3f10.5,5x,3f10.5,5x,3f10.5)') \r
 511      &   i,(gvdwx(j,i),j=1,3),(gvdwcT(j,i),j=1,3),(gvdwc(j,i),j=1,3),\r
 512      &   (gvdwcT(j,i),j=1,3)\r
 513       enddo\r
 514       call flush(iout)\r
 515 #endif\r
 516 #ifdef MPI\r
 517 C FG slaves call the following matching MPI_Bcast in ERGASTULUM\r
 518         if (nfgtasks.gt.1 .and. fg_rank.eq.0) \r
 519      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)\r
 520 #endif\r
 521 C\r
 522 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient\r
 523 C            in virtual-bond-vector coordinates\r
 524 C\r
 525 #ifdef DEBUG\r
 526 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"\r
 527 c      do i=1,nres-1\r
 528 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)') \r
 529 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)\r
 530 c      enddo\r
 531 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"\r
 532 c      do i=1,nres-1\r
 533 c        write (iout,'(i5,3f10.5,2x,f10.5)') \r
 534 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)\r
 535 c      enddo\r
 536       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"\r
 537       do i=1,nres\r
 538         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') \r
 539      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),\r
 540      &   g_corr5_loc(i)\r
 541       enddo\r
 542       call flush(iout)\r
 543 #endif\r
 544 #ifdef SPLITELE\r
 545 #ifdef TSCSC\r
 546       do i=1,nct\r
 547         do j=1,3\r
 548           gradbufc(j,i)=wsc*gvdwc(j,i)+wsc*wscT*gvdwcT(j,i)+\r
 549      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+\r
 550      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+\r
 551      &                wel_loc*gel_loc_long(j,i)+\r
 552      &                wcorr*gradcorr_long(j,i)+\r
 553      &                wcorr5*gradcorr5_long(j,i)+\r
 554      &                wcorr6*gradcorr6_long(j,i)+\r
 555      &                wturn6*gcorr6_turn_long(j,i)+\r
 556      &                wstrain*ghpbc(j,i)\r
 557         enddo\r
 558       enddo \r
 559 #else\r
 560       do i=1,nct\r
 561         do j=1,3\r
 562           gradbufc(j,i)=wsc*gvdwc(j,i)+\r
 563      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+\r
 564      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+\r
 565      &                wel_loc*gel_loc_long(j,i)+\r
 566      &                wcorr*gradcorr_long(j,i)+\r
 567      &                wcorr5*gradcorr5_long(j,i)+\r
 568      &                wcorr6*gradcorr6_long(j,i)+\r
 569      &                wturn6*gcorr6_turn_long(j,i)+\r
 570      &                wstrain*ghpbc(j,i)\r
 571         enddo\r
 572       enddo\r
 573 #endif\r
 574 #else\r
 575       do i=1,nct\r
 576         do j=1,3\r
 577           gradbufc(j,i)=wsc*gvdwc(j,i)+\r
 578      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+\r
 579      &                welec*gelc_long(j,i)+\r
 580      &                wbond*gradb(j,i)+\r
 581      &                wel_loc*gel_loc_long(j,i)+\r
 582      &                wcorr*gradcorr_long(j,i)+\r
 583      &                wcorr5*gradcorr5_long(j,i)+\r
 584      &                wcorr6*gradcorr6_long(j,i)+\r
 585      &                wturn6*gcorr6_turn_long(j,i)+\r
 586      &                wstrain*ghpbc(j,i)\r
 587         enddo\r
 588       enddo \r
 589 #endif\r
 590 #ifdef MPI\r
 591       if (nfgtasks.gt.1) then\r
 592       time00=MPI_Wtime()\r
 593 #ifdef DEBUG\r
 594       write (iout,*) "gradbufc before allreduce"\r
 595       do i=1,nres\r
 596         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)\r
 597       enddo\r
 598       call flush(iout)\r
 599 #endif\r
 600       do i=1,nres\r
 601         do j=1,3\r
 602           gradbufc_sum(j,i)=gradbufc(j,i)\r
 603         enddo\r
 604       enddo\r
 605 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,\r
 606 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)\r
 607 c      time_reduce=time_reduce+MPI_Wtime()-time00\r
 608 #ifdef DEBUG\r
 609 c      write (iout,*) "gradbufc_sum after allreduce"\r
 610 c      do i=1,nres\r
 611 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)\r
 612 c      enddo\r
 613 c      call flush(iout)\r
 614 #endif\r
 615 #ifdef TIMING\r
 616 c      time_allreduce=time_allreduce+MPI_Wtime()-time00\r
 617 #endif\r
 618       do i=nnt,nres\r
 619         do k=1,3\r
 620           gradbufc(k,i)=0.0d0\r
 621         enddo\r
 622       enddo\r
 623 #ifdef DEBUG\r
 624       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end\r
 625       write (iout,*) (i," jgrad_start",jgrad_start(i),\r
 626      &                  " jgrad_end  ",jgrad_end(i),\r
 627      &                  i=igrad_start,igrad_end)\r
 628 #endif\r
 629 c\r
 630 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,\r
 631 c do not parallelize this part.\r
 632 c\r
 633 c      do i=igrad_start,igrad_end\r
 634 c        do j=jgrad_start(i),jgrad_end(i)\r
 635 c          do k=1,3\r
 636 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)\r
 637 c          enddo\r
 638 c        enddo\r
 639 c      enddo\r
 640       do j=1,3\r
 641         gradbufc(j,nres-1)=gradbufc_sum(j,nres)\r
 642       enddo\r
 643       do i=nres-2,nnt,-1\r
 644         do j=1,3\r
 645           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)\r
 646         enddo\r
 647       enddo\r
 648 #ifdef DEBUG\r
 649       write (iout,*) "gradbufc after summing"\r
 650       do i=1,nres\r
 651         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)\r
 652       enddo\r
 653       call flush(iout)\r
 654 #endif\r
 655       else\r
 656 #endif\r
 657 #ifdef DEBUG\r
 658       write (iout,*) "gradbufc"\r
 659       do i=1,nres\r
 660         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)\r
 661       enddo\r
 662       call flush(iout)\r
 663 #endif\r
 664       do i=1,nres\r
 665         do j=1,3\r
 666           gradbufc_sum(j,i)=gradbufc(j,i)\r
 667           gradbufc(j,i)=0.0d0\r
 668         enddo\r
 669       enddo\r
 670       do j=1,3\r
 671         gradbufc(j,nres-1)=gradbufc_sum(j,nres)\r
 672       enddo\r
 673       do i=nres-2,nnt,-1\r
 674         do j=1,3\r
 675           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)\r
 676         enddo\r
 677       enddo\r
 678 c      do i=nnt,nres-1\r
 679 c        do k=1,3\r
 680 c          gradbufc(k,i)=0.0d0\r
 681 c        enddo\r
 682 c        do j=i+1,nres\r
 683 c          do k=1,3\r
 684 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)\r
 685 c          enddo\r
 686 c        enddo\r
 687 c      enddo\r
 688 #ifdef DEBUG\r
 689       write (iout,*) "gradbufc after summing"\r
 690       do i=1,nres\r
 691         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)\r
 692       enddo\r
 693       call flush(iout)\r
 694 #endif\r
 695 #ifdef MPI\r
 696       endif\r
 697 #endif\r
 698       do k=1,3\r
 699         gradbufc(k,nres)=0.0d0\r
 700       enddo\r
 701       do i=1,nct\r
 702         do j=1,3\r
 703 #ifdef SPLITELE\r
 704           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+\r
 705      &                wel_loc*gel_loc(j,i)+\r
 706      &                0.5d0*(wscp*gvdwc_scpp(j,i)+\r
 707      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+\r
 708      &                wel_loc*gel_loc_long(j,i)+\r
 709      &                wcorr*gradcorr_long(j,i)+\r
 710      &                wcorr5*gradcorr5_long(j,i)+\r
 711      &                wcorr6*gradcorr6_long(j,i)+\r
 712      &                wturn6*gcorr6_turn_long(j,i))+\r
 713      &                wbond*gradb(j,i)+\r
 714      &                wcorr*gradcorr(j,i)+\r
 715      &                wturn3*gcorr3_turn(j,i)+\r
 716      &                wturn4*gcorr4_turn(j,i)+\r
 717      &                wcorr5*gradcorr5(j,i)+\r
 718      &                wcorr6*gradcorr6(j,i)+\r
 719      &                wturn6*gcorr6_turn(j,i)+\r
 720      &                wsccor*gsccorc(j,i)\r
 721      &               +wscloc*gscloc(j,i)\r
 722 #else\r
 723           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+\r
 724      &                wel_loc*gel_loc(j,i)+\r
 725      &                0.5d0*(wscp*gvdwc_scpp(j,i)+\r
 726      &                welec*gelc_long(j,i)+\r
 727      &                wel_loc*gel_loc_long(j,i)+\r
 728      &                wcorr*gcorr_long(j,i)+\r
 729      &                wcorr5*gradcorr5_long(j,i)+\r
 730      &                wcorr6*gradcorr6_long(j,i)+\r
 731      &                wturn6*gcorr6_turn_long(j,i))+\r
 732      &                wbond*gradb(j,i)+\r
 733      &                wcorr*gradcorr(j,i)+\r
 734      &                wturn3*gcorr3_turn(j,i)+\r
 735      &                wturn4*gcorr4_turn(j,i)+\r
 736      &                wcorr5*gradcorr5(j,i)+\r
 737      &                wcorr6*gradcorr6(j,i)+\r
 738      &                wturn6*gcorr6_turn(j,i)+\r
 739      &                wsccor*gsccorc(j,i)\r
 740      &               +wscloc*gscloc(j,i)\r
 741 #endif\r
 742 #ifdef TSCSC\r
 743           gradx(j,i,icg)=wsc*gvdwx(j,i)+wsc*wscT*gvdwxT(j,i)+\r
 744      &                  wscp*gradx_scp(j,i)+\r
 745      &                  wbond*gradbx(j,i)+\r
 746      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+\r
 747      &                  wsccor*gsccorx(j,i)\r
 748      &                 +wscloc*gsclocx(j,i)\r
 749 #else\r
 750           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+\r
 751      &                  wbond*gradbx(j,i)+\r
 752      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+\r
 753      &                  wsccor*gsccorx(j,i)\r
 754      &                 +wscloc*gsclocx(j,i)\r
 755 \r
 756 #endif\r
 757         enddo\r
 758       enddo \r
 759 #ifdef DEBUG\r
 760       write (iout,*) "gloc before adding corr"\r
 761       do i=1,4*nres\r
 762         write (iout,*) i,gloc(i,icg)\r
 763       enddo\r
 764 #endif\r
 765       do i=1,nres-3\r
 766         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)\r
 767      &   +wcorr5*g_corr5_loc(i)\r
 768      &   +wcorr6*g_corr6_loc(i)\r
 769      &   +wturn4*gel_loc_turn4(i)\r
 770      &   +wturn3*gel_loc_turn3(i)\r
 771      &   +wturn6*gel_loc_turn6(i)\r
 772      &   +wel_loc*gel_loc_loc(i)\r
 773      &   +wsccor*gsccor_loc(i)\r
 774       enddo\r
 775 #ifdef DEBUG\r
 776       write (iout,*) "gloc after adding corr"\r
 777       do i=1,4*nres\r
 778         write (iout,*) i,gloc(i,icg)\r
 779       enddo\r
 780 #endif\r
 781 #ifdef MPI\r
 782       if (nfgtasks.gt.1) then\r
 783         do j=1,3\r
 784           do i=1,nres\r
 785             gradbufc(j,i)=gradc(j,i,icg)\r
 786             gradbufx(j,i)=gradx(j,i,icg)\r
 787           enddo\r
 788         enddo\r
 789         do i=1,4*nres\r
 790           glocbuf(i)=gloc(i,icg)\r
 791         enddo\r
 792         time00=MPI_Wtime()\r
 793         call MPI_Barrier(FG_COMM,IERR)\r
 794         time_barrier_g=time_barrier_g+MPI_Wtime()-time00\r
 795         time00=MPI_Wtime()\r
 796         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,\r
 797      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)\r
 798         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,\r
 799      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)\r
 800         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,\r
 801      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)\r
 802         time_reduce=time_reduce+MPI_Wtime()-time00\r
 803 #ifdef DEBUG\r
 804       write (iout,*) "gloc after reduce"\r
 805       do i=1,4*nres\r
 806         write (iout,*) i,gloc(i,icg)\r
 807       enddo\r
 808 #endif\r
 809       endif\r
 810 #endif\r
 811       if (gnorm_check) then\r
 812 c\r
 813 c Compute the maximum elements of the gradient\r
 814 c\r
 815       gvdwc_max=0.0d0\r
 816       gvdwc_scp_max=0.0d0\r
 817       gelc_max=0.0d0\r
 818       gvdwpp_max=0.0d0\r
 819       gradb_max=0.0d0\r
 820       ghpbc_max=0.0d0\r
 821       gradcorr_max=0.0d0\r
 822       gel_loc_max=0.0d0\r
 823       gcorr3_turn_max=0.0d0\r
 824       gcorr4_turn_max=0.0d0\r
 825       gradcorr5_max=0.0d0\r
 826       gradcorr6_max=0.0d0\r
 827       gcorr6_turn_max=0.0d0\r
 828       gsccorc_max=0.0d0\r
 829       gscloc_max=0.0d0\r
 830       gvdwx_max=0.0d0\r
 831       gradx_scp_max=0.0d0\r
 832       ghpbx_max=0.0d0\r
 833       gradxorr_max=0.0d0\r
 834       gsccorx_max=0.0d0\r
 835       gsclocx_max=0.0d0\r
 836       do i=1,nct\r
 837         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))\r
 838         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm\r
 839 #ifdef TSCSC\r
 840         gvdwc_norm=dsqrt(scalar(gvdwcT(1,i),gvdwcT(1,i)))\r
 841         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm          \r
 842 #endif\r
 843         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))\r
 844         if (gvdwc_scp_norm.gt.gvdwc_scp_max) \r
 845      &   gvdwc_scp_max=gvdwc_scp_norm\r
 846         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))\r
 847         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm\r
 848         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))\r
 849         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm\r
 850         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))\r
 851         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm\r
 852         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))\r
 853         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm\r
 854         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))\r
 855         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm\r
 856         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))\r
 857         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm\r
 858         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),\r
 859      &    gcorr3_turn(1,i)))\r
 860         if (gcorr3_turn_norm.gt.gcorr3_turn_max) \r
 861      &    gcorr3_turn_max=gcorr3_turn_norm\r
 862         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),\r
 863      &    gcorr4_turn(1,i)))\r
 864         if (gcorr4_turn_norm.gt.gcorr4_turn_max) \r
 865      &    gcorr4_turn_max=gcorr4_turn_norm\r
 866         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))\r
 867         if (gradcorr5_norm.gt.gradcorr5_max) \r
 868      &    gradcorr5_max=gradcorr5_norm\r
 869         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))\r
 870         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm\r
 871         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),\r
 872      &    gcorr6_turn(1,i)))\r
 873         if (gcorr6_turn_norm.gt.gcorr6_turn_max) \r
 874      &    gcorr6_turn_max=gcorr6_turn_norm\r
 875         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))\r
 876         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm\r
 877         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))\r
 878         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm\r
 879         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))\r
 880         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm\r
 881 #ifdef TSCSC\r
 882         gvdwx_norm=dsqrt(scalar(gvdwxT(1,i),gvdwxT(1,i)))\r
 883         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm\r
 884 #endif\r
 885         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))\r
 886         if (gradx_scp_norm.gt.gradx_scp_max) \r
 887      &    gradx_scp_max=gradx_scp_norm\r
 888         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))\r
 889         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm\r
 890         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))\r
 891         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm\r
 892         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))\r
 893         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm\r
 894         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))\r
 895         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm\r
 896       enddo \r
 897       if (gradout) then\r
 898 #ifdef AIX\r
 899         open(istat,file=statname,position="append")\r
 900 #else\r
 901         open(istat,file=statname,access="append")\r
 902 #endif\r
 903         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,\r
 904      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,\r
 905      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,\r
 906      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,\r
 907      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,\r
 908      &     gsccorx_max,gsclocx_max\r
 909         close(istat)\r
 910         if (gvdwc_max.gt.1.0d4) then\r
 911           write (iout,*) "gvdwc gvdwx gradb gradbx"\r
 912           do i=nnt,nct\r
 913             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),\r
 914      &        gradb(j,i),gradbx(j,i),j=1,3)\r
 915           enddo\r
 916           call pdbout(0.0d0,'cipiszcze',iout)\r
 917           call flush(iout)\r
 918         endif\r
 919       endif\r
 920       endif\r
 921 #ifdef DEBUG\r
 922       write (iout,*) "gradc gradx gloc"\r
 923       do i=1,nres\r
 924         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)') \r
 925      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)\r
 926       enddo \r
 927 #endif\r
 928 #ifdef TIMING\r
 929 #ifdef MPI\r
 930       time_sumgradient=time_sumgradient+MPI_Wtime()-time01\r
 931 #else\r
 932       time_sumgradient=time_sumgradient+tcpu()-time01\r
 933 #endif\r
 934 #endif\r
 935       return\r
 936       end\r
 937 \r
 938 \r
 939 c-------------------------------------------------------------------------------\r
 940 \r
 941 \r
 942       subroutine rescale_weights(t_bath)\r
 943       implicit real*8 (a-h,o-z)\r
 944       include 'DIMENSIONS'\r
 945       include 'COMMON.IOUNITS'\r
 946       include 'COMMON.FFIELD'\r
 947       include 'COMMON.SBRIDGE'\r
 948       double precision kfac /2.4d0/\r
 949       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/\r
 950 c      facT=temp0/t_bath\r
 951 c      facT=2*temp0/(t_bath+temp0)\r
 952       if (rescale_mode.eq.0) then\r
 953         facT=1.0d0\r
 954         facT2=1.0d0\r
 955         facT3=1.0d0\r
 956         facT4=1.0d0\r
 957         facT5=1.0d0\r
 958       else if (rescale_mode.eq.1) then\r
 959         facT=kfac/(kfac-1.0d0+t_bath/temp0)\r
 960         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)\r
 961         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)\r
 962         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)\r
 963         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)\r
 964       else if (rescale_mode.eq.2) then\r
 965         x=t_bath/temp0\r
 966         x2=x*x\r
 967         x3=x2*x\r
 968         x4=x3*x\r
 969         x5=x4*x\r
 970         facT=licznik/dlog(dexp(x)+dexp(-x))\r
 971         facT2=licznik/dlog(dexp(x2)+dexp(-x2))\r
 972         facT3=licznik/dlog(dexp(x3)+dexp(-x3))\r
 973         facT4=licznik/dlog(dexp(x4)+dexp(-x4))\r
 974         facT5=licznik/dlog(dexp(x5)+dexp(-x5))\r
 975       else\r
 976         write (iout,*) "Wrong RESCALE_MODE",rescale_mode\r
 977         write (*,*) "Wrong RESCALE_MODE",rescale_mode\r
 978 #ifdef MPI\r
 979        call MPI_Finalize(MPI_COMM_WORLD,IERROR)\r
 980 #endif\r
 981        stop 555\r
 982       endif\r
 983       welec=weights(3)*fact\r
 984       wcorr=weights(4)*fact3\r
 985       wcorr5=weights(5)*fact4\r
 986       wcorr6=weights(6)*fact5\r
 987       wel_loc=weights(7)*fact2\r
 988       wturn3=weights(8)*fact2\r
 989       wturn4=weights(9)*fact3\r
 990       wturn6=weights(10)*fact5\r
 991       wtor=weights(13)*fact\r
 992       wtor_d=weights(14)*fact2\r
 993       wsccor=weights(21)*fact\r
 994 #ifdef TSCSC\r
 995 c      wsct=t_bath/temp0\r
 996       wsct=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0\r
 997 #endif\r
 998       return\r
 999       end\r
1000 \r
1001 \r
1002 C------------------------------------------------------------------------\r
1003 \r
1004 \r
1005       subroutine enerprint(energia)\r
1006       implicit real*8 (a-h,o-z)\r
1007       include 'DIMENSIONS'\r
1008       include 'COMMON.IOUNITS'\r
1009       include 'COMMON.FFIELD'\r
1010       include 'COMMON.SBRIDGE'\r
1011       include 'COMMON.MD'\r
1012       double precision energia(0:n_ene)\r
1013       etot=energia(0)\r
1014 #ifdef TSCSC\r
1015       evdw=energia(22)+wsct*energia(23)\r
1016 #else\r
1017       evdw=energia(1)\r
1018 #endif\r
1019       evdw2=energia(2)\r
1020 #ifdef SCP14\r
1021       evdw2=energia(2)+energia(18)\r
1022 #else\r
1023       evdw2=energia(2)\r
1024 #endif\r
1025       ees=energia(3)\r
1026 #ifdef SPLITELE\r
1027       evdw1=energia(16)\r
1028 #endif\r
1029       ecorr=energia(4)\r
1030       ecorr5=energia(5)\r
1031       ecorr6=energia(6)\r
1032       eel_loc=energia(7)\r
1033       eello_turn3=energia(8)\r
1034       eello_turn4=energia(9)\r
1035       eello_turn6=energia(10)\r
1036       ebe=energia(11)\r
1037       escloc=energia(12)\r
1038       etors=energia(13)\r
1039       etors_d=energia(14)\r
1040       ehpb=energia(15)\r
1041       edihcnstr=energia(19)\r
1042       estr=energia(17)\r
1043       Uconst=energia(20)\r
1044       esccor=energia(21)\r
1045 #ifdef SPLITELE\r
1046       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,\r
1047      &  estr,wbond,ebe,wang,\r
1048      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,\r
1049      &  ecorr,wcorr,\r
1050      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,\r
1051      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,\r
1052      &  edihcnstr,ebr*nss,\r
1053      &  Uconst,etot\r
1054    10 format (/'Virtual-chain energies:'//\r
1055      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/\r
1056      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/\r
1057      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/\r
1058      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/\r
1059      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/\r
1060      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/\r
1061      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/\r
1062      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/\r
1063      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/\r
1064      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,\r
1065      & ' (SS bridges & dist. cnstr.)'/\r
1066      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/\r
1067      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/\r
1068      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/\r
1069      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/\r
1070      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/\r
1071      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/\r
1072      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/\r
1073      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/\r
1074      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/\r
1075      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/\r
1076      & 'UCONST= ',1pE16.6,' (Constraint energy)'/ \r
1077      & 'ETOT=  ',1pE16.6,' (total)')\r
1078 #else\r
1079       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,\r
1080      &  estr,wbond,ebe,wang,\r
1081      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,\r
1082      &  ecorr,wcorr,\r
1083      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,\r
1084      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,\r
1085      &  ebr*nss,Uconst,etot\r
1086    10 format (/'Virtual-chain energies:'//\r
1087      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/\r
1088      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/\r
1089      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/\r
1090      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/\r
1091      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/\r
1092      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/\r
1093      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/\r
1094      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/\r
1095      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,\r
1096      & ' (SS bridges & dist. cnstr.)'/\r
1097      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/\r
1098      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/\r
1099      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/\r
1100      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/\r
1101      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/\r
1102      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/\r
1103      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/\r
1104      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/\r
1105      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/\r
1106      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/\r
1107      & 'UCONST=',1pE16.6,' (Constraint energy)'/ \r
1108      & 'ETOT=  ',1pE16.6,' (total)')\r
1109 #endif\r
1110       return\r
1111       end\r
1112 \r
1113 \r
1114 C-----------------------------------------------------------------------\r
1115 \r
1116 \r
1117       subroutine elj(evdw,evdw_p,evdw_m)\r
1118 C\r
1119 C This subroutine calculates the interaction energy of nonbonded side chains\r
1120 C assuming the LJ potential of interaction.\r
1121 C\r
1122       implicit real*8 (a-h,o-z)\r
1123       include 'DIMENSIONS'\r
1124       parameter (accur=1.0d-10)\r
1125       include 'COMMON.GEO'\r
1126       include 'COMMON.VAR'\r
1127       include 'COMMON.LOCAL'\r
1128       include 'COMMON.CHAIN'\r
1129       include 'COMMON.DERIV'\r
1130       include 'COMMON.INTERACT'\r
1131       include 'COMMON.TORSION'\r
1132       include 'COMMON.SBRIDGE'\r
1133       include 'COMMON.NAMES'\r
1134       include 'COMMON.IOUNITS'\r
1135       include 'COMMON.CONTACTS'\r
1136       dimension gg(3)\r
1137 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon\r
1138       evdw=0.0D0\r
1139       do i=iatsc_s,iatsc_e\r
1140         itypi=itype(i)\r
1141         itypi1=itype(i+1)\r
1142         xi=c(1,nres+i)\r
1143         yi=c(2,nres+i)\r
1144         zi=c(3,nres+i)\r
1145 C Change 12/1/95\r
1146         num_conti=0\r
1147 C\r
1148 C Calculate SC interaction energy.\r
1149 C\r
1150         do iint=1,nint_gr(i)\r
1151 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),\r
1152 cd   &                  'iend=',iend(i,iint)\r
1153           do j=istart(i,iint),iend(i,iint)\r
1154             itypj=itype(j)\r
1155             xj=c(1,nres+j)-xi\r
1156             yj=c(2,nres+j)-yi\r
1157             zj=c(3,nres+j)-zi\r
1158 C Change 12/1/95 to calculate four-body interactions\r
1159             rij=xj*xj+yj*yj+zj*zj\r
1160             rrij=1.0D0/rij\r
1161 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj\r
1162             eps0ij=eps(itypi,itypj)\r
1163             fac=rrij**expon2\r
1164             e1=fac*fac*aa(itypi,itypj)\r
1165             e2=fac*bb(itypi,itypj)\r
1166             evdwij=e1+e2\r
1167 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)\r
1168 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)\r
1169 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')\r
1170 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),\r
1171 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,\r
1172 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)\r
1173 #ifdef TSCSC\r
1174             if (bb(itypi,itypj).gt.0) then\r
1175                evdw_p=evdw_p+evdwij\r
1176             else\r
1177                evdw_m=evdw_m+evdwij\r
1178             endif\r
1179 #else\r
1180             evdw=evdw+evdwij\r
1181 #endif\r
1182 C \r
1183 C Calculate the components of the gradient in DC and X\r
1184 C\r
1185             fac=-rrij*(e1+evdwij)\r
1186             gg(1)=xj*fac\r
1187             gg(2)=yj*fac\r
1188             gg(3)=zj*fac\r
1189 #ifdef TSCSC\r
1190             if (bb(itypi,itypj).gt.0.0d0) then\r
1191               do k=1,3\r
1192                 gvdwx(k,i)=gvdwx(k,i)-gg(k)\r
1193                 gvdwx(k,j)=gvdwx(k,j)+gg(k)\r
1194                 gvdwc(k,i)=gvdwc(k,i)-gg(k)\r
1195                 gvdwc(k,j)=gvdwc(k,j)+gg(k)\r
1196               enddo\r
1197             else\r
1198               do k=1,3\r
1199                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)\r
1200                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)\r
1201                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)\r
1202                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)\r
1203               enddo\r
1204             endif\r
1205 #else\r
1206             do k=1,3\r
1207               gvdwx(k,i)=gvdwx(k,i)-gg(k)\r
1208               gvdwx(k,j)=gvdwx(k,j)+gg(k)\r
1209               gvdwc(k,i)=gvdwc(k,i)-gg(k)\r
1210               gvdwc(k,j)=gvdwc(k,j)+gg(k)\r
1211             enddo\r
1212 #endif\r
1213 cgrad            do k=i,j-1\r
1214 cgrad              do l=1,3\r
1215 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)\r
1216 cgrad              enddo\r
1217 cgrad            enddo\r
1218 C\r
1219 C 12/1/95, revised on 5/20/97\r
1220 C\r
1221 C Calculate the contact function. The ith column of the array JCONT will \r
1222 C contain the numbers of atoms that make contacts with the atom I (of numbers\r
1223 C greater than I). The arrays FACONT and GACONT will contain the values of\r
1224 C the contact function and its derivative.\r
1225 C\r
1226 C Uncomment next line, if the correlation interactions include EVDW explicitly.\r
1227 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then\r
1228 C Uncomment next line, if the correlation interactions are contact function only\r
1229             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then\r
1230               rij=dsqrt(rij)\r
1231               sigij=sigma(itypi,itypj)\r
1232               r0ij=rs0(itypi,itypj)\r
1233 C\r
1234 C Check whether the SC's are not too far to make a contact.\r
1235 C\r
1236               rcut=1.5d0*r0ij\r
1237               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)\r
1238 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).\r
1239 C\r
1240               if (fcont.gt.0.0D0) then\r
1241 C If the SC-SC distance if close to sigma, apply spline.\r
1242 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,\r
1243 cAdam &             fcont1,fprimcont1)\r
1244 cAdam           fcont1=1.0d0-fcont1\r
1245 cAdam           if (fcont1.gt.0.0d0) then\r
1246 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1\r
1247 cAdam             fcont=fcont*fcont1\r
1248 cAdam           endif\r
1249 C Uncomment following 4 lines to have the geometric average of the epsilon0's\r
1250 cga             eps0ij=1.0d0/dsqrt(eps0ij)\r
1251 cga             do k=1,3\r
1252 cga               gg(k)=gg(k)*eps0ij\r
1253 cga             enddo\r
1254 cga             eps0ij=-evdwij*eps0ij\r
1255 C Uncomment for AL's type of SC correlation interactions.\r
1256 cadam           eps0ij=-evdwij\r
1257                 num_conti=num_conti+1\r
1258                 jcont(num_conti,i)=j\r
1259                 facont(num_conti,i)=fcont*eps0ij\r
1260                 fprimcont=eps0ij*fprimcont/rij\r
1261                 fcont=expon*fcont\r
1262 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)\r
1263 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)\r
1264 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)\r
1265 C Uncomment following 3 lines for Skolnick's type of SC correlation.\r
1266                 gacont(1,num_conti,i)=-fprimcont*xj\r
1267                 gacont(2,num_conti,i)=-fprimcont*yj\r
1268                 gacont(3,num_conti,i)=-fprimcont*zj\r
1269 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)\r
1270 cd              write (iout,'(2i3,3f10.5)') \r
1271 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)\r
1272               endif\r
1273             endif\r
1274           enddo\r
1275 c! j\r
1276         enddo\r
1277 c! iint\r
1278 C Change 12/1/95\r
1279         num_cont(i)=num_conti\r
1280       enddo          ! i\r
1281       do i=1,nct\r
1282         do j=1,3\r
1283           gvdwc(j,i)=expon*gvdwc(j,i)\r
1284           gvdwx(j,i)=expon*gvdwx(j,i)\r
1285         enddo\r
1286       enddo\r
1287 C******************************************************************************\r
1288 C\r
1289 C                              N O T E !!!\r
1290 C\r
1291 C To save time, the factor of EXPON has been extracted from ALL components\r
1292 C of GVDWC and GRADX. Remember to multiply them by this factor before further \r
1293 C use!\r
1294 C\r
1295 C******************************************************************************\r
1296       return\r
1297       end\r
1298 \r
1299 \r
1300 C-----------------------------------------------------------------------------\r
1301 \r
1302 \r
1303       subroutine eljk(evdw,evdw_p,evdw_m)\r
1304 C\r
1305 C This subroutine calculates the interaction energy of nonbonded side chains\r
1306 C assuming the LJK potential of interaction.\r
1307 C\r
1308       implicit real*8 (a-h,o-z)\r
1309       include 'DIMENSIONS'\r
1310       include 'COMMON.GEO'\r
1311       include 'COMMON.VAR'\r
1312       include 'COMMON.LOCAL'\r
1313       include 'COMMON.CHAIN'\r
1314       include 'COMMON.DERIV'\r
1315       include 'COMMON.INTERACT'\r
1316       include 'COMMON.IOUNITS'\r
1317       include 'COMMON.NAMES'\r
1318       dimension gg(3)\r
1319       logical scheck\r
1320 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon\r
1321       evdw=0.0D0\r
1322       do i=iatsc_s,iatsc_e\r
1323         itypi=itype(i)\r
1324         itypi1=itype(i+1)\r
1325         xi=c(1,nres+i)\r
1326         yi=c(2,nres+i)\r
1327         zi=c(3,nres+i)\r
1328 C\r
1329 C Calculate SC interaction energy.\r
1330 C\r
1331         do iint=1,nint_gr(i)\r
1332           do j=istart(i,iint),iend(i,iint)\r
1333             itypj=itype(j)\r
1334             xj=c(1,nres+j)-xi\r
1335             yj=c(2,nres+j)-yi\r
1336             zj=c(3,nres+j)-zi\r
1337             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)\r
1338             fac_augm=rrij**expon\r
1339             e_augm=augm(itypi,itypj)*fac_augm\r
1340             r_inv_ij=dsqrt(rrij)\r
1341             rij=1.0D0/r_inv_ij \r
1342             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))\r
1343             fac=r_shift_inv**expon\r
1344             e1=fac*fac*aa(itypi,itypj)\r
1345             e2=fac*bb(itypi,itypj)\r
1346             evdwij=e_augm+e1+e2\r
1347 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)\r
1348 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)\r
1349 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')\r
1350 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),\r
1351 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,\r
1352 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,\r
1353 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)\r
1354 #ifdef TSCSC\r
1355             if (bb(itypi,itypj).gt.0) then\r
1356                evdw_p=evdw_p+evdwij\r
1357             else\r
1358                evdw_m=evdw_m+evdwij\r
1359             endif\r
1360 #else\r
1361             evdw=evdw+evdwij\r
1362 #endif\r
1363 C \r
1364 C Calculate the components of the gradient in DC and X\r
1365 C\r
1366             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)\r
1367             gg(1)=xj*fac\r
1368             gg(2)=yj*fac\r
1369             gg(3)=zj*fac\r
1370 #ifdef TSCSC\r
1371             if (bb(itypi,itypj).gt.0.0d0) then\r
1372               do k=1,3\r
1373                 gvdwx(k,i)=gvdwx(k,i)-gg(k)\r
1374                 gvdwx(k,j)=gvdwx(k,j)+gg(k)\r
1375                 gvdwc(k,i)=gvdwc(k,i)-gg(k)\r
1376                 gvdwc(k,j)=gvdwc(k,j)+gg(k)\r
1377               enddo\r
1378             else\r
1379               do k=1,3\r
1380                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)\r
1381                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)\r
1382                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)\r
1383                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)\r
1384               enddo\r
1385             endif\r
1386 #else\r
1387             do k=1,3\r
1388               gvdwx(k,i)=gvdwx(k,i)-gg(k)\r
1389               gvdwx(k,j)=gvdwx(k,j)+gg(k)\r
1390               gvdwc(k,i)=gvdwc(k,i)-gg(k)\r
1391               gvdwc(k,j)=gvdwc(k,j)+gg(k)\r
1392             enddo\r
1393 #endif\r
1394 cgrad            do k=i,j-1\r
1395 cgrad              do l=1,3\r
1396 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)\r
1397 cgrad              enddo\r
1398 cgrad            enddo\r
1399           enddo      ! j\r
1400         enddo        ! iint\r
1401       enddo          ! i\r
1402       do i=1,nct\r
1403         do j=1,3\r
1404           gvdwc(j,i)=expon*gvdwc(j,i)\r
1405           gvdwx(j,i)=expon*gvdwx(j,i)\r
1406         enddo\r
1407       enddo\r
1408       return\r
1409       end\r
1410 \r
1411 \r
1412 C-----------------------------------------------------------------------------\r
1413 \r
1414 \r
1415       subroutine ebp(evdw,evdw_p,evdw_m)\r
1416 C\r
1417 C This subroutine calculates the interaction energy of nonbonded side chains\r
1418 C assuming the Berne-Pechukas potential of interaction.\r
1419 C\r
1420       implicit real*8 (a-h,o-z)\r
1421       include 'DIMENSIONS'\r
1422       include 'COMMON.GEO'\r
1423       include 'COMMON.VAR'\r
1424       include 'COMMON.LOCAL'\r
1425       include 'COMMON.CHAIN'\r
1426       include 'COMMON.DERIV'\r
1427       include 'COMMON.NAMES'\r
1428       include 'COMMON.INTERACT'\r
1429       include 'COMMON.IOUNITS'\r
1430       include 'COMMON.CALC'\r
1431       common /srutu/ icall\r
1432 c     double precision rrsave(maxdim)\r
1433       logical lprn\r
1434       evdw=0.0D0\r
1435 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon\r
1436 c      evdw=0.0D0\r
1437 c     if (icall.eq.0) then\r
1438 c       lprn=.true.\r
1439 c     else\r
1440         lprn=.false.\r
1441 c     endif\r
1442       ind=0\r
1443       do i=iatsc_s,iatsc_e\r
1444         itypi=itype(i)\r
1445         itypi1=itype(i+1)\r
1446         xi=c(1,nres+i)\r
1447         yi=c(2,nres+i)\r
1448         zi=c(3,nres+i)\r
1449         dxi=dc_norm(1,nres+i)\r
1450         dyi=dc_norm(2,nres+i)\r
1451         dzi=dc_norm(3,nres+i)\r
1452 c        dsci_inv=dsc_inv(itypi)\r
1453         dsci_inv=vbld_inv(i+nres)\r
1454 C\r
1455 C Calculate SC interaction energy.\r
1456 C\r
1457         do iint=1,nint_gr(i)\r
1458           do j=istart(i,iint),iend(i,iint)\r
1459             ind=ind+1\r
1460             itypj=itype(j)\r
1461 c            dscj_inv=dsc_inv(itypj)\r
1462             dscj_inv=vbld_inv(j+nres)\r
1463             chi1=chi(itypi,itypj)\r
1464             chi2=chi(itypj,itypi)\r
1465             chi12=chi1*chi2\r
1466             chip1=chip(itypi)\r
1467             chip2=chip(itypj)\r
1468             chip12=chip1*chip2\r
1469             alf1=alp(itypi)\r
1470             alf2=alp(itypj)\r
1471             alf12=0.5D0*(alf1+alf2)\r
1472 C For diagnostics only!!!\r
1473 c           chi1=0.0D0\r
1474 c           chi2=0.0D0\r
1475 c           chi12=0.0D0\r
1476 c           chip1=0.0D0\r
1477 c           chip2=0.0D0\r
1478 c           chip12=0.0D0\r
1479 c           alf1=0.0D0\r
1480 c           alf2=0.0D0\r
1481 c           alf12=0.0D0\r
1482             xj=c(1,nres+j)-xi\r
1483             yj=c(2,nres+j)-yi\r
1484             zj=c(3,nres+j)-zi\r
1485             dxj=dc_norm(1,nres+j)\r
1486             dyj=dc_norm(2,nres+j)\r
1487             dzj=dc_norm(3,nres+j)\r
1488             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)\r
1489 cd          if (icall.eq.0) then\r
1490 cd            rrsave(ind)=rrij\r
1491 cd          else\r
1492 cd            rrij=rrsave(ind)\r
1493 cd          endif\r
1494             rij=dsqrt(rrij)\r
1495 C Calculate the angle-dependent terms of energy & contributions to derivatives.\r
1496             call sc_angular\r
1497 C Calculate whole angle-dependent part of epsilon and contributions\r
1498 C to its derivatives\r
1499             fac=(rrij*sigsq)**expon2\r
1500             e1=fac*fac*aa(itypi,itypj)\r
1501             e2=fac*bb(itypi,itypj)\r
1502             evdwij=eps1*eps2rt*eps3rt*(e1+e2)\r
1503             eps2der=evdwij*eps3rt\r
1504             eps3der=evdwij*eps2rt\r
1505             evdwij=evdwij*eps2rt*eps3rt\r
1506 #ifdef TSCSC\r
1507             if (bb(itypi,itypj).gt.0) then\r
1508                evdw_p=evdw_p+evdwij\r
1509             else\r
1510                evdw_m=evdw_m+evdwij\r
1511             endif\r
1512 #else\r
1513             evdw=evdw+evdwij\r
1514 #endif\r
1515             if (lprn) then\r
1516             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)\r
1517             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)\r
1518 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')\r
1519 cd     &        restyp(itypi),i,restyp(itypj),j,\r
1520 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,\r
1521 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),\r
1522 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),\r
1523 cd     &        evdwij\r
1524             endif\r
1525 C Calculate gradient components.\r
1526             e1=e1*eps1*eps2rt**2*eps3rt**2\r
1527             fac=-expon*(e1+evdwij)\r
1528             sigder=fac/sigsq\r
1529             fac=rrij*fac\r
1530 C Calculate radial part of the gradient\r
1531             gg(1)=xj*fac\r
1532             gg(2)=yj*fac\r
1533             gg(3)=zj*fac\r
1534 C Calculate the angular part of the gradient and sum add the contributions\r
1535 C to the appropriate components of the Cartesian gradient.\r
1536 #ifdef TSCSC\r
1537             if (bb(itypi,itypj).gt.0) then\r
1538                call sc_grad\r
1539             else\r
1540                call sc_grad_T\r
1541             endif\r
1542 #else\r
1543             call sc_grad\r
1544 #endif\r
1545           enddo      ! j\r
1546         enddo        ! iint\r
1547       enddo          ! i\r
1548 c     stop\r
1549       return\r
1550       end\r
1551 \r
1552 \r
1553 C-----------------------------------------------------------------------------\r
1554 \r
1555 \r
1556       SUBROUTINE egb(evdw,evdw_p,evdw_m)\r
1557 C\r
1558 C This subroutine calculates the interaction energy of nonbonded side chains\r
1559 C assuming the Gay-Berne potential of interaction.\r
1560 C\r
1561       implicit real*8 (a-h,o-z)\r
1562       include 'DIMENSIONS'\r
1563       include 'COMMON.GEO'\r
1564       include 'COMMON.VAR'\r
1565       include 'COMMON.LOCAL'\r
1566       include 'COMMON.CHAIN'\r
1567       include 'COMMON.DERIV'\r
1568       include 'COMMON.NAMES'\r
1569       include 'COMMON.INTERACT'\r
1570       include 'COMMON.IOUNITS'\r
1571       include 'COMMON.CALC'\r
1572       include 'COMMON.CONTROL'\r
1573       logical lprn\r
1574       evdw=0.0D0\r
1575 ccccc      energy_dec=.false.\r
1576 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon\r
1577 c      evdw=0.0D0\r
1578       evdw_p=0.0D0\r
1579       evdw_m=0.0D0\r
1580       lprn=.false.\r
1581 c     if (icall.eq.0) lprn=.false.\r
1582       ind=0\r
1583       do i=iatsc_s,iatsc_e\r
1584         itypi=itype(i)\r
1585         itypi1=itype(i+1)\r
1586         xi=c(1,nres+i)\r
1587         yi=c(2,nres+i)\r
1588         zi=c(3,nres+i)\r
1589         dxi=dc_norm(1,nres+i)\r
1590         dyi=dc_norm(2,nres+i)\r
1591         dzi=dc_norm(3,nres+i)\r
1592 c        dsci_inv=dsc_inv(itypi)\r
1593         dsci_inv=vbld_inv(i+nres)\r
1594 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)\r
1595 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi\r
1596 C\r
1597 C Calculate SC interaction energy.\r
1598 C\r
1599         do iint=1,nint_gr(i)\r
1600           do j=istart(i,iint),iend(i,iint)\r
1601             ind=ind+1\r
1602             itypj=itype(j)\r
1603 c            dscj_inv=dsc_inv(itypj)\r
1604             dscj_inv=vbld_inv(j+nres)\r
1605 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,\r
1606 c     &       1.0d0/vbld(j+nres)\r
1607 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)\r
1608             sig0ij=sigma(itypi,itypj)\r
1609             chi1=chi(itypi,itypj)\r
1610             chi2=chi(itypj,itypi)\r
1611             chi12=chi1*chi2\r
1612             chip1=chip(itypi)\r
1613             chip2=chip(itypj)\r
1614             chip12=chip1*chip2\r
1615             alf1=alp(itypi)\r
1616             alf2=alp(itypj)\r
1617             alf12=0.5D0*(alf1+alf2)\r
1618 C For diagnostics only!!!\r
1619 c           chi1=0.0D0\r
1620 c           chi2=0.0D0\r
1621 c           chi12=0.0D0\r
1622 c           chip1=0.0D0\r
1623 c           chip2=0.0D0\r
1624 c           chip12=0.0D0\r
1625 c           alf1=0.0D0\r
1626 c           alf2=0.0D0\r
1627 c           alf12=0.0D0\r
1628             xj=c(1,nres+j)-xi\r
1629             yj=c(2,nres+j)-yi\r
1630             zj=c(3,nres+j)-zi\r
1631             dxj=dc_norm(1,nres+j)\r
1632             dyj=dc_norm(2,nres+j)\r
1633             dzj=dc_norm(3,nres+j)\r
1634 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi\r
1635 c            write (iout,*) "j",j," dc_norm",\r
1636 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)\r
1637             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)\r
1638             rij=dsqrt(rrij)\r
1639 c---------------------------------------------------------------\r
1640 C Calculate angle-dependent terms of energy and contributions to their\r
1641 C derivatives.\r
1642             call sc_angular\r
1643             sigsq=1.0D0/sigsq\r
1644             sig=sig0ij*dsqrt(sigsq)\r
1645             rij_shift=1.0D0/rij-sig+sig0ij\r
1646 c for diagnostics; uncomment\r
1647 c            rij_shift=1.2*sig0ij\r
1648 C I hate to put IF's in the loops, but here don't have another choice!!!!\r
1649             if (rij_shift.le.0.0D0) then\r
1650               evdw=1.0D20\r
1651 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')\r
1652 cd     &        restyp(itypi),i,restyp(itypj),j,\r
1653 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq) \r
1654               return\r
1655             endif\r
1656             sigder=-sig*sigsq\r
1657 c---------------------------------------------------------------\r
1658             rij_shift=1.0D0/rij_shift \r
1659             fac=rij_shift**expon\r
1660             e1=fac*fac*aa(itypi,itypj)\r
1661             e2=fac*bb(itypi,itypj)\r
1662             evdwij=eps1*eps2rt*eps3rt*(e1+e2)\r
1663             eps2der=evdwij*eps3rt\r
1664             eps3der=evdwij*eps2rt\r
1665 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,\r
1666 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2\r
1667             evdwij=evdwij*eps2rt*eps3rt\r
1668 #ifdef TSCSC\r
1669             if (bb(itypi,itypj).gt.0) then\r
1670                evdw_p=evdw_p+evdwij\r
1671             else\r
1672                evdw_m=evdw_m+evdwij\r
1673             endif\r
1674 #else\r
1675             evdw=evdw+evdwij\r
1676 #endif\r
1677             if (lprn) then\r
1678             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)\r
1679             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)\r
1680             write (iout,'(2(a3,i3,2x),17(0pf7.3))')\r
1681      &        restyp(itypi),i,restyp(itypj),j,\r
1682      &        epsi,sigm,chi1,chi2,chip1,chip2,\r
1683      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,\r
1684      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,\r
1685      &        evdwij\r
1686             endif\r
1687             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') \r
1688      &                        'evdw',i,j,evdwij\r
1689 C Calculate gradient components.\r
1690             e1=e1*eps1*eps2rt**2*eps3rt**2\r
1691             fac=-expon*(e1+evdwij)*rij_shift\r
1692             sigder = fac * sigder\r
1693             fac    = rij * fac\r
1694 c            fac=0.0d0\r
1695 C Calculate the radial part of the gradient\r
1696             gg(1) = xj * fac\r
1697             gg(2) = yj * fac\r
1698             gg(3) = zj * fac\r
1699 C Calculate angular part of the gradient.\r
1700 #ifdef TSCSC\r
1701             if (bb(itypi,itypj).gt.0) then\r
1702                call sc_grad\r
1703             else\r
1704                call sc_grad_T\r
1705             endif\r
1706 #else\r
1707             call sc_grad\r
1708 #endif\r
1709           enddo      ! j\r
1710         enddo        ! iint\r
1711       enddo          ! i\r
1712 c      write (iout,*) "Number of loop steps in EGB:",ind\r
1713 cccc      energy_dec=.false.\r
1714       return\r
1715       end\r
1716 \r
1717 \r
1718 C-----------------------------------------------------------------------------\r
1719 \r
1720 \r
1721       subroutine egbv(evdw,evdw_p,evdw_m)\r
1722 C\r
1723 C This subroutine calculates the interaction energy of nonbonded side chains\r
1724 C assuming the Gay-Berne-Vorobjev potential of interaction.\r
1725 C\r
1726       implicit real*8 (a-h,o-z)\r
1727       include 'DIMENSIONS'\r
1728       include 'COMMON.GEO'\r
1729       include 'COMMON.VAR'\r
1730       include 'COMMON.LOCAL'\r
1731       include 'COMMON.CHAIN'\r
1732       include 'COMMON.DERIV'\r
1733       include 'COMMON.NAMES'\r
1734       include 'COMMON.INTERACT'\r
1735       include 'COMMON.IOUNITS'\r
1736       include 'COMMON.CALC'\r
1737       common /srutu/ icall\r
1738       logical lprn\r
1739       evdw=0.0D0\r
1740 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon\r
1741 c      evdw=0.0D0\r
1742       lprn=.false.\r
1743 c     if (icall.eq.0) lprn=.true.\r
1744       ind=0\r
1745       do i=iatsc_s,iatsc_e\r
1746         itypi=itype(i)\r
1747         itypi1=itype(i+1)\r
1748         xi=c(1,nres+i)\r
1749         yi=c(2,nres+i)\r
1750         zi=c(3,nres+i)\r
1751         dxi=dc_norm(1,nres+i)\r
1752         dyi=dc_norm(2,nres+i)\r
1753         dzi=dc_norm(3,nres+i)\r
1754 c        dsci_inv=dsc_inv(itypi)\r
1755         dsci_inv=vbld_inv(i+nres)\r
1756 C\r
1757 C Calculate SC interaction energy.\r
1758 C\r
1759         do iint=1,nint_gr(i)\r
1760           do j=istart(i,iint),iend(i,iint)\r
1761             ind=ind+1\r
1762             itypj=itype(j)\r
1763 c            dscj_inv=dsc_inv(itypj)\r
1764             dscj_inv=vbld_inv(j+nres)\r
1765             sig0ij=sigma(itypi,itypj)\r
1766             r0ij=r0(itypi,itypj)\r
1767             chi1=chi(itypi,itypj)\r
1768             chi2=chi(itypj,itypi)\r
1769             chi12=chi1*chi2\r
1770             chip1=chip(itypi)\r
1771             chip2=chip(itypj)\r
1772             chip12=chip1*chip2\r
1773             alf1=alp(itypi)\r
1774             alf2=alp(itypj)\r
1775             alf12=0.5D0*(alf1+alf2)\r
1776 C For diagnostics only!!!\r
1777 c           chi1=0.0D0\r
1778 c           chi2=0.0D0\r
1779 c           chi12=0.0D0\r
1780 c           chip1=0.0D0\r
1781 c           chip2=0.0D0\r
1782 c           chip12=0.0D0\r
1783 c           alf1=0.0D0\r
1784 c           alf2=0.0D0\r
1785 c           alf12=0.0D0\r
1786             xj=c(1,nres+j)-xi\r
1787             yj=c(2,nres+j)-yi\r
1788             zj=c(3,nres+j)-zi\r
1789             dxj=dc_norm(1,nres+j)\r
1790             dyj=dc_norm(2,nres+j)\r
1791             dzj=dc_norm(3,nres+j)\r
1792             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)\r
1793             rij=dsqrt(rrij)\r
1794 C Calculate angle-dependent terms of energy and contributions to their\r
1795 C derivatives.\r
1796             call sc_angular\r
1797             sigsq=1.0D0/sigsq\r
1798             sig=sig0ij*dsqrt(sigsq)\r
1799             rij_shift=1.0D0/rij-sig+r0ij\r
1800 C I hate to put IF's in the loops, but here don't have another choice!!!!\r
1801             if (rij_shift.le.0.0D0) then\r
1802               evdw=1.0D20\r
1803               return\r
1804             endif\r
1805             sigder=-sig*sigsq\r
1806 c---------------------------------------------------------------\r
1807             rij_shift=1.0D0/rij_shift \r
1808             fac=rij_shift**expon\r
1809             e1=fac*fac*aa(itypi,itypj)\r
1810             e2=fac*bb(itypi,itypj)\r
1811             evdwij=eps1*eps2rt*eps3rt*(e1+e2)\r
1812             eps2der=evdwij*eps3rt\r
1813             eps3der=evdwij*eps2rt\r
1814             fac_augm=rrij**expon\r
1815             e_augm=augm(itypi,itypj)*fac_augm\r
1816             evdwij=evdwij*eps2rt*eps3rt\r
1817 #ifdef TSCSC\r
1818             if (bb(itypi,itypj).gt.0) then\r
1819                evdw_p=evdw_p+evdwij+e_augm\r
1820             else\r
1821                evdw_m=evdw_m+evdwij+e_augm\r
1822             endif\r
1823 #else\r
1824             evdw=evdw+evdwij+e_augm\r
1825 #endif\r
1826             if (lprn) then\r
1827             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)\r
1828             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)\r
1829             write (iout,'(2(a3,i3,2x),17(0pf7.3))')\r
1830      &        restyp(itypi),i,restyp(itypj),j,\r
1831      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),\r
1832      &        chi1,chi2,chip1,chip2,\r
1833      &        eps1,eps2rt**2,eps3rt**2,\r
1834      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,\r
1835      &        evdwij+e_augm\r
1836             endif\r
1837 C Calculate gradient components.\r
1838             e1=e1*eps1*eps2rt**2*eps3rt**2\r
1839             fac=-expon*(e1+evdwij)*rij_shift\r
1840             sigder=fac*sigder\r
1841             fac=rij*fac-2*expon*rrij*e_augm\r
1842 C Calculate the radial part of the gradient\r
1843             gg(1)=xj*fac\r
1844             gg(2)=yj*fac\r
1845             gg(3)=zj*fac\r
1846 C Calculate angular part of the gradient.\r
1847 #ifdef TSCSC\r
1848             if (bb(itypi,itypj).gt.0) then\r
1849                call sc_grad\r
1850             else\r
1851                call sc_grad_T\r
1852             endif\r
1853 #else\r
1854             call sc_grad\r
1855 #endif\r
1856           enddo      ! j\r
1857         enddo        ! iint\r
1858       enddo          ! i\r
1859       end\r
1860 \r
1861 \r
1862 C-----------------------------------------------------------------------------\r
1863 \r
1864 \r
1865       SUBROUTINE emomo(evdw,evdw_p,evdw_m)\r
1866 C\r
1867 C This subroutine calculates the interaction energy of nonbonded side chains\r
1868 C assuming the Gay-Berne potential of interaction.\r
1869 C\r
1870        IMPLICIT NONE\r
1871        INCLUDE 'DIMENSIONS'\r
1872        INCLUDE 'COMMON.CALC'\r
1873        INCLUDE 'COMMON.CONTROL'\r
1874        INCLUDE 'COMMON.CHAIN'\r
1875        INCLUDE 'COMMON.DERIV'\r
1876        INCLUDE 'COMMON.EMP'\r
1877        INCLUDE 'COMMON.GEO'\r
1878        INCLUDE 'COMMON.INTERACT'\r
1879        INCLUDE 'COMMON.IOUNITS'\r
1880        INCLUDE 'COMMON.LOCAL'\r
1881        INCLUDE 'COMMON.NAMES'\r
1882        INCLUDE 'COMMON.VAR'\r
1883        logical lprn\r
1884        double precision scalar\r
1885        double precision ener(4)\r
1886        evdw   = 0.0D0\r
1887        evdw_p = 0.0D0\r
1888        evdw_m = 0.0D0\r
1889 c DIAGNOSTICS\r
1890 ccccc      energy_dec=.false.\r
1891 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon\r
1892 c      lprn   = .false.\r
1893 c     if (icall.eq.0) lprn=.false.\r
1894 c END DIAGNOSTICS\r
1895 c      ind = 0\r
1896        DO i = iatsc_s, iatsc_e\r
1897         itypi  = itype(i)\r
1898 c        itypi1 = itype(i+1)\r
1899         dxi    = dc_norm(1,nres+i)\r
1900         dyi    = dc_norm(2,nres+i)\r
1901         dzi    = dc_norm(3,nres+i)\r
1902 c        dsci_inv=dsc_inv(itypi)\r
1903         dsci_inv = vbld_inv(i+nres)\r
1904 c! This small loop calculates hydrophobic centre location\r
1905 c! by taking Calpha location and moving by appropriate\r
1906 c! vector built by dtail * dc_norm\r
1907         DO k = 1, 3\r
1908          ctail(k,1) = c(k, i+nres)\r
1909      &              - dtail(k, itypi) * dc_norm(k, nres+i)\r
1910         END DO\r
1911         xi=c(1,nres+i)\r
1912         yi=c(2,nres+i)\r
1913         zi=c(3,nres+i)\r
1914 c!-------------------------------------------------------------------\r
1915 C Calculate SC interaction energy.\r
1916         DO iint = 1, nint_gr(i)\r
1917          DO j = istart(i,iint), iend(i,iint)\r
1918 c! initialize variables for electrostatic gradients\r
1919           CALL elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)\r
1920 c            ind=ind+1\r
1921 c            dscj_inv = dsc_inv(itypj)\r
1922           dscj_inv = vbld_inv(j+nres)\r
1923 c! rij holds 1/(distance of Calpha atoms)\r
1924           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)\r
1925           rij  = dsqrt(rrij)\r
1926 c!-------------------------------------------------------------------\r
1927 C Calculate angle-dependent terms of energy and contributions to their\r
1928 C derivatives.\r
1929           CALL sc_angular\r
1930 c! this should be in elgrad_init but om's are calculated by sc_angular\r
1931 c! which in turn is used by older potentials\r
1932 c! which proves how tangled UNRES code is >.<\r
1933 c! om = omega, sqom = om^2\r
1934           sqom1  = om1 * om1\r
1935           sqom2  = om2 * om2\r
1936           sqom12 = om12 * om12\r
1937 c! now we calculate FGB - Gey-Berne Force.\r
1938 c! It will be summed up in evdwij and saved in evdw\r
1939           sigsq     = 1.0D0  / sigsq\r
1940           sig       = sig0ij * dsqrt(sigsq)\r
1941           rij_shift = 1.0D0  / rij - sig + sig0ij\r
1942           IF (rij_shift.le.0.0D0) THEN\r
1943            evdw = 1.0D20\r
1944            RETURN\r
1945           END IF\r
1946           sigder = -sig * sigsq\r
1947           rij_shift = 1.0D0 / rij_shift \r
1948           fac       = rij_shift**expon\r
1949           c1        = fac  * fac * aa(itypi,itypj)\r
1950           c2        = fac  * bb(itypi,itypj)\r
1951           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )\r
1952           eps2der   = evdwij * eps3rt\r
1953           eps3der   = evdwij * eps2rt\r
1954           evdwij    = evdwij * eps2rt * eps3rt\r
1955 #ifdef TSCSC\r
1956           IF (bb(itypi,itypj).gt.0) THEN\r
1957            evdw_p = evdw_p + evdwij\r
1958           ELSE\r
1959            evdw_m = evdw_m + evdwij\r
1960           END IF\r
1961 #else\r
1962           evdw = evdw\r
1963      &         + evdwij\r
1964 #endif\r
1965 c!-------------------------------------------------------------------\r
1966 c! Calculate some components of GGB and EGB\r
1967           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2\r
1968           fac    = -expon * (c1 + evdwij) * rij_shift\r
1969           sigder = fac * sigder\r
1970           fac    = rij * fac\r
1971 c!         fac = 0.0d0\r
1972 c! Calculate the radial part of GGB\r
1973           gg(1) = xj * fac\r
1974           gg(2) = yj * fac\r
1975           gg(3) = zj * fac\r
1976 \r
1977 c! The angular derivatives of GGB are brought together in sc_grad\r
1978 c!-------------------------------------------------------------------\r
1979 c! Fcav\r
1980 c!\r
1981 c! Catch gly-gly interactions to skip calculation of something that\r
1982 c! does not exist\r
1983 \r
1984       IF (itypi.eq.10.and.itypj.eq.10) THEN\r
1985        Fcav = 0.0d0\r
1986        dFdR = 0.0d0\r
1987        dCAVdOM1  = 0.0d0\r
1988        dCAVdOM2  = 0.0d0\r
1989        dCAVdOM12 = 0.0d0\r
1990       ELSE\r
1991 \r
1992 c! we are not 2 glycines, so we calculate Fcav\r
1993        fac = chis1 * sqom1 + chis2 * sqom2\r
1994      &     - 2.0d0 * chis12 * om1 * om2 * om12\r
1995 c! we will use pom later in Gcav, so dont mess with it!\r
1996        pom = 1.0d0 - chis1 * chis2 * sqom12\r
1997 \r
1998        Lambf = (1.0d0 - (fac / pom))\r
1999        Lambf = dsqrt(Lambf)\r
2000 \r
2001        sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)\r
2002        Chif = Rtail * sparrow\r
2003        ChiLambf = Chif * Lambf\r
2004        eagle = dsqrt(ChiLambf)\r
2005        bat = ChiLambf ** 11.0d0\r
2006 \r
2007        top = b1 * ( eagle + b2 * ChiLambf - b3 )\r
2008        bot = 1.0d0 + b4 * (ChiLambf * bat)\r
2009        botsq = bot * bot\r
2010 \r
2011        Fcav = top / bot\r
2012 \r
2013 c!-------------------------------------------------------------------\r
2014 c! derivative of Fcav is Gcav...\r
2015 c!---------------------------------------------------\r
2016 \r
2017        dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))\r
2018        dbot = 12.0d0 * b4 * bat * Lambf\r
2019        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow\r
2020 \r
2021        dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))\r
2022        dbot = 12.0d0 * b4 * bat * Chif\r
2023        eagle = Lambf * pom\r
2024        dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)\r
2025        dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)\r
2026        dFdOM12 = chis12 * (chis1 * om1 * om12 - om2)\r
2027      &         * (chis2 * om2 * om12 - om1) / (eagle * pom)\r
2028 \r
2029        dFdL = ((dtop * bot - top * dbot) / botsq)\r
2030        dCAVdOM1  = dFdL * ( dFdOM1 )\r
2031        dCAVdOM2  = dFdL * ( dFdOM2 )\r
2032        dCAVdOM12 = dFdL * ( dFdOM12 )\r
2033 c!----------------------------------------------------\r
2034 c! Finally, add the distance derivatives to gvdwc\r
2035 c! Fac is used here to project the gradient vector into\r
2036 c! cartesian coordinates\r
2037 c! derivatives of omega angles will be added in sc_grad\r
2038       DO k = 1, 3\r
2039         fac = Rtail_distance(k) / Rtail\r
2040         gvdwx(k,i) = gvdwx(k,i)\r
2041      &             - dFdR * fac\r
2042 \r
2043         gvdwx(k,j) = gvdwx(k,j)\r
2044      &             + dFdR * fac\r
2045 \r
2046         gvdwc(k,i) = gvdwc(k,i)\r
2047      &             - dFdR * fac\r
2048 \r
2049         gvdwc(k,j) = gvdwc(k,j)\r
2050      &             + dFdR * fac\r
2051       END DO\r
2052 \r
2053 c!-------------------------------------------------------------------\r
2054 c! Compute head-head and head-tail energies for each state\r
2055 \r
2056           isel = iabs(Qi) + iabs(Qj)\r
2057           IF (isel.eq.0) THEN\r
2058 c! No charges - do nothing\r
2059            eheadtail = 0.0d0\r
2060 \r
2061           ELSE IF (isel.eq.4) THEN\r
2062 c! Calculate dipole-dipole interactions\r
2063            CALL edd(ecl)\r
2064            eheadtail = ECL\r
2065 \r
2066           ELSE IF (isel.eq.1 .and. iabs(Qi).eq.1) THEN\r
2067 c! Charge-nonpolar interactions\r
2068            CALL eqn(epol)\r
2069            eheadtail = epol\r
2070 \r
2071           ELSE IF (isel.eq.1 .and. iabs(Qj).eq.1) THEN\r
2072 c! Nonpolar-charge interactions\r
2073            CALL enq(epol)\r
2074            eheadtail = epol\r
2075 \r
2076           ELSE IF (isel.eq.3 .and. icharge(itypj).eq.2) THEN\r
2077 c! Charge-dipole interactions\r
2078            CALL eqd(ecl, elj, epol)\r
2079            eheadtail = ECL + elj + epol\r
2080 \r
2081           ELSE IF (isel.eq.3 .and. icharge(itypi).eq.2) THEN\r
2082 c! Dipole-charge interactions\r
2083            CALL edq(ecl, elj, epol)\r
2084            eheadtail = ECL + elj + epol\r
2085 \r
2086           ELSE IF ((isel.eq.2.and.\r
2087      &          iabs(Qi).eq.1).and.\r
2088      &          nstate(itypi,itypj).eq.1) THEN\r
2089 c! Same charge-charge interaction ( +/+ or -/- )\r
2090            CALL eqq(Ecl,Egb,Epol,Fisocav,Elj)\r
2091            eheadtail = ECL + Egb + Epol + Fisocav + Elj\r
2092 \r
2093           ELSE IF ((isel.eq.2.and.\r
2094      &          iabs(Qi).eq.1).and.\r
2095      &          nstate(itypi,itypj).ne.1) THEN\r
2096 c! Different charge-charge interaction ( +/- or -/+ )\r
2097            CALL energy_quad\r
2098      &     (istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)\r
2099           END IF\r
2100 \r
2101 c! this endif ends the "catch the gly-gly" at the beggining of Fcav\r
2102        END IF\r
2103        evdw = evdw\r
2104      &      + Fcav\r
2105      &      + eheadtail\r
2106 c!-------------------------------------------------------------------\r
2107 c! As all angular derivatives are done, now we sum them up,\r
2108 c! then transform and project into cartesian vectors and add to gvdwc\r
2109 c! We call sc_grad always, with the exception of +/- interaction.\r
2110 c! This is because energy_quad subroutine needs to handle\r
2111 c! this job in his own way.\r
2112 c! This IS probably not very efficient and SHOULD be optimised\r
2113 c! but it will require major restructurization of emomo\r
2114 c! so it will be left as it is for now\r
2115        IF (nstate(itypi,itypj).eq.1) THEN\r
2116 #ifdef TSCSC\r
2117         IF (bb(itypi,itypj).gt.0) THEN\r
2118          CALL sc_grad\r
2119         ELSE\r
2120          CALL sc_grad_T\r
2121         END IF\r
2122 #else\r
2123         CALL sc_grad\r
2124 #endif\r
2125        END IF\r
2126 c!-------------------------------------------------------------------\r
2127 c! NAPISY KONCOWE\r
2128 c! j\r
2129          END DO\r
2130 c! iint\r
2131         END DO\r
2132 c! i\r
2133        END DO\r
2134 c      write (iout,*) "Number of loop steps in EGB:",ind\r
2135 cccc      energy_dec=.false.\r
2136        RETURN\r
2137       END SUBROUTINE emomo\r
2138 \r
2139 c! END OF MOMO\r
2140 C--------------------------------------------------------------------\r
2141 \r
2142 \r
2143       SUBROUTINE eqq(Ecl,Egb,Epol,Fisocav,Elj)\r
2144        IMPLICIT NONE\r
2145        INCLUDE 'DIMENSIONS'\r
2146        INCLUDE 'COMMON.CALC'\r
2147        INCLUDE 'COMMON.CHAIN'\r
2148        INCLUDE 'COMMON.CONTROL'\r
2149        INCLUDE 'COMMON.DERIV'\r
2150        INCLUDE 'COMMON.EMP'\r
2151        INCLUDE 'COMMON.GEO'\r
2152        INCLUDE 'COMMON.INTERACT'\r
2153        INCLUDE 'COMMON.IOUNITS'\r
2154        INCLUDE 'COMMON.LOCAL'\r
2155        INCLUDE 'COMMON.NAMES'\r
2156        INCLUDE 'COMMON.VAR'\r
2157        double precision scalar\r
2158 c! Epol and Gpol analytical parameters\r
2159        alphapol1 = alphapol(itypi,itypj)\r
2160        alphapol2 = alphapol(itypj,itypi)\r
2161 c! Fisocav and Gisocav analytical parameters\r
2162        al1  = alphiso(1,itypi,itypj)\r
2163        al2  = alphiso(2,itypi,itypj)\r
2164        al3  = alphiso(3,itypi,itypj)\r
2165        al4  = alphiso(4,itypi,itypj)\r
2166        csig = sigiso(itypi, itypj)\r
2167 c!\r
2168        w1   = wqdip(1,itypi,itypj)\r
2169        w2   = wqdip(2,itypi,itypj)\r
2170        pis  = sig0head(itypi,itypj)\r
2171        eps0 = epshead(itypi,itypj)\r
2172        Rhead_sq = Rhead * Rhead\r
2173 \r
2174 c! R1 - distance between head of ith side chain and tail of jth sidechain\r
2175 c! R2 - distance between head of jth side chain and tail of ith sidechain\r
2176        R1 = 0.0d0\r
2177        R2 = 0.0d0\r
2178        DO k = 1, 3\r
2179 c! Calculate head-to-tail distances\r
2180         R1=R1+(ctail(k,2)-chead(k,1))**2\r
2181         R2=R2+(chead(k,2)-ctail(k,1))**2\r
2182        END DO\r
2183 c! Pitagoras\r
2184        R1 = dsqrt(R1)\r
2185        R2 = dsqrt(R2)\r
2186 \r
2187 c!-------------------------------------------------------------------\r
2188 c! Coulomb electrostatic interaction\r
2189        Ecl = (332.0d0 * Qij) / Rhead\r
2190 c!       write (*,*) "Ecl = ", Ecl\r
2191 c! derivative of Ecl is Gcl...\r
2192        dGCLdR = (-332.0d0 * Qij ) / Rhead_sq\r
2193 c! =============\r
2194 c!       Ecl = 0.0d0\r
2195 c!       dGCLdR = 0.0d0\r
2196 c! =============\r
2197        dGCLdOM1 = 0.0d0\r
2198        dGCLdOM2 = 0.0d0\r
2199        dGCLdOM12 = 0.0d0\r
2200 c!-------------------------------------------------------------------\r
2201 c! Generalised Born Solvent Polarization\r
2202        ee = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))\r
2203        Fgb = sqrt( ( Rhead_sq ) + a12sq * ee)\r
2204        Egb = (332.0d0 * Qij * eps_inout_fac) / Fgb\r
2205 \r
2206 c! Derivative of Egb is Ggb...\r
2207        dGGBdFGB = (-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb)\r
2208        dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee) ) )\r
2209      &        / ( 2.0d0 * Fgb )\r
2210        dGGBdR = dGGBdFGB * dFGBdR\r
2211 \r
2212 c! =============\r
2213 c!       write (*,*) "Fgb = ", Fgb\r
2214 c!       write (*,*) "Egb = ", Egb\r
2215 c!       write (*,*) "dFGBdR = ", dFGBdR\r
2216 c!       write (*,*) "dGGBdR = ", dGGBdR\r
2217 c!       Egb = 0.0d0\r
2218 c!       dGGBdR = 0.0d0\r
2219 c! =============\r
2220 c!-------------------------------------------------------------------\r
2221 c! Fisocav - isotropic cavity creation term\r
2222        pom = Rhead * csig\r
2223        top = al1 * (dsqrt(pom) + al2 * pom - al3)\r
2224        bot = (1.0d0 + al4 * pom**12.0d0)\r
2225        botsq = bot * bot\r
2226        FisoCav = top / bot\r
2227 \r
2228 c! Derivative of Fisocav is GCV...\r
2229        dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)\r
2230        dbot = 12.0d0 * al4 * pom ** 11.0d0\r
2231        dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig\r
2232 \r
2233 c! =============\r
2234 c!       FisoCav = 0.0d0\r
2235 c!       dGCVdR = 0.0d0\r
2236 c! =============\r
2237 c!-------------------------------------------------------------------\r
2238 c! Polarization energy\r
2239 c! Epol\r
2240        MomoFac1 = (1.0d0 - chi1 * sqom2)\r
2241        MomoFac2 = (1.0d0 - chi2 * sqom1)\r
2242        RR1  = ( R1 * R1 ) / MomoFac1\r
2243        RR2  = ( R2 * R2 ) / MomoFac2\r
2244        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))\r
2245        ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))\r
2246        fgb1 = sqrt( RR1 + a12sq * ee1 )\r
2247        fgb2 = sqrt( RR2 + a12sq * ee2 )\r
2248        epol = 332.0d0 * eps_inout_fac * (\r
2249      & (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))\r
2250 \r
2251 c! derivative of Epol is Gpol...\r
2252        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)\r
2253      &          / (fgb1 ** 5.0d0)\r
2254        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)\r
2255      &          / (fgb2 ** 5.0d0)\r
2256        dFGBdR1 = ( (R1 / MomoFac1)\r
2257      &        * ( 2.0d0 - (0.5d0 * ee1) ) )\r
2258      &        / ( 2.0d0 * fgb1 )\r
2259        dFGBdR2 = ( (R2 / MomoFac2)\r
2260      &        * ( 2.0d0 - (0.5d0 * ee2) ) )\r
2261      &        / ( 2.0d0 * fgb2 )\r
2262        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))\r
2263      &          * ( 2.0d0 - 0.5d0 * ee1) )\r
2264      &          / ( 2.0d0 * fgb1 )\r
2265        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))\r
2266      &          * ( 2.0d0 - 0.5d0 * ee2) )\r
2267      &          / ( 2.0d0 * fgb2 )\r
2268        dPOLdR1 = dPOLdFGB1 * dFGBdR1\r
2269        dPOLdR2 = dPOLdFGB2 * dFGBdR2\r
2270        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1\r
2271        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2\r
2272 c! =============\r
2273 c!       Epol = 0.0d0\r
2274 c!       dPOLdR1 = 0.0d0\r
2275 c!       dPOLdR2 = 0.0d0\r
2276 c!       dPOLdOM1 = 0.0d0\r
2277 c!       dPOLdOM2 = 0.0d0\r
2278 c! =============\r
2279 c!-------------------------------------------------------------------\r
2280 c! Elj\r
2281        pom = (pis / Rhead)**6.0d0\r
2282        Elj = 4.0d0 * eps0 * pom * (pom-1.0d0)\r
2283 c!       write (*,*) "ELJ = ", ELJ\r
2284 c! derivative of Elj is Glj\r
2285        Glj = 4.0d0 * eps0 \r
2286      &     * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))\r
2287      &     +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))\r
2288 c!       dGLJdR = glj * fish\r
2289        dGLJdR = glj\r
2290 c! =============\r
2291 c!       Elj = 0.0d0\r
2292 c!       dGLJdR = 0.0d0\r
2293 c! =============\r
2294 c!-------------------------------------------------------------------\r
2295 c! Return the results\r
2296        DO k = 1, 3\r
2297         erhead(k) = Rhead_distance(k)/Rhead\r
2298         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)\r
2299         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)\r
2300        END DO\r
2301 \r
2302        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )\r
2303        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )\r
2304        bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )\r
2305        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )\r
2306        facd1 = d1 * vbld_inv(i+nres)\r
2307        facd2 = d2 * vbld_inv(j+nres)\r
2308 \r
2309        DO k = 1, 3\r
2310         hawk   = (erhead_tail(k,1) + \r
2311      & facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres)))\r
2312         condor = (erhead_tail(k,2) +\r
2313      & facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))\r
2314 \r
2315         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))\r
2316         gvdwx(k,i) = gvdwx(k,i)\r
2317      &             - dGCLdR * pom\r
2318      &             - dGGBdR * pom\r
2319      &             - dGCVdR * pom\r
2320      &             - dPOLdR1 * hawk\r
2321      &             - dPOLdR2 * erhead_tail(k,2)\r
2322      &             - dGLJdR * pom\r
2323 \r
2324         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))\r
2325         gvdwx(k,j) = gvdwx(k,j)\r
2326      &             + dGCLdR * pom\r
2327      &             + dGGBdR * pom\r
2328      &             + dGCVdR * pom\r
2329      &             + dPOLdR1 * erhead_tail(k,1)\r
2330      &             + dPOLdR2 * condor\r
2331      &             + dGLJdR * pom\r
2332 \r
2333         gvdwc(k,i) = gvdwc(k,i)\r
2334      &             - dGCLdR * erhead(k)\r
2335      &             - dGGBdR * erhead(k)\r
2336      &             - dGCVdR * erhead(k)\r
2337      &             - dPOLdR1 * erhead_tail(k,1)\r
2338      &             - dPOLdR2 * erhead_tail(k,2)\r
2339      &             - dGLJdR * erhead(k)\r
2340 \r
2341         gvdwc(k,j) = gvdwc(k,j)\r
2342      &             + dGCLdR * erhead(k)\r
2343      &             + dGGBdR * erhead(k)\r
2344      &             + dGCVdR * erhead(k)\r
2345      &             + dPOLdR1 * erhead_tail(k,1)\r
2346      &             + dPOLdR2 * erhead_tail(k,2)\r
2347      &             + dGLJdR * erhead(k)\r
2348 \r
2349        END DO\r
2350        RETURN\r
2351       END SUBROUTINE eqq\r
2352 \r
2353 \r
2354 c!-------------------------------------------------------------------\r
2355 \r
2356       SUBROUTINE energy_quad\r
2357      &(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)\r
2358        IMPLICIT NONE\r
2359        INCLUDE 'DIMENSIONS'\r
2360        INCLUDE 'COMMON.CALC'\r
2361        INCLUDE 'COMMON.CHAIN'\r
2362        INCLUDE 'COMMON.CONTROL'\r
2363        INCLUDE 'COMMON.DERIV'\r
2364        INCLUDE 'COMMON.EMP'\r
2365        INCLUDE 'COMMON.GEO'\r
2366        INCLUDE 'COMMON.INTERACT'\r
2367        INCLUDE 'COMMON.IOUNITS'\r
2368        INCLUDE 'COMMON.LOCAL'\r
2369        INCLUDE 'COMMON.NAMES'\r
2370        INCLUDE 'COMMON.VAR'\r
2371        double precision scalar\r
2372        double precision ener(4)\r
2373        double precision dcosom1(3),dcosom2(3)\r
2374 c! Epol and Gpol analytical parameters\r
2375        alphapol1 = alphapol(itypi,itypj)\r
2376        alphapol2 = alphapol(itypj,itypi)\r
2377 c! Fisocav and Gisocav analytical parameters\r
2378        al1  = alphiso(1,itypi,itypj)\r
2379        al2  = alphiso(2,itypi,itypj)\r
2380        al3  = alphiso(3,itypi,itypj)\r
2381        al4  = alphiso(4,itypi,itypj)\r
2382        csig = sigiso(itypi, itypj)\r
2383 c!\r
2384        w1   = wqdip(1,itypi,itypj)\r
2385        w2   = wqdip(2,itypi,itypj)\r
2386        pis  = sig0head(itypi,itypj)\r
2387        eps0 = epshead(itypi,itypj)\r
2388 \r
2389 c! First things first:\r
2390 c! We need to do sc_grad's job with GB and Fcav\r
2391 \r
2392        eom1  =\r
2393      &         eps2der * eps2rt_om1\r
2394      &       - 2.0D0 * alf1 * eps3der\r
2395      &       + sigder * sigsq_om1\r
2396      &       + dCAVdOM1\r
2397 \r
2398        eom2  =\r
2399      &         eps2der * eps2rt_om2\r
2400      &       + 2.0D0 * alf2 * eps3der\r
2401      &       + sigder * sigsq_om2\r
2402      &       + dCAVdOM2\r
2403 \r
2404        eom12 =\r
2405      &         evdwij  * eps1_om12\r
2406      &       + eps2der * eps2rt_om12\r
2407      &       - 2.0D0 * alf12 * eps3der\r
2408      &       + sigder *sigsq_om12\r
2409      &       + dCAVdOM12\r
2410 \r
2411 c! now some magical transformations to project gradient into\r
2412 c! three cartesian vectors\r
2413 \r
2414        DO k = 1, 3\r
2415         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))\r
2416         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))\r
2417         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)\r
2418 c! this acts on hydrophobic center of interaction\r
2419         gvdwx(k,i)= gvdwx(k,i) - gg(k)\r
2420      &            + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))\r
2421      &            + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv\r
2422         gvdwx(k,j)= gvdwx(k,j) + gg(k)\r
2423      &            + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))\r
2424      &            + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv\r
2425 c! this acts on Calpha\r
2426         gvdwc(k,i)=gvdwc(k,i)-gg(k)\r
2427         gvdwc(k,j)=gvdwc(k,j)+gg(k)\r
2428        END DO\r
2429 \r
2430 c! sc_grad is done, now we will compute \r
2431 \r
2432        eheadtail = 0.0d0\r
2433        eom1 = 0.0d0\r
2434        eom2 = 0.0d0\r
2435        eom12 = 0.0d0\r
2436 c*************************************************************\r
2437        DO istate = 1, nstate(itypi,itypj)\r
2438 c!       DO istate = 1, 1\r
2439 c!        write (*,*) "istate = ", istate\r
2440 c*************************************************************\r
2441         IF (istate.ne.1) THEN\r
2442          IF (istate.lt.3) THEN\r
2443           ii = 1\r
2444          ELSE\r
2445           ii = 2\r
2446          END IF\r
2447         jj = istate/ii\r
2448         d1 = dhead(1,ii,itypi,itypj)\r
2449         d2 = dhead(2,jj,itypi,itypj)\r
2450         DO k = 1,3\r
2451          chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)\r
2452          chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)\r
2453          Rhead_distance(k) = chead(k,2) - chead(k,1)\r
2454         END DO\r
2455 c! pitagoras (root of sum of squares)\r
2456         Rhead = dsqrt(\r
2457      &          (Rhead_distance(1)*Rhead_distance(1))\r
2458      &        + (Rhead_distance(2)*Rhead_distance(2))\r
2459      &        + (Rhead_distance(3)*Rhead_distance(3)))\r
2460         END IF\r
2461         Rhead_sq = Rhead * Rhead\r
2462 \r
2463 c! R1 - distance between head of ith side chain and tail of jth sidechain\r
2464 c! R2 - distance between head of jth side chain and tail of ith sidechain\r
2465         R1 = 0.0d0\r
2466         R2 = 0.0d0\r
2467         DO k = 1, 3\r
2468 c! Calculate head-to-tail distances\r
2469          R1=R1+(ctail(k,2)-chead(k,1))**2\r
2470          R2=R2+(chead(k,2)-ctail(k,1))**2\r
2471         END DO\r
2472 c! Pitagoras\r
2473         R1 = dsqrt(R1)\r
2474         R2 = dsqrt(R2)\r
2475 \r
2476 c!-------------------------------------------------------------------\r
2477 c! Coulomb electrostatic interaction\r
2478         Ecl = (332.0d0 * Qij) / Rhead\r
2479 c!        write (*,*) "Ecl = ", Ecl\r
2480 c! derivative of Ecl is Gcl...\r
2481         dGCLdR = (-332.0d0 * Qij ) / Rhead_sq\r
2482 c! =============\r
2483 c!      write (*,*) "Ecl = ", Ecl\r
2484 c!      write (*,*) "dGCLdR = ", dGCLdR\r
2485 c!        Ecl = 0.0d0\r
2486 c!        dGCLdR = 0.0d0\r
2487 c! =============\r
2488         dGCLdOM1 = 0.0d0\r
2489         dGCLdOM2 = 0.0d0\r
2490         dGCLdOM12 = 0.0d0\r
2491 c!-------------------------------------------------------------------\r
2492 c! Generalised Born Solvent Polarization\r
2493         ee = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))\r
2494         Fgb = sqrt( ( Rhead_sq ) + a12sq * ee)\r
2495         Egb = (332.0d0 * Qij * eps_inout_fac) / Fgb\r
2496 \r
2497 c! Derivative of Egb is Ggb...\r
2498         dGGBdFGB = (-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb)\r
2499         dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee) ) )\r
2500      &         / ( 2.0d0 * Fgb )\r
2501         dGGBdR = dGGBdFGB * dFGBdR\r
2502 \r
2503 c! =============\r
2504 c!        write (*,*) "Fgb = ", Fgb\r
2505 c!        write (*,*) "Egb = ", Egb\r
2506 c!        write (*,*) "dFGBdR = ", dFGBdR\r
2507 c!        write (*,*) "dGGBdR = ", dGGBdR\r
2508 c!        Egb = 0.0d0\r
2509 c!        dGGBdR = 0.0d0\r
2510 c! =============\r
2511 c!-------------------------------------------------------------------\r
2512 c! Fisocav - isotropic cavity creation term\r
2513         pom = Rhead * csig\r
2514         top = al1 * (dsqrt(pom) + al2 * pom - al3)\r
2515         bot = (1.0d0 + al4 * pom**12.0d0)\r
2516         botsq = bot * bot\r
2517         FisoCav = top / bot\r
2518 \r
2519 c! Derivative of Fisocav is GCV...\r
2520         dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)\r
2521         dbot = 12.0d0 * al4 * pom ** 11.0d0\r
2522         dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig\r
2523 \r
2524 c! =============\r
2525 c!      write(*,*) "FisoCav = ", Fisocav\r
2526 c!      write(*,*) "dGCVdR = ", dGCVdR\r
2527 c!        FisoCav = 0.0d0\r
2528 c!        dGCVdR = 0.0d0\r
2529 c! =============\r
2530 c!-------------------------------------------------------------------\r
2531 c! Polarization energy\r
2532 c! Epol\r
2533         MomoFac1 = (1.0d0 - chi1 * sqom2)\r
2534         MomoFac2 = (1.0d0 - chi2 * sqom1)\r
2535         RR1  = ( R1 * R1 ) / MomoFac1\r
2536         RR2  = ( R2 * R2 ) / MomoFac2\r
2537         ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))\r
2538         ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))\r
2539         fgb1 = sqrt( RR1 + a12sq * ee1 )\r
2540         fgb2 = sqrt( RR2 + a12sq * ee2 )\r
2541         epol = 332.0d0 * eps_inout_fac * (\r
2542      &  (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))\r
2543 \r
2544 c! derivative of Epol is Gpol...\r
2545         dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)\r
2546      &            / (fgb1 ** 5.0d0)\r
2547         dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)\r
2548      &            / (fgb2 ** 5.0d0)\r
2549         dFGBdR1 = ( (R1 / MomoFac1)\r
2550      &          * ( 2.0d0 - (0.5d0 * ee1) ) )\r
2551      &          / ( 2.0d0 * fgb1 )\r
2552         dFGBdR2 = ( (R2 / MomoFac2)\r
2553      &          * ( 2.0d0 - (0.5d0 * ee2) ) )\r
2554      &          / ( 2.0d0 * fgb2 )\r
2555         dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))\r
2556      &           * ( 2.0d0 - 0.5d0 * ee1) )\r
2557      &           / ( 2.0d0 * fgb1 )\r
2558         dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))\r
2559      &           * ( 2.0d0 - 0.5d0 * ee2) )\r
2560      &           / ( 2.0d0 * fgb2 )\r
2561         dPOLdR1 = dPOLdFGB1 * dFGBdR1\r
2562         dPOLdR2 = dPOLdFGB2 * dFGBdR2\r
2563         dPOLdOM1 = dPOLdFGB2 * dFGBdOM1\r
2564         dPOLdOM2 = dPOLdFGB1 * dFGBdOM2\r
2565 c! =============\r
2566 c!      write(*,*) "Epol = ", Epol\r
2567 c!      write(*,*) "dPOLdR1 = ", dPOLdOM2\r
2568 c!      write(*,*) "dPOLdR2 = ", dPOLdR2\r
2569 c!      write(*,*) "dPOLdOM1 = ", dPOLdOM1\r
2570 c!      write(*,*) "dPOLdOM2 = ", dPOLdOM2\r
2571 c!        Epol = 0.0d0\r
2572 c!        dPOLdR1 = 0.0d0\r
2573 c!        dPOLdR2 = 0.0d0\r
2574 c!        dPOLdOM1 = 0.0d0\r
2575 c!        dPOLdOM2 = 0.0d0\r
2576 c! =============\r
2577 c!-------------------------------------------------------------------\r
2578 c! Elj\r
2579         pom = (pis / Rhead)**6.0d0\r
2580         Elj = 4.0d0 * eps0 * pom * (pom-1.0d0)\r
2581 c!        write (*,*) "ELJ = ", ELJ\r
2582 c! derivative of Elj is Glj\r
2583         dGLJdR = 4.0d0 * eps0 \r
2584      &      * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))\r
2585      &      +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))\r
2586 \r
2587 c! =============\r
2588 c!      write (*,*) "Elj = ", Elj\r
2589 c!      write (*,*) "dGLJdR = ", dGLJdR\r
2590 c!        Elj = 0.0d0\r
2591 c!        dGLJdR = 0.0d0\r
2592 c! =============\r
2593 c!-------------------------------------------------------------------\r
2594 c! Equad\r
2595        IF (Wqd.ne.0.0d0) THEN\r
2596 \r
2597         Beta1 = 5.0d0 + 3.0d0 * (sqom12 - 1.0d0)\r
2598      &        - 37.5d0  * ( sqom1 + sqom2 )\r
2599      &        + 157.5d0 * ( sqom1 * sqom2 )\r
2600      &        - 45.0d0  * om1*om2*om12\r
2601         fac = -( Wqd / (2.0d0 * Fgb**5.0d0) )\r
2602         Equad = fac * Beta1\r
2603 c! derivative of Equad...\r
2604         dQUADdR = ((2.5d0 * Wqd * Beta1) / (Fgb**6.0d0)) * dFGBdR\r
2605         dQUADdOM1 = fac\r
2606      &            * (-75.0d0*om1 + 315.0d0*om1*sqom2 - 45.0d0*om2*om12)\r
2607         dQUADdOM2 = fac\r
2608      &            * (-75.0d0*om2 + 315.0d0*sqom1*om2 - 45.0d0*om1*om12)\r
2609         dQUADdOM12 = fac\r
2610      &             * ( 6.0d0*om12 - 45.0d0*om1*om2 )\r
2611 c!      write(*,*) "Equad = ", Equad\r
2612 c!      write(*,*) "dQUADdR = ", dQUADdR\r
2613 c!      write(*,*) "dQUADdOM1 = ", dQUADdOM1\r
2614 c!      write(*,*) "dQUADdOM2 = ", dQUADdOM2\r
2615 c!      write(*,*) "dQUADdOM12 = ", dQUADdOM12\r
2616         ELSE\r
2617          Beta1 = 0.0d0\r
2618          Equad = 0.0d0\r
2619         END IF\r
2620 c!-------------------------------------------------------------------\r
2621 c! Return the results\r
2622 \r
2623 c! Angular stuff\r
2624 c!        eom1 = eom1 + dPOLdOM1 + dQUADdOM1\r
2625 c!        eom2 = eom2 + dPOLdOM2 + dQUADdOM2\r
2626 c!        eom12 = eom12 + dQUADdOM12\r
2627         eom1 = dPOLdOM1 + dQUADdOM1\r
2628         eom2 = dPOLdOM2 + dQUADdOM2\r
2629         eom12 = dQUADdOM12\r
2630 c! now some magical transformations to project gradient into\r
2631 c! three cartesian vectors\r
2632         DO k = 1, 3\r
2633          dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))\r
2634          dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))\r
2635 c!         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)\r
2636          tuna(k) = eom1 * dcosom1(k) + eom2 * dcosom2(k)\r
2637         END DO\r
2638 \r
2639 c! Radial stuff\r
2640         DO k = 1, 3\r
2641          erhead(k) = Rhead_distance(k)/Rhead\r
2642          erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)\r
2643          erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)\r
2644         END DO\r
2645         erdxi = scalar( erhead(1), dC_norm(1,i+nres) )\r
2646         erdxj = scalar( erhead(1), dC_norm(1,j+nres) )\r
2647         bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )\r
2648         eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )\r
2649         facd1 = d1 * vbld_inv(i+nres)\r
2650         facd2 = d2 * vbld_inv(j+nres)\r
2651 \r
2652 c! Throw the results into gheadtail which holds gradients\r
2653 c! for each micro-state\r
2654 \r
2655         DO k = 1, 3\r
2656          hawk   = (erhead_tail(k,1) + \r
2657      &  facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres)))\r
2658          condor = (erhead_tail(k,2) +\r
2659      &  facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))\r
2660 \r
2661          pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))\r
2662 c! this acts on hydrophobic center of interaction\r
2663 c!         gvdwx(k,i) = gvdwx(k,i)\r
2664          gheadtail(k,1,1) = gheadtail(k,1,1)\r
2665      &                    - dGCLdR * pom\r
2666      &                    - dGGBdR * pom\r
2667      &                    - dGCVdR * pom\r
2668      &                    - dPOLdR1 * hawk\r
2669      &                    - dPOLdR2 * erhead_tail(k,2)\r
2670      &                    - dGLJdR * pom\r
2671      &                    - dQUADdR * pom\r
2672      &                    - tuna(k)\r
2673      &            + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))\r
2674      &            + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv\r
2675 c!      write (*,*) "gheadtail(k,1,1) = ", gheadtail(k,1,1)\r
2676 \r
2677          pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))\r
2678 c! this acts on hydrophobic center of interaction\r
2679 c!         gvdwx(k,j) = gvdwx(k,j)\r
2680          gheadtail(k,2,1) = gheadtail(k,2,1)\r
2681      &                    + dGCLdR * pom\r
2682      &                    + dGGBdR * pom\r
2683      &                    + dGCVdR * pom\r
2684      &                    + dPOLdR1 * erhead_tail(k,1)\r
2685      &                    + dPOLdR2 * condor\r
2686      &                    + dGLJdR * pom\r
2687      &                    + dQUADdR * pom\r
2688      &                    + tuna(k)\r
2689      &            + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))\r
2690      &            + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv\r
2691 \r
2692 c! this acts on Calpha\r
2693 c!         gvdwc(k,i) = gvdwc(k,i)\r
2694          gheadtail(k,3,1) = gheadtail(k,3,1)\r
2695      &                    - dGCLdR * erhead(k)\r
2696      &                    - dGGBdR * erhead(k)\r
2697      &                    - dGCVdR * erhead(k)\r
2698      &                    - dPOLdR1 * erhead_tail(k,1)\r
2699      &                    - dPOLdR2 * erhead_tail(k,2)\r
2700      &                    - dGLJdR * erhead(k)\r
2701      &                    - dQUADdR * erhead(k)\r
2702      &                    - tuna(k)\r
2703 \r
2704 c! this acts on Calpha\r
2705 c!         gvdwc(k,j) = gvdwc(k,j)\r
2706          gheadtail(k,4,1) = gheadtail(k,4,1)\r
2707      &                    + dGCLdR * erhead(k)\r
2708      &                    + dGGBdR * erhead(k)\r
2709      &                    + dGCVdR * erhead(k)\r
2710      &                    + dPOLdR1 * erhead_tail(k,1)\r
2711      &                    + dPOLdR2 * erhead_tail(k,2)\r
2712      &                    + dGLJdR * erhead(k)\r
2713      &                    + dQUADdR * erhead(k)\r
2714      &                    + tuna(k)\r
2715         END DO\r
2716         ener(istate) = ECL + Egb + Epol + Fisocav + Elj + Equad\r
2717 c!        write (*,*) "ener(",istate,") = ", ener(istate)\r
2718         eheadtail = eheadtail\r
2719      &            + wstate(istate, itypi, itypj)\r
2720      &            * dexp(-betaT * ener(istate))\r
2721 c!      write (*,*) "wstate = ", wstate(istate, itypi, itypj)\r
2722 c!        write (*,*) "betaT = ", betaT\r
2723 c!        write (*,*) "-E1beta = ", (-betaT * ener(istate))\r
2724 c!        write (*,*) "w1exp = ", (wstate(istate, itypi, itypj)\r
2725 c!     &            * dexp(-betaT * ener(istate)))\r
2726 c! foreach cartesian dimension\r
2727         DO k = 1, 3\r
2728 c! foreach of two gvdwx and gvdwc\r
2729          DO l = 1, 4\r
2730           gheadtail(k,l,2) = gheadtail(k,l,2)\r
2731      &                     + wstate( istate, itypi, itypj )\r
2732      &                     * dexp(-betaT * ener(istate))\r
2733      &                     * gheadtail(k,l,1)\r
2734           gheadtail(k,l,1) = 0.0d0\r
2735 c!      write (*,*) "wstate = ", wstate(istate,itypi,itypj)\r
2736 c!      write (*,*) "-G1beta =", (-betaT * gheadtail(k,l,1))\r
2737 c!      write (*,*) "top(",k,",",l,",",2,") = ", gheadtail(k,l,2)\r
2738          END DO\r
2739         END DO\r
2740        END DO\r
2741 c! Here ended the gigantic DO istate = 1, 4, which starts\r
2742 c! at the beggining of the subroutine\r
2743 \r
2744        DO k = 1, 3\r
2745         DO l = 1, 4\r
2746          gheadtail(k,l,2) = gheadtail(k,l,2) / eheadtail\r
2747 c!         write (*,*) "eheadtail = ", eheadtail\r
2748 c!         write (*,*) "gheadtail(",k,",",l,",2) = ",\r
2749 c!     &                gheadtail(k,l,2)\r
2750         END DO\r
2751         gvdwx(k,i) = gvdwx(k,i) + gheadtail(k,1,2)\r
2752         gvdwx(k,j) = gvdwx(k,j) + gheadtail(k,2,2)\r
2753         gvdwc(k,i) = gvdwc(k,i) + gheadtail(k,3,2)\r
2754         gvdwc(k,j) = gvdwc(k,j) + gheadtail(k,4,2)\r
2755         DO l = 1, 4\r
2756          gheadtail(k,l,1) = 0.0d0\r
2757          gheadtail(k,l,2) = 0.0d0\r
2758         END DO\r
2759        END DO\r
2760        eheadtail = (-dlog(eheadtail)) / betaT\r
2761 c!       write (*,*) "eheadtail_final = ", eheadtail\r
2762        dPOLdOM1 = 0.0d0\r
2763        dPOLdOM2 = 0.0d0\r
2764        dQUADdOM1 = 0.0d0\r
2765        dQUADdOM2 = 0.0d0\r
2766        dQUADdOM12 = 0.0d0\r
2767        RETURN\r
2768       END SUBROUTINE energy_quad\r
2769 \r
2770 \r
2771 c!-------------------------------------------------------------------\r
2772 \r
2773 \r
2774       SUBROUTINE eqn(Epol)\r
2775       IMPLICIT NONE\r
2776       INCLUDE 'DIMENSIONS'\r
2777       INCLUDE 'COMMON.CALC'\r
2778       INCLUDE 'COMMON.CHAIN'\r
2779       INCLUDE 'COMMON.CONTROL'\r
2780       INCLUDE 'COMMON.DERIV'\r
2781       INCLUDE 'COMMON.EMP'\r
2782       INCLUDE 'COMMON.GEO'\r
2783       INCLUDE 'COMMON.INTERACT'\r
2784       INCLUDE 'COMMON.IOUNITS'\r
2785       INCLUDE 'COMMON.LOCAL'\r
2786       INCLUDE 'COMMON.NAMES'\r
2787       INCLUDE 'COMMON.VAR'\r
2788       double precision scalar\r
2789       alphapol1 = alphapol(itypi,itypj)\r
2790 c! R1 - distance between head of ith side chain and tail of jth sidechain\r
2791        R1 = 0.0d0\r
2792        DO k = 1, 3\r
2793 c! Calculate head-to-tail distances\r
2794         R1=R1+(ctail(k,2)-chead(k,1))**2\r
2795        END DO\r
2796 c! Pitagoras\r
2797        R1 = dsqrt(R1)\r
2798 c--------------------------------------------------------------------\r
2799 c Polarization energy\r
2800 c Epol\r
2801        MomoFac1 = (1.0d0 - chi1 * sqom2)\r
2802        RR1  = R1 * R1 / MomoFac1\r
2803        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))\r
2804        fgb1 = sqrt( RR1 + a12sq * ee1)\r
2805        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)\r
2806 c!------------------------------------------------------------------\r
2807 c! derivative of Epol is Gpol...\r
2808        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)\r
2809      &          / (fgb1 ** 5.0d0)\r
2810 \r
2811        dFGBdR1 = ( (R1 / MomoFac1)\r
2812      &        * ( 2.0d0 - (0.5d0 * ee1) ) )\r
2813      &        / ( 2.0d0 * fgb1 )\r
2814 \r
2815        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))\r
2816      &          * (2.0d0 - 0.5d0 * ee1) )\r
2817      &          / (2.0d0 * fgb1)\r
2818 \r
2819        dPOLdR1 = dPOLdFGB1 * dFGBdR1\r
2820 \r
2821        dPOLdOM1 = 0.0d0\r
2822 \r
2823        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2\r
2824 c!-------------------------------------------------------------------\r
2825 c! Return the results\r
2826        DO k = 1, 3\r
2827         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)\r
2828        END DO\r
2829 \r
2830        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )\r
2831        facd1 = d1 * vbld_inv(i+nres)\r
2832 \r
2833        DO k = 1, 3\r
2834         hawk = (erhead_tail(k,1) + \r
2835      & facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))\r
2836 \r
2837         gvdwx(k,i) = gvdwx(k,i)\r
2838      &             - dPOLdR1 * hawk\r
2839 \r
2840         gvdwx(k,j) = gvdwx(k,j)\r
2841      &             + dPOLdR1 * erhead_tail(k,1)\r
2842 \r
2843         gvdwc(k,i) = gvdwc(k,i)\r
2844      &             - dPOLdR1 * erhead_tail(k,1)\r
2845 \r
2846         gvdwc(k,j) = gvdwc(k,j)\r
2847      &             + dPOLdR1 * erhead_tail(k,1)\r
2848 \r
2849        END DO\r
2850        RETURN\r
2851       END SUBROUTINE eqn\r
2852 \r
2853 \r
2854 c!-------------------------------------------------------------------\r
2855 \r
2856 \r
2857 \r
2858       SUBROUTINE enq(Epol)\r
2859        IMPLICIT NONE\r
2860        INCLUDE 'DIMENSIONS'\r
2861        INCLUDE 'COMMON.CALC'\r
2862        INCLUDE 'COMMON.CHAIN'\r
2863        INCLUDE 'COMMON.CONTROL'\r
2864        INCLUDE 'COMMON.DERIV'\r
2865        INCLUDE 'COMMON.EMP'\r
2866        INCLUDE 'COMMON.GEO'\r
2867        INCLUDE 'COMMON.INTERACT'\r
2868        INCLUDE 'COMMON.IOUNITS'\r
2869        INCLUDE 'COMMON.LOCAL'\r
2870        INCLUDE 'COMMON.NAMES'\r
2871        INCLUDE 'COMMON.VAR'\r
2872        double precision scalar\r
2873        alphapol2 = alphapol(itypj,itypi)\r
2874 c! R2 - distance between head of jth side chain and tail of ith sidechain\r
2875        R2 = 0.0d0\r
2876        DO k = 1, 3\r
2877 c! Calculate head-to-tail distances\r
2878         R2=R2+(chead(k,2)-ctail(k,1))**2\r
2879        END DO\r
2880 c! Pitagoras\r
2881        R2 = dsqrt(R2)\r
2882 c------------------------------------------------------------------------\r
2883 c Polarization energy\r
2884        MomoFac2 = (1.0d0 - chi2 * sqom1)\r
2885        RR2  = R2 * R2 / MomoFac2\r
2886        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))\r
2887        fgb2 = sqrt(RR2  + a12sq * ee2)\r
2888        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )\r
2889 c!-------------------------------------------------------------------\r
2890 c! derivative of Epol is Gpol...\r
2891        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)\r
2892      &          / (fgb2 ** 5.0d0)\r
2893 \r
2894        dFGBdR2 = ( (R2 / MomoFac2)\r
2895      &        * ( 2.0d0 - (0.5d0 * ee2) ) )\r
2896      &        / (2.0d0 * fgb2)\r
2897 \r
2898        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))\r
2899      &          * (2.0d0 - 0.5d0 * ee2) )\r
2900      &          / (2.0d0 * fgb2)\r
2901 \r
2902        dPOLdR2 = dPOLdFGB2 * dFGBdR2\r
2903 \r
2904        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1\r
2905 \r
2906        dPOLdOM2 = 0.0d0\r
2907 c!-------------------------------------------------------------------\r
2908 c! Return the results\r
2909        DO k = 1, 3\r
2910         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)\r
2911        END DO\r
2912        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )\r
2913        facd2 = d2 * vbld_inv(j+nres)\r
2914        DO k = 1, 3\r
2915         condor = (erhead_tail(k,2)\r
2916      & + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))\r
2917 \r
2918         gvdwx(k,i) = gvdwx(k,i)\r
2919      &             - dPOLdR2 * erhead_tail(k,2)\r
2920 \r
2921         gvdwx(k,j) = gvdwx(k,j)\r
2922      &             + dPOLdR2 * condor\r
2923 \r
2924         gvdwc(k,i) = gvdwc(k,i)\r
2925      &             - dPOLdR2 * erhead_tail(k,2)\r
2926 \r
2927         gvdwc(k,j) = gvdwc(k,j)\r
2928      &             + dPOLdR2 * erhead_tail(k,2)\r
2929 \r
2930        END DO\r
2931       RETURN\r
2932       END SUBROUTINE enq\r
2933 \r
2934 \r
2935 c!-------------------------------------------------------------------\r
2936 \r
2937 \r
2938       SUBROUTINE eqd(Ecl,Elj,Epol)\r
2939        IMPLICIT NONE\r
2940        INCLUDE 'DIMENSIONS'\r
2941        INCLUDE 'COMMON.CALC'\r
2942        INCLUDE 'COMMON.CHAIN'\r
2943        INCLUDE 'COMMON.CONTROL'\r
2944        INCLUDE 'COMMON.DERIV'\r
2945        INCLUDE 'COMMON.EMP'\r
2946        INCLUDE 'COMMON.GEO'\r
2947        INCLUDE 'COMMON.INTERACT'\r
2948        INCLUDE 'COMMON.IOUNITS'\r
2949        INCLUDE 'COMMON.LOCAL'\r
2950        INCLUDE 'COMMON.NAMES'\r
2951        INCLUDE 'COMMON.VAR'\r
2952        double precision scalar\r
2953        alphapol1 = alphapol(itypi,itypj)\r
2954        w1        = wqdip(1,itypi,itypj)\r
2955        w2        = wqdip(2,itypi,itypj)\r
2956        pis  = sig0head(itypi,itypj)\r
2957        eps0 = epshead(itypi,itypj)\r
2958 c!-------------------------------------------------------------------\r
2959 c! R1 - distance between head of ith side chain and tail of jth sidechain\r
2960        R1 = 0.0d0\r
2961        DO k = 1, 3\r
2962 c! Calculate head-to-tail distances\r
2963         R1=R1+(ctail(k,2)-chead(k,1))**2\r
2964        END DO\r
2965 c! Pitagoras\r
2966        R1 = dsqrt(R1)\r
2967 \r
2968 c!-------------------------------------------------------------------\r
2969 c! ecl\r
2970        sparrow  = w1 * Qi * om1 \r
2971        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)\r
2972        Ecl = sparrow / Rhead**2.0d0\r
2973      &     - hawk    / Rhead**4.0d0\r
2974 c!       Ecl = 0.0d0\r
2975 c!       write (iout,*) "ECL = ", ECL\r
2976 c!-------------------------------------------------------------------\r
2977 c! derivative of ecl is Gcl\r
2978 c! dF/dr part\r
2979        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0\r
2980      &           + 4.0d0 * hawk    / Rhead**5.0d0\r
2981 c!       dGCLdR  = 0.0d0\r
2982 c! dF/dom1\r
2983        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)\r
2984 c!       dGCLdOM1 = 0.0d0\r
2985 c! dF/dom2\r
2986        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)\r
2987 c!       dGCLdOM2 = 0.0d0\r
2988 c--------------------------------------------------------------------\r
2989 c Polarization energy\r
2990 c Epol\r
2991        MomoFac1 = (1.0d0 - chi1 * sqom2)\r
2992        RR1  = R1 * R1 / MomoFac1\r
2993        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))\r
2994        fgb1 = sqrt( RR1 + a12sq * ee1)\r
2995        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)\r
2996 c!       epol = 0.0d0\r
2997 c!       write (iout,*) "EPOL = ", EPOL\r
2998 c!------------------------------------------------------------------\r
2999 c! derivative of Epol is Gpol...\r
3000        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)\r
3001      &          / (fgb1 ** 5.0d0)\r
3002        dFGBdR1 = ( (R1 / MomoFac1)\r
3003      &        * ( 2.0d0 - (0.5d0 * ee1) ) )\r
3004      &        / ( 2.0d0 * fgb1 )\r
3005        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))\r
3006      &          * (2.0d0 - 0.5d0 * ee1) )\r
3007      &          / (2.0d0 * fgb1)\r
3008        dPOLdR1 = dPOLdFGB1 * dFGBdR1\r
3009 c!       dPOLdR1 = 0.0d0\r
3010        dPOLdOM1 = 0.0d0\r
3011        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2\r
3012 c!       dPOLdOM2 = 0.0d0\r
3013 c!-------------------------------------------------------------------\r
3014 c! Elj\r
3015        pom = (pis / Rhead)**6.0d0\r
3016        Elj = 4.0d0 * eps0 * pom * (pom-1.0d0)\r
3017 c!       write (*,*) "ELJ = ", ELJ\r
3018 c! derivative of Elj is Glj\r
3019        dGLJdR = 4.0d0 * eps0 \r
3020      &     * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))\r
3021      &     +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))\r
3022 c!-------------------------------------------------------------------\r
3023 c! Return the results\r
3024        DO k = 1, 3\r
3025         erhead(k) = Rhead_distance(k)/Rhead\r
3026         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)\r
3027        END DO\r
3028 \r
3029        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )\r
3030        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )\r
3031        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )\r
3032        facd1 = d1 * vbld_inv(i+nres)\r
3033        facd2 = d2 * vbld_inv(j+nres)\r
3034 \r
3035        DO k = 1, 3\r
3036         hawk = (erhead_tail(k,1) + \r
3037      & facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))\r
3038 \r
3039         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))\r
3040         gvdwx(k,i) = gvdwx(k,i)\r
3041      &             - dGCLdR * pom\r
3042      &             - dPOLdR1 * hawk\r
3043      &             - dGLJdR * pom\r
3044 \r
3045         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))\r
3046         gvdwx(k,j) = gvdwx(k,j)\r
3047      &             + dGCLdR * pom\r
3048      &             + dPOLdR1 * erhead_tail(k,1)\r
3049      &             + dGLJdR * pom\r
3050 \r
3051 \r
3052         gvdwc(k,i) = gvdwc(k,i)\r
3053      &             - dGCLdR * erhead(k)\r
3054      &             - dPOLdR1 * erhead_tail(k,1)\r
3055      &             - dGLJdR * erhead(k)\r
3056 \r
3057         gvdwc(k,j) = gvdwc(k,j)\r
3058      &             + dGCLdR * erhead(k)\r
3059      &             + dPOLdR1 * erhead_tail(k,1)\r
3060      &             + dGLJdR * erhead(k)\r
3061 \r
3062        END DO\r
3063        RETURN\r
3064       END SUBROUTINE eqd\r
3065 \r
3066 \r
3067 c!-------------------------------------------------------------------\r
3068 \r
3069 \r
3070       SUBROUTINE edq(Ecl,Elj,Epol)\r
3071        IMPLICIT NONE\r
3072        INCLUDE 'DIMENSIONS'\r
3073        INCLUDE 'COMMON.CALC'\r
3074        INCLUDE 'COMMON.CHAIN'\r
3075        INCLUDE 'COMMON.CONTROL'\r
3076        INCLUDE 'COMMON.DERIV'\r
3077        INCLUDE 'COMMON.EMP'\r
3078        INCLUDE 'COMMON.GEO'\r
3079        INCLUDE 'COMMON.INTERACT'\r
3080        INCLUDE 'COMMON.IOUNITS'\r
3081        INCLUDE 'COMMON.LOCAL'\r
3082        INCLUDE 'COMMON.NAMES'\r
3083        INCLUDE 'COMMON.VAR'\r
3084        double precision scalar\r
3085        alphapol2 = alphapol(itypj,itypi)\r
3086        w1        = wqdip(1,itypi,itypj)\r
3087        w2        = wqdip(2,itypi,itypj)\r
3088        pis  = sig0head(itypi,itypj)\r
3089        eps0 = epshead(itypi,itypj)\r
3090 c!-------------------------------------------------------------------\r
3091 c! R2 - distance between head of jth side chain and tail of ith sidechain\r
3092        R2 = 0.0d0\r
3093        DO k = 1, 3\r
3094 c! Calculate head-to-tail distances\r
3095         R2=R2+(chead(k,2)-ctail(k,1))**2\r
3096        END DO\r
3097 c! Pitagoras\r
3098        R2 = dsqrt(R2)\r
3099 \r
3100 c!-------------------------------------------------------------------\r
3101 c! ecl\r
3102        sparrow  = w1 * Qi * om1 \r
3103        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)\r
3104        ECL = sparrow / Rhead**2.0d0\r
3105      &     - hawk    / Rhead**4.0d0\r
3106 c!       write (iout,*) "ECL = ", ECL\r
3107 c!       Ecl = 0.0d0\r
3108 c!-------------------------------------------------------------------\r
3109 c! derivative of ecl is Gcl\r
3110 c! dF/dr part\r
3111        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0\r
3112      &           + 4.0d0 * hawk    / Rhead**5.0d0\r
3113 c!       dGCLdR = 0.0d0\r
3114 c! dF/dom1\r
3115        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)\r
3116 c!       dGCLdOM1 = 0.0d0\r
3117 c! dF/dom2\r
3118        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)\r
3119 c!       dGCLdOM2 = 0.0d0\r
3120 c--------------------------------------------------------------------\r
3121 c Polarization energy\r
3122 c Epol\r
3123        MomoFac2 = (1.0d0 - chi2 * sqom1)\r
3124        RR2  = R2 * R2 / MomoFac2\r
3125        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))\r
3126        fgb2 = sqrt(RR2  + a12sq * ee2)\r
3127        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )\r
3128 c!       write (iout,*) "EPOL = ", EPOL\r
3129 c!       epol = 0.0d0\r
3130 c!------------------------------------------------------------------\r
3131 c! derivative of Epol is Gpol...\r
3132        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)\r
3133      &          / (fgb2 ** 5.0d0)\r
3134        dFGBdR2 = ( (R2 / MomoFac2)\r
3135      &        * ( 2.0d0 - (0.5d0 * ee2) ) )\r
3136      &        / (2.0d0 * fgb2)\r
3137        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))\r
3138      &          * (2.0d0 - 0.5d0 * ee2) )\r
3139      &          / (2.0d0 * fgb2)\r
3140        dPOLdR2 = dPOLdFGB2 * dFGBdR2\r
3141 c!       dPOLdR1 = 0.0d0\r
3142        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1\r
3143 c!       dPOLdOM1 = 0.0d0\r
3144        dPOLdOM2 = 0.0d0\r
3145 c!-------------------------------------------------------------------\r
3146 c! Elj\r
3147        pom = (pis / Rhead)**6.0d0\r
3148        Elj = 4.0d0 * eps0 * pom * (pom-1.0d0)\r
3149 c!       write (iout,*) "ELJ = ", ELJ\r
3150 c! derivative of Elj is Glj\r
3151        dGLJdR = 4.0d0 * eps0 \r
3152      &     * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))\r
3153      &     +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))\r
3154 c!-------------------------------------------------------------------\r
3155 c! Return the results\r
3156        DO k = 1, 3\r
3157         erhead(k) = Rhead_distance(k)/Rhead\r
3158         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)\r
3159        END DO\r
3160 \r
3161        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )\r
3162        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )\r
3163        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )\r
3164        facd1 = d1 * vbld_inv(i+nres)\r
3165        facd2 = d2 * vbld_inv(j+nres)\r
3166 \r
3167        DO k = 1, 3\r
3168         condor = (erhead_tail(k,2)\r
3169      & + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))\r
3170 \r
3171         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))\r
3172         gvdwx(k,i) = gvdwx(k,i)\r
3173      &             - dGCLdR * pom\r
3174      &             - dPOLdR2 * erhead_tail(k,2)\r
3175      &             - dGLJdR * pom\r
3176 \r
3177         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))\r
3178         gvdwx(k,j) = gvdwx(k,j)\r
3179      &             + dGCLdR * pom\r
3180      &             + dPOLdR2 * condor\r
3181      &             + dGLJdR * pom\r
3182 \r
3183 \r
3184         gvdwc(k,i) = gvdwc(k,i)\r
3185      &             - dGCLdR * erhead(k)\r
3186      &             - dPOLdR2 * erhead_tail(k,2)\r
3187      &             - dGLJdR * erhead(k)\r
3188 \r
3189         gvdwc(k,j) = gvdwc(k,j)\r
3190      &             + dGCLdR * erhead(k)\r
3191      &             + dPOLdR2 * erhead_tail(k,2)\r
3192      &             + dGLJdR * erhead(k)\r
3193 \r
3194        END DO\r
3195        RETURN\r
3196       END SUBROUTINE edq\r
3197 \r
3198 \r
3199 C--------------------------------------------------------------------\r
3200 \r
3201 \r
3202       SUBROUTINE edd(ECL)\r
3203        IMPLICIT NONE\r
3204        INCLUDE 'DIMENSIONS'\r
3205        INCLUDE 'COMMON.CALC'\r
3206        INCLUDE 'COMMON.CHAIN'\r
3207        INCLUDE 'COMMON.CONTROL'\r
3208        INCLUDE 'COMMON.DERIV'\r
3209        INCLUDE 'COMMON.EMP'\r
3210        INCLUDE 'COMMON.GEO'\r
3211        INCLUDE 'COMMON.INTERACT'\r
3212        INCLUDE 'COMMON.IOUNITS'\r
3213        INCLUDE 'COMMON.LOCAL'\r
3214        INCLUDE 'COMMON.NAMES'\r
3215        INCLUDE 'COMMON.VAR'\r
3216        double precision scalar\r
3217        csig = sigiso(itypi,itypj)\r
3218        w1 = wqdip(1,itypi,itypj)\r
3219        w2 = wqdip(2,itypi,itypj)\r
3220 c! intermediates\r
3221        sparrow  = -3.0d0 * w1\r
3222        rosella  = 6.0d0 * w2\r
3223        hawk = Rhead**3.0d0\r
3224 c! bat = R^6\r
3225        bat = hawk**2.0d0\r
3226 c! condor = -3w1 / R^3\r
3227        condor  = sparrow / hawk\r
3228 c! eagle = 6w2 / R^6\r
3229        eagle = rosella / bat\r
3230        fac = (om12 - 3.0d0 * om1 * om2)\r
3231        c1 = (w1 / hawk) * fac\r
3232        c2 = (w2 / Rhead ** 6.0d0)\r
3233      &    * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))\r
3234        ECL = c1 - c2\r
3235 c!-------------------------------------------------------------------\r
3236 c! dervative of ECL is GCL...\r
3237 c! dECL/dr\r
3238        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)\r
3239        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0)\r
3240      &    * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))\r
3241        dGCLdR = c1 - c2\r
3242 c! dECL/dom1\r
3243        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)\r
3244        c2 = (-6.0d0 * w2) / (Rhead**6.0d0)\r
3245      &    * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )\r
3246        dGCLdOM1 = c1 - c2\r
3247 c! dECL/dom2\r
3248        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)\r
3249        c2 = (-6.0d0 * w2) / (Rhead**6.0d0)\r
3250      &    * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )\r
3251        dGCLdOM2 = c1 - c2\r
3252 c! dECL/dom12\r
3253        c1 = w1 / (Rhead ** 3.0d0)\r
3254        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0\r
3255        dGCLdOM12 = c1 - c2\r
3256 c!-------------------------------------------------------------------\r
3257 c! Return the results\r
3258        DO k= 1, 3\r
3259         erhead(k) = Rhead_distance(k)/Rhead\r
3260        END DO\r
3261        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )\r
3262        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )\r
3263        facd1 = d1 * vbld_inv(i+nres)\r
3264        facd2 = d2 * vbld_inv(j+nres)\r
3265        DO k = 1, 3\r
3266 \r
3267         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))\r
3268         gvdwx(k,i) = gvdwx(k,i)\r
3269      &             - dGCLdR * pom\r
3270         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))\r
3271         gvdwx(k,j) = gvdwx(k,j)\r
3272      &             + dGCLdR * pom\r
3273 \r
3274         gvdwc(k,i) = gvdwc(k,i)\r
3275      &             - dGCLdR * erhead(k)\r
3276         gvdwc(k,j) = gvdwc(k,j)\r
3277      &             + dGCLdR * erhead(k)\r
3278        END DO\r
3279        RETURN\r
3280       END SUBROUTINE edd\r
3281 \r
3282 \r
3283 c!-------------------------------------------------------------------\r
3284 \r
3285 \r
3286       SUBROUTINE elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)\r
3287        IMPLICIT NONE\r
3288 c! maxres\r
3289        INCLUDE 'DIMENSIONS'\r
3290 c! itypi, itypj, i, j, k, l, chead, \r
3291        INCLUDE 'COMMON.CALC'\r
3292 c! c, nres, dc_norm\r
3293        INCLUDE 'COMMON.CHAIN'\r
3294 c! gradc, gradx\r
3295        INCLUDE 'COMMON.DERIV'\r
3296 c! electrostatic gradients-specific variables\r
3297        INCLUDE 'COMMON.EMP'\r
3298 c! wquad, dhead, alphiso, alphasur, rborn, epsintab\r
3299        INCLUDE 'COMMON.INTERACT'\r
3300 c! Rb\r
3301        INCLUDE 'COMMON.MD'\r
3302 c! io for debug, disable it in final builds\r
3303        INCLUDE 'COMMON.IOUNITS'\r
3304 c!-------------------------------------------------------------------\r
3305 c! Variable Init\r
3306 \r
3307 c! what amino acid is the aminoacid j'th?\r
3308        itypj=itype(j)\r
3309 c! 1/(Gas Constant * Thermostate temperature) = BetaT\r
3310        BetaT = 1.0d0 / (t_bath * Rb)\r
3311 c!       write (*,*) "t_bath = ", t_bath, "Rb = ", Rb\r
3312 c!       write (*,'(a,f5.3)') " Betat = ", BetaT\r
3313 c! Gay-berne var's\r
3314        sig0ij = sigma( itypi,itypj )\r
3315        chi1   = chi( itypi, itypj )\r
3316        chi2   = chi( itypj, itypi )\r
3317        chi12  = chi1 * chi2\r
3318        chip1  = chipp( itypi, itypj )\r
3319        chip2  = chipp( itypj, itypi )\r
3320        chip12 = chip1 * chip2\r
3321 c! not used by momo potential, but needed by sc_angular which is shared\r
3322 c! by all energy_potential subroutines\r
3323        alf1   = 0.0d0\r
3324        alf2   = 0.0d0\r
3325        alf12  = 0.0d0\r
3326 c! location, location, location\r
3327        xj  = c( 1, nres+j ) - xi\r
3328        yj  = c( 2, nres+j ) - yi\r
3329        zj  = c( 3, nres+j ) - zi\r
3330        dxj = dc_norm( 1, nres+j )\r
3331        dyj = dc_norm( 2, nres+j )\r
3332        dzj = dc_norm( 3, nres+j )\r
3333 c! distance from center of chain(?) to polar/charged head\r
3334        d1 = dhead(1, 1, itypi, itypj)\r
3335        d2 = dhead(2, 1, itypi, itypj)\r
3336 c! ai*aj from Fgb\r
3337        a12sq = rborn(itypi,itypj)\r
3338        a12sq = a12sq * a12sq\r
3339 c! charge of amino acid itypi is...\r
3340        Qi  = icharge(itypi)\r
3341        Qj  = icharge(itypj)\r
3342        Qij = Qi * Qj\r
3343 c! Eps'(i,j) for Elj\r
3344        eps_head = epshead(itypi,itypj)\r
3345 c! chis1,2,12\r
3346        chis1 = chis(itypi,itypj) \r
3347        chis2 = chis(itypj,itypi)\r
3348        chis12 = chis1 * chis2\r
3349        sig1 = sigmap(itypi,itypj)\r
3350        sig2 = sigmap(itypj,itypi)\r
3351 c! alpha factors from Fcav/Gcav\r
3352        b1 = alphasur(1,itypi,itypj)\r
3353        b2 = alphasur(2,itypi,itypj)\r
3354        b3 = alphasur(3,itypi,itypj)\r
3355        b4 = alphasur(4,itypi,itypj)\r
3356 c! used to determine wheter we want to do quadrupole calculations\r
3357        wqd = wquad(itypi, itypj)\r
3358        eps_in = epsintab(itypi,itypj)\r
3359        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))\r
3360 c!       write (*,*) "eps_inout_fac = ", eps_inout_fac\r
3361 c!-------------------------------------------------------------------\r
3362 c! tail location and distance calculations\r
3363 c! shameless ripoff from emomo\r
3364        Rtail = 0.0d0\r
3365        DO k = 1, 3\r
3366         ctail(k,1)=c(k,i+nres)-dtail(k,itypi)*dc_norm(k,nres+i)\r
3367         ctail(k,2)=c(k,j+nres)-dtail(k,itypj)*dc_norm(k,nres+j)\r
3368        END DO\r
3369 c! tail distances will be themselves usefull elswhere\r
3370 c1 (in Gcav, for example)\r
3371        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )\r
3372        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )\r
3373        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )\r
3374        Rtail = dsqrt(\r
3375      &     (Rtail_distance(1)*Rtail_distance(1))\r
3376      &   + (Rtail_distance(2)*Rtail_distance(2))\r
3377      &   + (Rtail_distance(3)*Rtail_distance(3)))\r
3378 c!-------------------------------------------------------------------\r
3379 c! Calculate location and distance between polar heads\r
3380 c! distance between heads\r
3381 c! for each one of our three dimensional space...\r
3382        DO k = 1,3\r
3383 c! location of polar head is computed by taking hydrophobic centre\r
3384 c! and moving by a d1 * dc_norm vector\r
3385 c! see unres publications for very informative images\r
3386         chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)\r
3387         chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)\r
3388 c! distance \r
3389 c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))\r
3390 c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)\r
3391         Rhead_distance(k) = chead(k,2) - chead(k,1)\r
3392        END DO\r
3393 c! pitagoras (root of sum of squares)\r
3394        Rhead = dsqrt(\r
3395      &     (Rhead_distance(1)*Rhead_distance(1))\r
3396      &   + (Rhead_distance(2)*Rhead_distance(2))\r
3397      &   + (Rhead_distance(3)*Rhead_distance(3)))\r
3398 c!-------------------------------------------------------------------\r
3399 c! zero everything that should be zero'ed\r
3400        Egb = 0.0d0\r
3401        ECL = 0.0d0\r
3402        Elj = 0.0d0\r
3403        Equad = 0.0d0\r
3404        Epol = 0.0d0\r
3405        eheadtail = 0.0d0\r
3406        dGCLdR = 0.0d0\r
3407        dGCLdOM1 = 0.0d0\r
3408        dGCLdOM2 = 0.0d0\r
3409        dGCLdOM12 = 0.0d0\r
3410        dPOLdR1 = 0.0d0\r
3411        dPOLdOM1 = 0.0d0\r
3412        dPOLdOM2 = 0.0d0\r
3413        Glj = 0.0d0\r
3414        dGLJdR = 0.0d0\r
3415        dGLJdOM1 = 0.0d0\r
3416        dGLJdOM2 = 0.0d0\r
3417        dGLJdOM12 = 0.0d0\r
3418        RETURN\r
3419       END SUBROUTINE elgrad_init\r
3420 \r
3421 \r
3422 c!-------------------------------------------------------------------\r
3423 \r
3424 \r
3425       SUBROUTINE sc_angular\r
3426 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,\r
3427 C om12. Called by ebp, egb, egbv, and emomo\r
3428        IMPLICIT NONE\r
3429 c! ntyp needed in other commons\r
3430        INCLUDE 'DIMENSIONS'\r
3431        INCLUDE 'COMMON.CALC'\r
3432 c! chi()\r
3433        INCLUDE 'COMMON.INTERACT'\r
3434        INCLUDE 'COMMON.IOUNITS'\r
3435        INCLUDE 'COMMON.EMP'\r
3436 \r
3437        erij(1) = xj * rij\r
3438        erij(2) = yj * rij\r
3439        erij(3) = zj * rij\r
3440        om1  = dxi * erij(1) + dyi * erij(2) + dzi * erij(3)\r
3441        om2  = dxj * erij(1) + dyj * erij(2) + dzj * erij(3)\r
3442        om12 = dxi * dxj     + dyi * dyj     + dzi * dzj\r
3443        chiom12 = chi12 * om12\r
3444 C Calculate eps1(om12) and its derivative in om12\r
3445        faceps1     = 1.0D0 - om12 * chiom12\r
3446        faceps1_inv = 1.0D0 / faceps1\r
3447        eps1 = dsqrt(faceps1_inv)\r
3448 C Following variable is eps1*deps1/dom12\r
3449        eps1_om12 = faceps1_inv * chiom12\r
3450 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,\r
3451 C and om12.\r
3452        om1om2 = om1  * om2\r
3453        chiom1 = chi1 * om1\r
3454        chiom2 = chi2 * om2\r
3455        facsig = om1  * chiom1 + om2 * chiom2\r
3456      &       - 2.0D0 * om1om2 * chiom12\r
3457        sigsq  = 1.0D0 - facsig * faceps1_inv\r
3458        sigsq_om1  = (chiom1 - chiom12 * om2) * faceps1_inv\r
3459        sigsq_om2  = (chiom2 - chiom12 * om1) * faceps1_inv\r
3460        sigsq_om12 = -chi12 * (om1om2 * faceps1 - om12 * facsig)\r
3461      &           * faceps1_inv**2\r
3462 C Calculate eps2 and its derivatives in om1, om2, and om12.\r
3463        chipom1  = chip1  * om1\r
3464        chipom2  = chip2  * om2\r
3465        chipom12 = chip12 * om12\r
3466        facp     = 1.0D0 - om12 * chipom12\r
3467        facp_inv = 1.0D0 / facp\r
3468        facp1 = om1 * chipom1 + om2 * chipom2\r
3469      &       -2.0D0 * om1om2 * chipom12\r
3470 C Following variable is the square root of eps2\r
3471        eps2rt = 1.0D0 - facp1 * facp_inv\r
3472 \r
3473 C Following three variables are the derivatives of the square root of eps\r
3474 C in om1, om2, and om12.\r
3475        eps2rt_om1  =-4.0D0 * (chipom1 - chipom12 * om2) * facp_inv\r
3476        eps2rt_om2  =-4.0D0 * (chipom2 - chipom12 * om1) * facp_inv\r
3477        eps2rt_om12 = 4.0D0 * chip12\r
3478      &             * (om1om2*facp-om12*facp1)*facp_inv**2 \r
3479 \r
3480 c! Evaluate the "asymmetric" factor in the VDW constant, eps3\r
3481 c! Note that THIS is 0 in emomo, so we should probably move it out of sc_angular\r
3482 c! Or frankly, we should restructurize the whole energy section\r
3483        eps3rt = 1.0D0 - alf1 * om1 + alf2 * om2 - alf12 * om12\r
3484 \r
3485 C Calculate whole angle-dependent part of epsilon and contributions\r
3486 C to its derivatives\r
3487 \r
3488        RETURN\r
3489       END SUBROUTINE sc_angular\r
3490 \r
3491 \r
3492 C--------------------------------------------------------------------\r
3493 \r
3494 \r
3495       subroutine sc_grad_T\r
3496       implicit real*8 (a-h,o-z)\r
3497       include 'DIMENSIONS'\r
3498       include 'COMMON.CHAIN'\r
3499       include 'COMMON.DERIV'\r
3500       include 'COMMON.CALC'\r
3501       include 'COMMON.IOUNITS'\r
3502       double precision dcosom1(3),dcosom2(3)\r
3503       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1\r
3504       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2\r
3505       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12\r
3506      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12\r
3507 c diagnostics only\r
3508 c      eom1=0.0d0\r
3509 c      eom2=0.0d0\r
3510 c      eom12=evdwij*eps1_om12\r
3511 c end diagnostics\r
3512 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,\r
3513 c     &  " sigder",sigder\r
3514 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12\r
3515 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12\r
3516       do k=1,3\r
3517         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))\r
3518         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))\r
3519       enddo\r
3520       do k=1,3\r
3521         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)\r
3522       enddo \r
3523 c      write (iout,*) "gg",(gg(k),k=1,3)\r
3524       do k=1,3\r
3525         gvdwxT(k,i)=gvdwxT(k,i)-gg(k)\r
3526      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))\r
3527      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv\r
3528         gvdwxT(k,j)=gvdwxT(k,j)+gg(k)\r
3529      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))\r
3530      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv\r
3531 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))\r
3532 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv\r
3533 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))\r
3534 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv\r
3535       enddo\r
3536 C \r
3537 C Calculate the components of the gradient in DC and X\r
3538 C\r
3539 cgrad      do k=i,j-1\r
3540 cgrad        do l=1,3\r
3541 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)\r
3542 cgrad        enddo\r
3543 cgrad      enddo\r
3544       do l=1,3\r
3545         gvdwcT(l,i)=gvdwcT(l,i)-gg(l)\r
3546         gvdwcT(l,j)=gvdwcT(l,j)+gg(l)\r
3547       enddo\r
3548       return\r
3549       end\r
3550 \r
3551 \r
3552 C--------------------------------------------------------------------\r
3553 \r
3554 \r
3555       SUBROUTINE sc_grad\r
3556        IMPLICIT real*8 (a-h,o-z)\r
3557        INCLUDE 'DIMENSIONS'\r
3558        INCLUDE 'COMMON.CHAIN'\r
3559        INCLUDE 'COMMON.DERIV'\r
3560        INCLUDE 'COMMON.CALC'\r
3561        INCLUDE 'COMMON.IOUNITS'\r
3562        INCLUDE 'COMMON.EMP'\r
3563        double precision dcosom1(3),dcosom2(3)\r
3564 \r
3565 c! each eom holds sum of omega-angular derivatives of each component\r
3566 c! of energy function. First GGB, then Gcav, dipole-dipole,...\r
3567        eom1  =\r
3568      &         eps2der * eps2rt_om1\r
3569      &       - 2.0D0 * alf1 * eps3der\r
3570      &       + sigder * sigsq_om1\r
3571      &       + dCAVdOM1\r
3572      &       + dGCLdOM1\r
3573      &       + dPOLdOM1\r
3574 \r
3575        eom2  =\r
3576      &         eps2der * eps2rt_om2\r
3577      &       + 2.0D0 * alf2 * eps3der\r
3578      &       + sigder * sigsq_om2\r
3579      &       + dCAVdOM2\r
3580      &       + dGCLdOM2\r
3581      &       + dPOLdOM2\r
3582 \r
3583        eom12 =\r
3584      &         evdwij  * eps1_om12\r
3585      &       + eps2der * eps2rt_om12\r
3586      &       - 2.0D0 * alf12 * eps3der\r
3587      &       + sigder *sigsq_om12\r
3588      &       + dCAVdOM12\r
3589      &       + dGCLdOM12\r
3590 \r
3591 c! now some magical transformations to project gradient into\r
3592 c! three cartesian vectors\r
3593 \r
3594        DO k = 1, 3\r
3595         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))\r
3596         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))\r
3597         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)\r
3598 c! this acts on hydrophobic center of interaction\r
3599         gvdwx(k,i)= gvdwx(k,i) - gg(k)\r
3600      &            + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))\r
3601      &            + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv\r
3602         gvdwx(k,j)= gvdwx(k,j) + gg(k)\r
3603      &            + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))\r
3604      &            + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv\r
3605 c! this acts on Calpha\r
3606         gvdwc(k,i)=gvdwc(k,i)-gg(k)\r
3607         gvdwc(k,j)=gvdwc(k,j)+gg(k)\r
3608        END DO\r
3609        RETURN\r
3610       END SUBROUTINE sc_grad\r
3611 \r
3612 \r
3613 C--------------------------------------------------------------------\r
3614 \r
3615 \r
3616       subroutine e_softsphere(evdw)\r
3617 C\r
3618 C This subroutine calculates the interaction energy of nonbonded side chains\r
3619 C assuming the LJ potential of interaction.\r
3620 C\r
3621       implicit real*8 (a-h,o-z)\r
3622       include 'DIMENSIONS'\r
3623       parameter (accur=1.0d-10)\r
3624       include 'COMMON.GEO'\r
3625       include 'COMMON.VAR'\r
3626       include 'COMMON.LOCAL'\r
3627       include 'COMMON.CHAIN'\r
3628       include 'COMMON.DERIV'\r
3629       include 'COMMON.INTERACT'\r
3630       include 'COMMON.TORSION'\r
3631       include 'COMMON.SBRIDGE'\r
3632       include 'COMMON.NAMES'\r
3633       include 'COMMON.IOUNITS'\r
3634       include 'COMMON.CONTACTS'\r
3635       dimension gg(3)\r
3636 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct\r
3637       evdw=0.0D0\r
3638       do i=iatsc_s,iatsc_e\r
3639         itypi=itype(i)\r
3640         itypi1=itype(i+1)\r
3641         xi=c(1,nres+i)\r
3642         yi=c(2,nres+i)\r
3643         zi=c(3,nres+i)\r
3644 C\r
3645 C Calculate SC interaction energy.\r
3646 C\r
3647         do iint=1,nint_gr(i)\r
3648 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),\r
3649 cd   &                  'iend=',iend(i,iint)\r
3650           do j=istart(i,iint),iend(i,iint)\r
3651             itypj=itype(j)\r
3652             xj=c(1,nres+j)-xi\r
3653             yj=c(2,nres+j)-yi\r
3654             zj=c(3,nres+j)-zi\r
3655             rij=xj*xj+yj*yj+zj*zj\r
3656 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj\r
3657             r0ij=r0(itypi,itypj)\r
3658             r0ijsq=r0ij*r0ij\r
3659 c            print *,i,j,r0ij,dsqrt(rij)\r
3660             if (rij.lt.r0ijsq) then\r
3661               evdwij=0.25d0*(rij-r0ijsq)**2\r
3662               fac=rij-r0ijsq\r
3663             else\r
3664               evdwij=0.0d0\r
3665               fac=0.0d0\r
3666             endif\r
3667             evdw=evdw+evdwij\r
3668 C \r
3669 C Calculate the components of the gradient in DC and X\r
3670 C\r
3671             gg(1)=xj*fac\r
3672             gg(2)=yj*fac\r
3673             gg(3)=zj*fac\r
3674             do k=1,3\r
3675               gvdwx(k,i)=gvdwx(k,i)-gg(k)\r
3676               gvdwx(k,j)=gvdwx(k,j)+gg(k)\r
3677               gvdwc(k,i)=gvdwc(k,i)-gg(k)\r
3678               gvdwc(k,j)=gvdwc(k,j)+gg(k)\r
3679             enddo\r
3680 cgrad            do k=i,j-1\r
3681 cgrad              do l=1,3\r
3682 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)\r
3683 cgrad              enddo\r
3684 cgrad            enddo\r
3685           enddo ! j\r
3686         enddo ! iint\r
3687       enddo ! i\r
3688       return\r
3689       end\r
3690 \r
3691 \r
3692 C--------------------------------------------------------------------\r
3693 \r
3694 \r
3695       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,\r
3696      &              eello_turn4)\r
3697 C\r
3698 C Soft-sphere potential of p-p interaction\r
3699 C \r
3700       implicit real*8 (a-h,o-z)\r
3701       include 'DIMENSIONS'\r
3702       include 'COMMON.CONTROL'\r
3703       include 'COMMON.IOUNITS'\r
3704       include 'COMMON.GEO'\r
3705       include 'COMMON.VAR'\r
3706       include 'COMMON.LOCAL'\r
3707       include 'COMMON.CHAIN'\r
3708       include 'COMMON.DERIV'\r
3709       include 'COMMON.INTERACT'\r
3710       include 'COMMON.CONTACTS'\r
3711       include 'COMMON.TORSION'\r
3712       include 'COMMON.VECTORS'\r
3713       include 'COMMON.FFIELD'\r
3714       dimension ggg(3)\r
3715 cd      write(iout,*) 'In EELEC_soft_sphere'\r
3716       ees=0.0D0\r
3717       evdw1=0.0D0\r
3718       eel_loc=0.0d0 \r
3719       eello_turn3=0.0d0\r
3720       eello_turn4=0.0d0\r
3721       ind=0\r
3722       do i=iatel_s,iatel_e\r
3723         dxi=dc(1,i)\r
3724         dyi=dc(2,i)\r
3725         dzi=dc(3,i)\r
3726         xmedi=c(1,i)+0.5d0*dxi\r
3727         ymedi=c(2,i)+0.5d0*dyi\r
3728         zmedi=c(3,i)+0.5d0*dzi\r
3729         num_conti=0\r
3730 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)\r
3731         do j=ielstart(i),ielend(i)\r
3732           ind=ind+1\r
3733           iteli=itel(i)\r
3734           itelj=itel(j)\r
3735           if (j.eq.i+2 .and. itelj.eq.2) iteli=2\r
3736           r0ij=rpp(iteli,itelj)\r
3737           r0ijsq=r0ij*r0ij \r
3738           dxj=dc(1,j)\r
3739           dyj=dc(2,j)\r
3740           dzj=dc(3,j)\r
3741           xj=c(1,j)+0.5D0*dxj-xmedi\r
3742           yj=c(2,j)+0.5D0*dyj-ymedi\r
3743           zj=c(3,j)+0.5D0*dzj-zmedi\r
3744           rij=xj*xj+yj*yj+zj*zj\r
3745           if (rij.lt.r0ijsq) then\r
3746             evdw1ij=0.25d0*(rij-r0ijsq)**2\r
3747             fac=rij-r0ijsq\r
3748           else\r
3749             evdw1ij=0.0d0\r
3750             fac=0.0d0\r
3751           endif\r
3752           evdw1=evdw1+evdw1ij\r
3753 C\r
3754 C Calculate contributions to the Cartesian gradient.\r
3755 C\r
3756           ggg(1)=fac*xj\r
3757           ggg(2)=fac*yj\r
3758           ggg(3)=fac*zj\r
3759           do k=1,3\r
3760             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)\r
3761             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)\r
3762           enddo\r
3763 *\r
3764 * Loop over residues i+1 thru j-1.\r
3765 *\r
3766 cgrad          do k=i+1,j-1\r
3767 cgrad            do l=1,3\r
3768 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)\r
3769 cgrad            enddo\r
3770 cgrad          enddo\r
3771         enddo ! j\r
3772       enddo   ! i\r
3773 cgrad      do i=nnt,nct-1\r
3774 cgrad        do k=1,3\r
3775 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)\r
3776 cgrad        enddo\r
3777 cgrad        do j=i+1,nct-1\r
3778 cgrad          do k=1,3\r
3779 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)\r
3780 cgrad          enddo\r
3781 cgrad        enddo\r
3782 cgrad      enddo\r
3783       return\r
3784       end\r
3785 \r
3786 \r
3787 c--------------------------------------------------------------------\r
3788 \r
3789 \r
3790       subroutine vec_and_deriv\r
3791       implicit real*8 (a-h,o-z)\r
3792       include 'DIMENSIONS'\r
3793 #ifdef MPI\r
3794       include 'mpif.h'\r
3795 #endif\r
3796       include 'COMMON.IOUNITS'\r
3797       include 'COMMON.GEO'\r
3798       include 'COMMON.VAR'\r
3799       include 'COMMON.LOCAL'\r
3800       include 'COMMON.CHAIN'\r
3801       include 'COMMON.VECTORS'\r
3802       include 'COMMON.SETUP'\r
3803       include 'COMMON.TIME1'\r
3804       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)\r
3805 C Compute the local reference systems. For reference system (i), the\r
3806 C X-axis points from CA(i) to CA(i+1), the Y axis is in the \r
3807 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.\r
3808 #ifdef PARVEC\r
3809       do i=ivec_start,ivec_end\r
3810 #else\r
3811       do i=1,nres-1\r
3812 #endif\r
3813           if (i.eq.nres-1) then\r
3814 C Case of the last full residue\r
3815 C Compute the Z-axis\r
3816             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))\r
3817             costh=dcos(pi-theta(nres))\r
3818             fac=1.0d0/dsqrt(1.0d0-costh*costh)\r
3819             do k=1,3\r
3820               uz(k,i)=fac*uz(k,i)\r
3821             enddo\r
3822 C Compute the derivatives of uz\r
3823             uzder(1,1,1)= 0.0d0\r
3824             uzder(2,1,1)=-dc_norm(3,i-1)\r
3825             uzder(3,1,1)= dc_norm(2,i-1) \r
3826             uzder(1,2,1)= dc_norm(3,i-1)\r
3827             uzder(2,2,1)= 0.0d0\r
3828             uzder(3,2,1)=-dc_norm(1,i-1)\r
3829             uzder(1,3,1)=-dc_norm(2,i-1)\r
3830             uzder(2,3,1)= dc_norm(1,i-1)\r
3831             uzder(3,3,1)= 0.0d0\r
3832             uzder(1,1,2)= 0.0d0\r
3833             uzder(2,1,2)= dc_norm(3,i)\r
3834             uzder(3,1,2)=-dc_norm(2,i) \r
3835             uzder(1,2,2)=-dc_norm(3,i)\r
3836             uzder(2,2,2)= 0.0d0\r
3837             uzder(3,2,2)= dc_norm(1,i)\r
3838             uzder(1,3,2)= dc_norm(2,i)\r
3839             uzder(2,3,2)=-dc_norm(1,i)\r
3840             uzder(3,3,2)= 0.0d0\r
3841 C Compute the Y-axis\r
3842             facy=fac\r
3843             do k=1,3\r
3844               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))\r
3845             enddo\r
3846 C Compute the derivatives of uy\r
3847             do j=1,3\r
3848               do k=1,3\r
3849                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)\r
3850      &                        -dc_norm(k,i)*dc_norm(j,i-1)\r
3851                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)\r
3852               enddo\r
3853               uyder(j,j,1)=uyder(j,j,1)-costh\r
3854               uyder(j,j,2)=1.0d0+uyder(j,j,2)\r
3855             enddo\r
3856             do j=1,2\r
3857               do k=1,3\r
3858                 do l=1,3\r
3859                   uygrad(l,k,j,i)=uyder(l,k,j)\r
3860                   uzgrad(l,k,j,i)=uzder(l,k,j)\r
3861                 enddo\r
3862               enddo\r
3863             enddo \r
3864             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))\r
3865             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))\r
3866             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))\r
3867             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))\r
3868           else\r
3869 C Other residues\r
3870 C Compute the Z-axis\r
3871             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))\r
3872             costh=dcos(pi-theta(i+2))\r
3873             fac=1.0d0/dsqrt(1.0d0-costh*costh)\r
3874             do k=1,3\r
3875               uz(k,i)=fac*uz(k,i)\r
3876             enddo\r
3877 C Compute the derivatives of uz\r
3878             uzder(1,1,1)= 0.0d0\r
3879             uzder(2,1,1)=-dc_norm(3,i+1)\r
3880             uzder(3,1,1)= dc_norm(2,i+1) \r
3881             uzder(1,2,1)= dc_norm(3,i+1)\r
3882             uzder(2,2,1)= 0.0d0\r
3883             uzder(3,2,1)=-dc_norm(1,i+1)\r
3884             uzder(1,3,1)=-dc_norm(2,i+1)\r
3885             uzder(2,3,1)= dc_norm(1,i+1)\r
3886             uzder(3,3,1)= 0.0d0\r
3887             uzder(1,1,2)= 0.0d0\r
3888             uzder(2,1,2)= dc_norm(3,i)\r
3889             uzder(3,1,2)=-dc_norm(2,i) \r
3890             uzder(1,2,2)=-dc_norm(3,i)\r
3891             uzder(2,2,2)= 0.0d0\r
3892             uzder(3,2,2)= dc_norm(1,i)\r
3893             uzder(1,3,2)= dc_norm(2,i)\r
3894             uzder(2,3,2)=-dc_norm(1,i)\r
3895             uzder(3,3,2)= 0.0d0\r
3896 C Compute the Y-axis\r
3897             facy=fac\r
3898             do k=1,3\r
3899               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))\r
3900             enddo\r
3901 C Compute the derivatives of uy\r
3902             do j=1,3\r
3903               do k=1,3\r
3904                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)\r
3905      &                        -dc_norm(k,i)*dc_norm(j,i+1)\r
3906                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)\r
3907               enddo\r
3908               uyder(j,j,1)=uyder(j,j,1)-costh\r
3909               uyder(j,j,2)=1.0d0+uyder(j,j,2)\r
3910             enddo\r
3911             do j=1,2\r
3912               do k=1,3\r
3913                 do l=1,3\r
3914                   uygrad(l,k,j,i)=uyder(l,k,j)\r
3915                   uzgrad(l,k,j,i)=uzder(l,k,j)\r
3916                 enddo\r
3917               enddo\r
3918             enddo \r
3919             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))\r
3920             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))\r
3921             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))\r
3922             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))\r
3923           endif\r
3924       enddo\r
3925       do i=1,nres-1\r
3926         vbld_inv_temp(1)=vbld_inv(i+1)\r
3927         if (i.lt.nres-1) then\r
3928           vbld_inv_temp(2)=vbld_inv(i+2)\r
3929           else\r
3930           vbld_inv_temp(2)=vbld_inv(i)\r
3931           endif\r
3932         do j=1,2\r
3933           do k=1,3\r
3934             do l=1,3\r
3935               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)\r
3936               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)\r
3937             enddo\r
3938           enddo\r
3939         enddo\r
3940       enddo\r
3941 #if defined(PARVEC) && defined(MPI)\r
3942       if (nfgtasks1.gt.1) then\r
3943         time00=MPI_Wtime()\r
3944 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,\r
3945 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),\r
3946 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)\r
3947         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),\r
3948      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,\r
3949      &   FG_COMM1,IERR)\r
3950         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),\r
3951      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,\r
3952      &   FG_COMM1,IERR)\r
3953         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),\r
3954      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),\r
3955      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)\r
3956         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),\r
3957      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),\r
3958      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)\r
3959         time_gather=time_gather+MPI_Wtime()-time00\r
3960       endif\r
3961 c      if (fg_rank.eq.0) then\r
3962 c        write (iout,*) "Arrays UY and UZ"\r
3963 c        do i=1,nres-1\r
3964 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),\r
3965 c     &     (uz(k,i),k=1,3)\r
3966 c        enddo\r
3967 c      endif\r
3968 #endif\r
3969       return\r
3970       end\r
3971 \r
3972 \r
3973 C--------------------------------------------------------------------\r
3974 \r
3975 \r
3976       subroutine check_vecgrad\r
3977       implicit real*8 (a-h,o-z)\r
3978       include 'DIMENSIONS'\r
3979       include 'COMMON.IOUNITS'\r
3980       include 'COMMON.GEO'\r
3981       include 'COMMON.VAR'\r
3982       include 'COMMON.LOCAL'\r
3983       include 'COMMON.CHAIN'\r
3984       include 'COMMON.VECTORS'\r
3985       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)\r
3986       dimension uyt(3,maxres),uzt(3,maxres)\r
3987       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)\r
3988       double precision delta /1.0d-7/\r
3989       call vec_and_deriv\r
3990 cd      do i=1,nres\r
3991 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)\r
3992 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)\r
3993 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)\r
3994 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,\r
3995 cd     &     (dc_norm(if90,i),if90=1,3)\r
3996 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)\r
3997 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)\r
3998 cd          write(iout,'(a)')\r
3999 cd      enddo\r
4000       do i=1,nres\r
4001         do j=1,2\r
4002           do k=1,3\r
4003             do l=1,3\r
4004               uygradt(l,k,j,i)=uygrad(l,k,j,i)\r
4005               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)\r
4006             enddo\r
4007           enddo\r
4008         enddo\r
4009       enddo\r
4010       call vec_and_deriv\r
4011       do i=1,nres\r
4012         do j=1,3\r
4013           uyt(j,i)=uy(j,i)\r
4014           uzt(j,i)=uz(j,i)\r
4015         enddo\r
4016       enddo\r
4017       do i=1,nres\r
4018 cd        write (iout,*) 'i=',i\r
4019         do k=1,3\r
4020           erij(k)=dc_norm(k,i)\r
4021         enddo\r
4022         do j=1,3\r
4023           do k=1,3\r
4024             dc_norm(k,i)=erij(k)\r
4025           enddo\r
4026           dc_norm(j,i)=dc_norm(j,i)+delta\r
4027 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))\r
4028 c          do k=1,3\r
4029 c            dc_norm(k,i)=dc_norm(k,i)/fac\r
4030 c          enddo\r
4031 c          write (iout,*) (dc_norm(k,i),k=1,3)\r
4032 c          write (iout,*) (erij(k),k=1,3)\r
4033           call vec_and_deriv\r
4034           do k=1,3\r
4035             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta\r
4036             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta\r
4037             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta\r
4038             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta\r
4039           enddo \r
4040 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)') \r
4041 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),\r
4042 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)\r
4043         enddo\r
4044         do k=1,3\r
4045           dc_norm(k,i)=erij(k)\r
4046         enddo\r
4047 cd        do k=1,3\r
4048 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)') \r
4049 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),\r
4050 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)\r
4051 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)') \r
4052 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),\r
4053 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)\r
4054 cd          write (iout,'(a)')\r
4055 cd        enddo\r
4056       enddo\r
4057       return\r
4058       end\r
4059 \r
4060 \r
4061 C--------------------------------------------------------------------------\r
4062 \r
4063 \r
4064       subroutine set_matrices\r
4065       implicit real*8 (a-h,o-z)\r
4066       include 'DIMENSIONS'\r
4067 #ifdef MPI\r
4068       include "mpif.h"\r
4069       include "COMMON.SETUP"\r
4070       integer IERR\r
4071       integer status(MPI_STATUS_SIZE)\r
4072 #endif\r
4073       include 'COMMON.IOUNITS'\r
4074       include 'COMMON.GEO'\r
4075       include 'COMMON.VAR'\r
4076       include 'COMMON.LOCAL'\r
4077       include 'COMMON.CHAIN'\r
4078       include 'COMMON.DERIV'\r
4079       include 'COMMON.INTERACT'\r
4080       include 'COMMON.CONTACTS'\r
4081       include 'COMMON.TORSION'\r
4082       include 'COMMON.VECTORS'\r
4083       include 'COMMON.FFIELD'\r
4084       double precision auxvec(2),auxmat(2,2)\r
4085 C\r
4086 C Compute the virtual-bond-torsional-angle dependent quantities needed\r
4087 C to calculate the el-loc multibody terms of various order.\r
4088 C\r
4089 #ifdef PARMAT\r
4090       do i=ivec_start+2,ivec_end+2\r
4091 #else\r
4092       do i=3,nres+1\r
4093 #endif\r
4094         if (i .lt. nres+1) then\r
4095           sin1=dsin(phi(i))\r
4096           cos1=dcos(phi(i))\r
4097           sintab(i-2)=sin1\r
4098           costab(i-2)=cos1\r
4099           obrot(1,i-2)=cos1\r
4100           obrot(2,i-2)=sin1\r
4101           sin2=dsin(2*phi(i))\r
4102           cos2=dcos(2*phi(i))\r
4103           sintab2(i-2)=sin2\r
4104           costab2(i-2)=cos2\r
4105           obrot2(1,i-2)=cos2\r
4106           obrot2(2,i-2)=sin2\r
4107           Ug(1,1,i-2)=-cos1\r
4108           Ug(1,2,i-2)=-sin1\r
4109           Ug(2,1,i-2)=-sin1\r
4110           Ug(2,2,i-2)= cos1\r
4111           Ug2(1,1,i-2)=-cos2\r
4112           Ug2(1,2,i-2)=-sin2\r
4113           Ug2(2,1,i-2)=-sin2\r
4114           Ug2(2,2,i-2)= cos2\r
4115         else\r
4116           costab(i-2)=1.0d0\r
4117           sintab(i-2)=0.0d0\r
4118           obrot(1,i-2)=1.0d0\r
4119           obrot(2,i-2)=0.0d0\r
4120           obrot2(1,i-2)=0.0d0\r
4121           obrot2(2,i-2)=0.0d0\r
4122           Ug(1,1,i-2)=1.0d0\r
4123           Ug(1,2,i-2)=0.0d0\r
4124           Ug(2,1,i-2)=0.0d0\r
4125           Ug(2,2,i-2)=1.0d0\r
4126           Ug2(1,1,i-2)=0.0d0\r
4127           Ug2(1,2,i-2)=0.0d0\r
4128           Ug2(2,1,i-2)=0.0d0\r
4129           Ug2(2,2,i-2)=0.0d0\r
4130         endif\r
4131         if (i .gt. 3 .and. i .lt. nres+1) then\r
4132           obrot_der(1,i-2)=-sin1\r
4133           obrot_der(2,i-2)= cos1\r
4134           Ugder(1,1,i-2)= sin1\r
4135           Ugder(1,2,i-2)=-cos1\r
4136           Ugder(2,1,i-2)=-cos1\r
4137           Ugder(2,2,i-2)=-sin1\r
4138           dwacos2=cos2+cos2\r
4139           dwasin2=sin2+sin2\r
4140           obrot2_der(1,i-2)=-dwasin2\r
4141           obrot2_der(2,i-2)= dwacos2\r
4142           Ug2der(1,1,i-2)= dwasin2\r
4143           Ug2der(1,2,i-2)=-dwacos2\r
4144           Ug2der(2,1,i-2)=-dwacos2\r
4145           Ug2der(2,2,i-2)=-dwasin2\r
4146         else\r
4147           obrot_der(1,i-2)=0.0d0\r
4148           obrot_der(2,i-2)=0.0d0\r
4149           Ugder(1,1,i-2)=0.0d0\r
4150           Ugder(1,2,i-2)=0.0d0\r
4151           Ugder(2,1,i-2)=0.0d0\r
4152           Ugder(2,2,i-2)=0.0d0\r
4153           obrot2_der(1,i-2)=0.0d0\r
4154           obrot2_der(2,i-2)=0.0d0\r
4155           Ug2der(1,1,i-2)=0.0d0\r
4156           Ug2der(1,2,i-2)=0.0d0\r
4157           Ug2der(2,1,i-2)=0.0d0\r
4158           Ug2der(2,2,i-2)=0.0d0\r
4159         endif\r
4160 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then\r
4161         if (i.gt. nnt+2 .and. i.lt.nct+2) then\r
4162           iti = itortyp(itype(i-2))\r
4163         else\r
4164           iti=ntortyp+1\r
4165         endif\r
4166 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then\r
4167         if (i.gt. nnt+1 .and. i.lt.nct+1) then\r
4168           iti1 = itortyp(itype(i-1))\r
4169         else\r
4170           iti1=ntortyp+1\r
4171         endif\r
4172 cd        write (iout,*) '*******i',i,' iti1',iti\r
4173 cd        write (iout,*) 'b1',b1(:,iti)\r
4174 cd        write (iout,*) 'b2',b2(:,iti)\r
4175 cd        write (iout,*) 'Ug',Ug(:,:,i-2)\r
4176 c        if (i .gt. iatel_s+2) then\r
4177         if (i .gt. nnt+2) then\r
4178           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))\r
4179           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))\r
4180           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) \r
4181      &    then\r
4182           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))\r
4183           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))\r
4184           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))\r
4185           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))\r
4186           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))\r
4187           endif\r
4188         else\r
4189           do k=1,2\r
4190             Ub2(k,i-2)=0.0d0\r
4191             Ctobr(k,i-2)=0.0d0 \r
4192             Dtobr2(k,i-2)=0.0d0\r
4193             do l=1,2\r
4194               EUg(l,k,i-2)=0.0d0\r
4195               CUg(l,k,i-2)=0.0d0\r
4196               DUg(l,k,i-2)=0.0d0\r
4197               DtUg2(l,k,i-2)=0.0d0\r
4198             enddo\r
4199           enddo\r
4200         endif\r
4201         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))\r
4202         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))\r
4203         do k=1,2\r
4204           muder(k,i-2)=Ub2der(k,i-2)\r
4205         enddo\r
4206 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then\r
4207         if (i.gt. nnt+1 .and. i.lt.nct+1) then\r
4208           iti1 = itortyp(itype(i-1))\r
4209         else\r
4210           iti1=ntortyp+1\r
4211         endif\r
4212         do k=1,2\r
4213           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)\r
4214         enddo\r
4215 cd        write (iout,*) 'mu ',mu(:,i-2)\r
4216 cd        write (iout,*) 'mu1',mu1(:,i-2)\r
4217 cd        write (iout,*) 'mu2',mu2(:,i-2)\r
4218         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)\r
4219      &  then  \r
4220         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))\r
4221         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))\r
4222         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))\r
4223         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))\r
4224         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))\r
4225 C Vectors and matrices dependent on a single virtual-bond dihedral.\r
4226         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))\r
4227         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2)) \r
4228         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2)) \r
4229         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))\r
4230         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))\r
4231         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))\r
4232         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))\r
4233         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))\r
4234         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))\r
4235         endif\r
4236       enddo\r
4237 C Matrices dependent on two consecutive virtual-bond dihedrals.\r
4238 C The order of matrices is from left to right.\r
4239       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)\r
4240      &then\r
4241 c      do i=max0(ivec_start,2),ivec_end\r
4242       do i=2,nres-1\r
4243         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))\r
4244         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))\r
4245         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))\r
4246         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))\r
4247         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))\r
4248         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))\r
4249         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))\r
4250         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))\r
4251       enddo\r
4252       endif\r
4253 #if defined(MPI) && defined(PARMAT)\r
4254 #ifdef DEBUG\r
4255 c      if (fg_rank.eq.0) then\r
4256         write (iout,*) "Arrays UG and UGDER before GATHER"\r
4257         do i=1,nres-1\r
4258           write (iout,'(i5,4f10.5,5x,4f10.5)') i,\r
4259      &     ((ug(l,k,i),l=1,2),k=1,2),\r
4260      &     ((ugder(l,k,i),l=1,2),k=1,2)\r
4261         enddo\r
4262         write (iout,*) "Arrays UG2 and UG2DER"\r
4263         do i=1,nres-1\r
4264           write (iout,'(i5,4f10.5,5x,4f10.5)') i,\r
4265      &     ((ug2(l,k,i),l=1,2),k=1,2),\r
4266      &     ((ug2der(l,k,i),l=1,2),k=1,2)\r
4267         enddo\r
4268         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"\r
4269         do i=1,nres-1\r
4270           write (iout,'(i5,4f10.5,5x,4f10.5)') i,\r
4271      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),\r
4272      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)\r
4273         enddo\r
4274         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"\r
4275         do i=1,nres-1\r
4276           write (iout,'(i5,4f10.5,5x,4f10.5)') i,\r
4277      &     costab(i),sintab(i),costab2(i),sintab2(i)\r
4278         enddo\r
4279         write (iout,*) "Array MUDER"\r
4280         do i=1,nres-1\r
4281           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)\r
4282         enddo\r
4283 c      endif\r
4284 #endif\r
4285       if (nfgtasks.gt.1) then\r
4286         time00=MPI_Wtime()\r
4287 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,\r
4288 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),\r
4289 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)\r
4290 #ifdef MATGATHER\r
4291         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),\r
4292      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,\r
4293      &   FG_COMM1,IERR)\r
4294         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),\r
4295      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,\r
4296      &   FG_COMM1,IERR)\r
4297         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),\r
4298      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,\r
4299      &   FG_COMM1,IERR)\r
4300         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),\r
4301      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,\r
4302      &   FG_COMM1,IERR)\r
4303         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),\r
4304      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,\r
4305      &   FG_COMM1,IERR)\r
4306         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),\r
4307      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,\r
4308      &   FG_COMM1,IERR)\r
4309         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),\r
4310      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),\r
4311      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)\r
4312         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),\r
4313      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),\r
4314      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)\r
4315         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),\r
4316      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),\r
4317      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)\r
4318         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),\r
4319      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),\r
4320      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)\r
4321         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)\r
4322      &  then\r
4323         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),\r
4324      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,\r
4325      &   FG_COMM1,IERR)\r
4326         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),\r
4327      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,\r
4328      &   FG_COMM1,IERR)\r
4329         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),\r
4330      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,\r
4331      &   FG_COMM1,IERR)\r
4332        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),\r
4333      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,\r
4334      &   FG_COMM1,IERR)\r
4335         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),\r
4336      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,\r
4337      &   FG_COMM1,IERR)\r
4338         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),\r
4339      &   ivec_count(fg_rank1),\r
4340      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,\r
4341      &   FG_COMM1,IERR)\r
4342         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),\r
4343      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,\r
4344      &   FG_COMM1,IERR)\r
4345         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),\r
4346      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,\r
4347      &   FG_COMM1,IERR)\r
4348         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),\r
4349      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,\r
4350      &   FG_COMM1,IERR)\r
4351         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),\r
4352      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,\r
4353      &   FG_COMM1,IERR)\r
4354         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),\r
4355      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,\r
4356      &   FG_COMM1,IERR)\r
4357         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),\r
4358      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,\r
4359      &   FG_COMM1,IERR)\r
4360         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),\r
4361      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,\r
4362      &   FG_COMM1,IERR)\r
4363         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),\r
4364      &   ivec_count(fg_rank1),\r
4365      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,\r
4366      &   FG_COMM1,IERR)\r
4367         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),\r
4368      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,\r
4369      &   FG_COMM1,IERR)\r
4370        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),\r
4371      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,\r
4372      &   FG_COMM1,IERR)\r
4373         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),\r
4374      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,\r
4375      &   FG_COMM1,IERR)\r
4376        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),\r
4377      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,\r
4378      &   FG_COMM1,IERR)\r
4379         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),\r
4380      &   ivec_count(fg_rank1),\r
4381      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,\r
4382      &   FG_COMM1,IERR)\r
4383         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),\r
4384      &   ivec_count(fg_rank1),\r
4385      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,\r
4386      &   FG_COMM1,IERR)\r
4387         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),\r
4388      &   ivec_count(fg_rank1),\r
4389      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),\r
4390      &   MPI_MAT2,FG_COMM1,IERR)\r
4391         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),\r
4392      &   ivec_count(fg_rank1),\r
4393      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),\r
4394      &   MPI_MAT2,FG_COMM1,IERR)\r
4395         endif\r
4396 #else\r
4397 c Passes matrix info through the ring\r
4398       isend=fg_rank1\r
4399       irecv=fg_rank1-1\r
4400       if (irecv.lt.0) irecv=nfgtasks1-1 \r
4401       iprev=irecv\r
4402       inext=fg_rank1+1\r
4403       if (inext.ge.nfgtasks1) inext=0\r
4404       do i=1,nfgtasks1-1\r
4405 c        write (iout,*) "isend",isend," irecv",irecv\r
4406 c        call flush(iout)\r
4407         lensend=lentyp(isend)\r
4408         lenrecv=lentyp(irecv)\r
4409 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv\r
4410 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,\r
4411 c     &   MPI_ROTAT1(lensend),inext,2200+isend,\r
4412 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),\r
4413 c     &   iprev,2200+irecv,FG_COMM,status,IERR)\r
4414 c        write (iout,*) "Gather ROTAT1"\r
4415 c        call flush(iout)\r
4416 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,\r
4417 c     &   MPI_ROTAT2(lensend),inext,3300+isend,\r
4418 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),\r
4419 c     &   iprev,3300+irecv,FG_COMM,status,IERR)\r
4420 c        write (iout,*) "Gather ROTAT2"\r
4421 c        call flush(iout)\r
4422         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,\r
4423      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,\r
4424      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),\r
4425      &   iprev,4400+irecv,FG_COMM,status,IERR)\r
4426 c        write (iout,*) "Gather ROTAT_OLD"\r
4427 c        call flush(iout)\r
4428         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,\r
4429      &   MPI_PRECOMP11(lensend),inext,5500+isend,\r
4430      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),\r
4431      &   iprev,5500+irecv,FG_COMM,status,IERR)\r
4432 c        write (iout,*) "Gather PRECOMP11"\r
4433 c        call flush(iout)\r
4434         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,\r
4435      &   MPI_PRECOMP12(lensend),inext,6600+isend,\r
4436      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),\r
4437      &   iprev,6600+irecv,FG_COMM,status,IERR)\r
4438 c        write (iout,*) "Gather PRECOMP12"\r
4439 c        call flush(iout)\r
4440         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) \r
4441      &  then\r
4442         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,\r
4443      &   MPI_ROTAT2(lensend),inext,7700+isend,\r
4444      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),\r
4445      &   iprev,7700+irecv,FG_COMM,status,IERR)\r
4446 c        write (iout,*) "Gather PRECOMP21"\r
4447 c        call flush(iout)\r
4448         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,\r
4449      &   MPI_PRECOMP22(lensend),inext,8800+isend,\r
4450      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),\r
4451      &   iprev,8800+irecv,FG_COMM,status,IERR)\r
4452 c        write (iout,*) "Gather PRECOMP22"\r
4453 c        call flush(iout)\r
4454         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,\r
4455      &   MPI_PRECOMP23(lensend),inext,9900+isend,\r
4456      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,\r
4457      &   MPI_PRECOMP23(lenrecv),\r
4458      &   iprev,9900+irecv,FG_COMM,status,IERR)\r
4459 c        write (iout,*) "Gather PRECOMP23"\r
4460 c        call flush(iout)\r
4461         endif\r
4462         isend=irecv\r
4463         irecv=irecv-1\r
4464         if (irecv.lt.0) irecv=nfgtasks1-1\r
4465       enddo\r
4466 #endif\r
4467         time_gather=time_gather+MPI_Wtime()-time00\r
4468       endif\r
4469 #ifdef DEBUG\r
4470 c      if (fg_rank.eq.0) then\r
4471         write (iout,*) "Arrays UG and UGDER"\r
4472         do i=1,nres-1\r
4473           write (iout,'(i5,4f10.5,5x,4f10.5)') i,\r
4474      &     ((ug(l,k,i),l=1,2),k=1,2),\r
4475      &     ((ugder(l,k,i),l=1,2),k=1,2)\r
4476         enddo\r
4477         write (iout,*) "Arrays UG2 and UG2DER"\r
4478         do i=1,nres-1\r
4479           write (iout,'(i5,4f10.5,5x,4f10.5)') i,\r
4480      &     ((ug2(l,k,i),l=1,2),k=1,2),\r
4481      &     ((ug2der(l,k,i),l=1,2),k=1,2)\r
4482         enddo\r
4483         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"\r
4484         do i=1,nres-1\r
4485           write (iout,'(i5,4f10.5,5x,4f10.5)') i,\r
4486      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),\r
4487      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)\r
4488         enddo\r
4489         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"\r
4490         do i=1,nres-1\r
4491           write (iout,'(i5,4f10.5,5x,4f10.5)') i,\r
4492      &     costab(i),sintab(i),costab2(i),sintab2(i)\r
4493         enddo\r
4494         write (iout,*) "Array MUDER"\r
4495         do i=1,nres-1\r
4496           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)\r
4497         enddo\r
4498 c      endif\r
4499 #endif\r
4500 #endif\r
4501 cd      do i=1,nres\r
4502 cd        iti = itortyp(itype(i))\r
4503 cd        write (iout,*) i\r
4504 cd        do j=1,2\r
4505 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)') \r
4506 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)\r
4507 cd        enddo\r
4508 cd      enddo\r
4509       return\r
4510       end\r
4511 \r
4512 \r
4513 C--------------------------------------------------------------------------\r
4514 \r
4515 \r
4516       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)\r
4517 C\r
4518 C This subroutine calculates the average interaction energy and its gradient\r
4519 C in the virtual-bond vectors between non-adjacent peptide groups, based on \r
4520 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715. \r
4521 C The potential depends both on the distance of peptide-group centers and on \r
4522 C the orientation of the CA-CA virtual bonds.\r
4523 C \r
4524       implicit real*8 (a-h,o-z)\r
4525 #ifdef MPI\r
4526       include 'mpif.h'\r
4527 #endif\r
4528       include 'DIMENSIONS'\r
4529       include 'COMMON.CONTROL'\r
4530       include 'COMMON.SETUP'\r
4531       include 'COMMON.IOUNITS'\r
4532       include 'COMMON.GEO'\r
4533       include 'COMMON.VAR'\r
4534       include 'COMMON.LOCAL'\r
4535       include 'COMMON.CHAIN'\r
4536       include 'COMMON.DERIV'\r
4537       include 'COMMON.INTERACT'\r
4538       include 'COMMON.CONTACTS'\r
4539       include 'COMMON.TORSION'\r
4540       include 'COMMON.VECTORS'\r
4541       include 'COMMON.FFIELD'\r
4542       include 'COMMON.TIME1'\r
4543       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),\r
4544      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)\r
4545       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),\r
4546      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)\r
4547       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,\r
4548      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,\r
4549      &    num_conti,j1,j2\r
4550 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions\r
4551 #ifdef MOMENT\r
4552       double precision scal_el /1.0d0/\r
4553 #else\r
4554       double precision scal_el /0.5d0/\r
4555 #endif\r
4556 C 12/13/98 \r
4557 C 13-go grudnia roku pamietnego... \r
4558       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,\r
4559      &                   0.0d0,1.0d0,0.0d0,\r
4560      &                   0.0d0,0.0d0,1.0d0/\r
4561 cd      write(iout,*) 'In EELEC'\r
4562 cd      do i=1,nloctyp\r
4563 cd        write(iout,*) 'Type',i\r
4564 cd        write(iout,*) 'B1',B1(:,i)\r
4565 cd        write(iout,*) 'B2',B2(:,i)\r
4566 cd        write(iout,*) 'CC',CC(:,:,i)\r
4567 cd        write(iout,*) 'DD',DD(:,:,i)\r
4568 cd        write(iout,*) 'EE',EE(:,:,i)\r
4569 cd      enddo\r
4570 cd      call check_vecgrad\r
4571 cd      stop\r
4572       if (icheckgrad.eq.1) then\r
4573         do i=1,nres-1\r
4574           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))\r
4575           do k=1,3\r
4576             dc_norm(k,i)=dc(k,i)*fac\r
4577           enddo\r
4578 c          write (iout,*) 'i',i,' fac',fac\r
4579         enddo\r
4580       endif\r
4581       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 \r
4582      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. \r
4583      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then\r
4584 c        call vec_and_deriv\r
4585 #ifdef TIMING\r
4586         time01=MPI_Wtime()\r
4587 #endif\r
4588         call set_matrices\r
4589 #ifdef TIMING\r
4590         time_mat=time_mat+MPI_Wtime()-time01\r
4591 #endif\r
4592       endif\r
4593 cd      do i=1,nres-1\r
4594 cd        write (iout,*) 'i=',i\r
4595 cd        do k=1,3\r
4596 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)\r
4597 cd        enddo\r
4598 cd        do k=1,3\r
4599 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)') \r
4600 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)\r
4601 cd        enddo\r
4602 cd      enddo\r
4603       t_eelecij=0.0d0\r
4604       ees=0.0D0\r
4605       evdw1=0.0D0\r
4606       eel_loc=0.0d0 \r
4607       eello_turn3=0.0d0\r
4608       eello_turn4=0.0d0\r
4609       ind=0\r
4610       do i=1,nres\r
4611         num_cont_hb(i)=0\r
4612       enddo\r
4613 cd      print '(a)','Enter EELEC'\r
4614 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e\r
4615       do i=1,nres\r
4616         gel_loc_loc(i)=0.0d0\r
4617         gcorr_loc(i)=0.0d0\r
4618       enddo\r
4619 c\r
4620 c\r
4621 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms\r
4622 C\r
4623 C Loop over i,i+2 and i,i+3 pairs of the peptide groups\r
4624 C\r
4625       do i=iturn3_start,iturn3_end\r
4626         dxi=dc(1,i)\r
4627         dyi=dc(2,i)\r
4628         dzi=dc(3,i)\r
4629         dx_normi=dc_norm(1,i)\r
4630         dy_normi=dc_norm(2,i)\r
4631         dz_normi=dc_norm(3,i)\r
4632         xmedi=c(1,i)+0.5d0*dxi\r
4633         ymedi=c(2,i)+0.5d0*dyi\r
4634         zmedi=c(3,i)+0.5d0*dzi\r
4635         num_conti=0\r
4636         call eelecij(i,i+2,ees,evdw1,eel_loc)\r
4637         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)\r
4638         num_cont_hb(i)=num_conti\r
4639       enddo\r
4640       do i=iturn4_start,iturn4_end\r
4641         dxi=dc(1,i)\r
4642         dyi=dc(2,i)\r
4643         dzi=dc(3,i)\r
4644         dx_normi=dc_norm(1,i)\r
4645         dy_normi=dc_norm(2,i)\r
4646         dz_normi=dc_norm(3,i)\r
4647         xmedi=c(1,i)+0.5d0*dxi\r
4648         ymedi=c(2,i)+0.5d0*dyi\r
4649         zmedi=c(3,i)+0.5d0*dzi\r
4650         num_conti=num_cont_hb(i)\r
4651         call eelecij(i,i+3,ees,evdw1,eel_loc)\r
4652         if (wturn4.gt.0.0d0) call eturn4(i,eello_turn4)\r
4653         num_cont_hb(i)=num_conti\r
4654       enddo   ! i\r
4655 c\r
4656 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3\r
4657 c\r
4658       do i=iatel_s,iatel_e\r
4659         dxi=dc(1,i)\r
4660         dyi=dc(2,i)\r
4661         dzi=dc(3,i)\r
4662         dx_normi=dc_norm(1,i)\r
4663         dy_normi=dc_norm(2,i)\r
4664         dz_normi=dc_norm(3,i)\r
4665         xmedi=c(1,i)+0.5d0*dxi\r
4666         ymedi=c(2,i)+0.5d0*dyi\r
4667         zmedi=c(3,i)+0.5d0*dzi\r
4668 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)\r
4669         num_conti=num_cont_hb(i)\r
4670         do j=ielstart(i),ielend(i)\r
4671           call eelecij(i,j,ees,evdw1,eel_loc)\r
4672         enddo ! j\r
4673         num_cont_hb(i)=num_conti\r
4674       enddo   ! i\r
4675 c      write (iout,*) "Number of loop steps in EELEC:",ind\r
4676 cd      do i=1,nres\r
4677 cd        write (iout,'(i3,3f10.5,5x,3f10.5)') \r
4678 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)\r
4679 cd      enddo\r
4680 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term\r
4681 ccc      eel_loc=eel_loc+eello_turn3\r
4682 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij\r
4683       return\r
4684       end\r
4685 \r
4686 \r
4687 C-------------------------------------------------------------------------------\r
4688 \r
4689 \r
4690 cDEC$ ATTRIBUTES FORCEINLINE :: eelecij\r
4691       subroutine eelecij(i,j,ees,evdw1,eel_loc)\r
4692       implicit real*8 (a-h,o-z)\r
4693       include 'DIMENSIONS'\r
4694 #ifdef MPI\r
4695       include "mpif.h"\r
4696 #endif\r
4697       include 'COMMON.CONTROL'\r
4698       include 'COMMON.IOUNITS'\r
4699       include 'COMMON.GEO'\r
4700       include 'COMMON.VAR'\r
4701       include 'COMMON.LOCAL'\r
4702       include 'COMMON.CHAIN'\r
4703       include 'COMMON.DERIV'\r
4704       include 'COMMON.INTERACT'\r
4705       include 'COMMON.CONTACTS'\r
4706       include 'COMMON.TORSION'\r
4707       include 'COMMON.VECTORS'\r
4708       include 'COMMON.FFIELD'\r
4709       include 'COMMON.TIME1'\r
4710       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),\r
4711      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)\r
4712       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),\r
4713      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)\r
4714       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,\r
4715      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,\r
4716      &    num_conti,j1,j2\r
4717 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions\r
4718 #ifdef MOMENT\r
4719       double precision scal_el /1.0d0/\r
4720 #else\r
4721       double precision scal_el /0.5d0/\r
4722 #endif\r
4723 C 12/13/98 \r
4724 C 13-go grudnia roku pamietnego... \r
4725       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,\r
4726      &                   0.0d0,1.0d0,0.0d0,\r
4727      &                   0.0d0,0.0d0,1.0d0/\r
4728 c          time00=MPI_Wtime()\r
4729 cd      write (iout,*) "eelecij",i,j\r
4730 c          ind=ind+1\r
4731           iteli=itel(i)\r
4732           itelj=itel(j)\r
4733           if (j.eq.i+2 .and. itelj.eq.2) iteli=2\r
4734           aaa=app(iteli,itelj)\r
4735           bbb=bpp(iteli,itelj)\r
4736           ael6i=ael6(iteli,itelj)\r
4737           ael3i=ael3(iteli,itelj) \r
4738           dxj=dc(1,j)\r
4739           dyj=dc(2,j)\r
4740           dzj=dc(3,j)\r
4741           dx_normj=dc_norm(1,j)\r
4742           dy_normj=dc_norm(2,j)\r
4743           dz_normj=dc_norm(3,j)\r
4744           xj=c(1,j)+0.5D0*dxj-xmedi\r
4745           yj=c(2,j)+0.5D0*dyj-ymedi\r
4746           zj=c(3,j)+0.5D0*dzj-zmedi\r
4747           rij=xj*xj+yj*yj+zj*zj\r
4748           rrmij=1.0D0/rij\r
4749           rij=dsqrt(rij)\r
4750           rmij=1.0D0/rij\r
4751           r3ij=rrmij*rmij\r
4752           r6ij=r3ij*r3ij  \r
4753           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj\r
4754           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij\r
4755           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij\r
4756           fac=cosa-3.0D0*cosb*cosg\r
4757           ev1=aaa*r6ij*r6ij\r
4758 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions\r
4759           if (j.eq.i+2) ev1=scal_el*ev1\r
4760           ev2=bbb*r6ij\r
4761           fac3=ael6i*r6ij\r
4762           fac4=ael3i*r3ij\r
4763           evdwij=ev1+ev2\r
4764           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))\r
4765           el2=fac4*fac       \r
4766           eesij=el1+el2\r
4767 C 12/26/95 - for the evaluation of multi-body H-bonding interactions\r
4768           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)\r
4769           ees=ees+eesij\r
4770           evdw1=evdw1+evdwij\r
4771 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')\r
4772 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,\r
4773 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,\r
4774 cd     &      xmedi,ymedi,zmedi,xj,yj,zj\r
4775 \r
4776           if (energy_dec) then \r
4777               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij\r
4778               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij\r
4779           endif\r
4780 \r
4781 C\r
4782 C Calculate contributions to the Cartesian gradient.\r
4783 C\r
4784 #ifdef SPLITELE\r
4785           facvdw=-6*rrmij*(ev1+evdwij)\r
4786           facel=-3*rrmij*(el1+eesij)\r
4787           fac1=fac\r
4788           erij(1)=xj*rmij\r
4789           erij(2)=yj*rmij\r
4790           erij(3)=zj*rmij\r
4791 *\r
4792 * Radial derivatives. First process both termini of the fragment (i,j)\r
4793 *\r
4794           ggg(1)=facel*xj\r
4795           ggg(2)=facel*yj\r
4796           ggg(3)=facel*zj\r
4797 c          do k=1,3\r
4798 c            ghalf=0.5D0*ggg(k)\r
4799 c            gelc(k,i)=gelc(k,i)+ghalf\r
4800 c            gelc(k,j)=gelc(k,j)+ghalf\r
4801 c          enddo\r
4802 c 9/28/08 AL Gradient compotents will be summed only at the end\r
4803           do k=1,3\r
4804             gelc_long(k,j)=gelc_long(k,j)+ggg(k)\r
4805             gelc_long(k,i)=gelc_long(k,i)-ggg(k)\r
4806           enddo\r
4807 *\r
4808 * Loop over residues i+1 thru j-1.\r
4809 *\r
4810 cgrad          do k=i+1,j-1\r
4811 cgrad            do l=1,3\r
4812 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)\r
4813 cgrad            enddo\r
4814 cgrad          enddo\r
4815           ggg(1)=facvdw*xj\r
4816           ggg(2)=facvdw*yj\r
4817           ggg(3)=facvdw*zj\r
4818 c          do k=1,3\r
4819 c            ghalf=0.5D0*ggg(k)\r
4820 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf\r
4821 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf\r
4822 c          enddo\r
4823 c 9/28/08 AL Gradient compotents will be summed only at the end\r
4824           do k=1,3\r
4825             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)\r
4826             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)\r
4827           enddo\r
4828 *\r
4829 * Loop over residues i+1 thru j-1.\r
4830 *\r
4831 cgrad          do k=i+1,j-1\r
4832 cgrad            do l=1,3\r
4833 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)\r
4834 cgrad            enddo\r
4835 cgrad          enddo\r
4836 #else\r
4837           facvdw=ev1+evdwij \r
4838           facel=el1+eesij  \r
4839           fac1=fac\r
4840           fac=-3*rrmij*(facvdw+facvdw+facel)\r
4841           erij(1)=xj*rmij\r
4842           erij(2)=yj*rmij\r
4843           erij(3)=zj*rmij\r
4844 *\r
4845 * Radial derivatives. First process both termini of the fragment (i,j)\r
4846 * \r
4847           ggg(1)=fac*xj\r
4848           ggg(2)=fac*yj\r
4849           ggg(3)=fac*zj\r
4850 c          do k=1,3\r
4851 c            ghalf=0.5D0*ggg(k)\r
4852 c            gelc(k,i)=gelc(k,i)+ghalf\r
4853 c            gelc(k,j)=gelc(k,j)+ghalf\r
4854 c          enddo\r
4855 c 9/28/08 AL Gradient compotents will be summed only at the end\r
4856           do k=1,3\r
4857             gelc_long(k,j)=gelc(k,j)+ggg(k)\r
4858             gelc_long(k,i)=gelc(k,i)-ggg(k)\r
4859           enddo\r
4860 *\r
4861 * Loop over residues i+1 thru j-1.\r
4862 *\r
4863 cgrad          do k=i+1,j-1\r
4864 cgrad            do l=1,3\r
4865 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)\r
4866 cgrad            enddo\r
4867 cgrad          enddo\r
4868 c 9/28/08 AL Gradient compotents will be summed only at the end\r
4869           ggg(1)=facvdw*xj\r
4870           ggg(2)=facvdw*yj\r
4871           ggg(3)=facvdw*zj\r
4872           do k=1,3\r
4873             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)\r
4874             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)\r
4875           enddo\r
4876 #endif\r
4877 *\r
4878 * Angular part\r
4879 *          \r
4880           ecosa=2.0D0*fac3*fac1+fac4\r
4881           fac4=-3.0D0*fac4\r
4882           fac3=-6.0D0*fac3\r
4883           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)\r
4884           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)\r
4885           do k=1,3\r
4886             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)\r
4887             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)\r
4888           enddo\r
4889 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),\r
4890 cd   &          (dcosg(k),k=1,3)\r
4891           do k=1,3\r
4892             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k) \r
4893           enddo\r
4894 c          do k=1,3\r
4895 c            ghalf=0.5D0*ggg(k)\r
4896 c            gelc(k,i)=gelc(k,i)+ghalf\r
4897 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))\r
4898 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)\r
4899 c            gelc(k,j)=gelc(k,j)+ghalf\r
4900 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))\r
4901 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)\r
4902 c          enddo\r
4903 cgrad          do k=i+1,j-1\r
4904 cgrad            do l=1,3\r
4905 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)\r
4906 cgrad            enddo\r
4907 cgrad          enddo\r
4908           do k=1,3\r
4909             gelc(k,i)=gelc(k,i)\r
4910      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))\r
4911      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)\r
4912             gelc(k,j)=gelc(k,j)\r
4913      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))\r
4914      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)\r
4915             gelc_long(k,j)=gelc_long(k,j)+ggg(k)\r
4916             gelc_long(k,i)=gelc_long(k,i)-ggg(k)\r
4917           enddo\r
4918           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0\r
4919      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 \r
4920      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN\r
4921 C\r
4922 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction \r
4923 C   energy of a peptide unit is assumed in the form of a second-order \r
4924 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.\r
4925 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms\r
4926 C   are computed for EVERY pair of non-contiguous peptide groups.\r
4927 C\r
4928           if (j.lt.nres-1) then\r
4929             j1=j+1\r
4930             j2=j-1\r
4931           else\r
4932             j1=j-1\r
4933             j2=j-2\r
4934           endif\r
4935           kkk=0\r
4936           do k=1,2\r
4937             do l=1,2\r
4938               kkk=kkk+1\r
4939               muij(kkk)=mu(k,i)*mu(l,j)\r
4940             enddo\r
4941           enddo  \r
4942 cd         write (iout,*) 'EELEC: i',i,' j',j\r
4943 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2\r
4944 cd          write(iout,*) 'muij',muij\r
4945           ury=scalar(uy(1,i),erij)\r
4946           urz=scalar(uz(1,i),erij)\r
4947           vry=scalar(uy(1,j),erij)\r
4948           vrz=scalar(uz(1,j),erij)\r
4949           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry\r
4950           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz\r
4951           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry\r
4952           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz\r
4953           fac=dsqrt(-ael6i)*r3ij\r
4954           a22=a22*fac\r
4955           a23=a23*fac\r
4956           a32=a32*fac\r
4957           a33=a33*fac\r
4958 cd          write (iout,'(4i5,4f10.5)')\r
4959 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33\r
4960 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij\r
4961 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),\r
4962 cd     &      uy(:,j),uz(:,j)\r
4963 cd          write (iout,'(4f10.5)') \r
4964 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),\r
4965 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))\r
4966 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz\r
4967 cd           write (iout,'(9f10.5/)') \r
4968 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij\r
4969 C Derivatives of the elements of A in virtual-bond vectors\r
4970           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))\r
4971           do k=1,3\r
4972             uryg(k,1)=scalar(erder(1,k),uy(1,i))\r
4973             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))\r
4974             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))\r
4975             urzg(k,1)=scalar(erder(1,k),uz(1,i))\r
4976             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))\r
4977             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))\r
4978             vryg(k,1)=scalar(erder(1,k),uy(1,j))\r
4979             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))\r
4980             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))\r
4981             vrzg(k,1)=scalar(erder(1,k),uz(1,j))\r
4982             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))\r
4983             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))\r
4984           enddo\r
4985 C Compute radial contributions to the gradient\r
4986           facr=-3.0d0*rrmij\r
4987           a22der=a22*facr\r
4988           a23der=a23*facr\r
4989           a32der=a32*facr\r
4990           a33der=a33*facr\r
4991           agg(1,1)=a22der*xj\r
4992           agg(2,1)=a22der*yj\r
4993           agg(3,1)=a22der*zj\r
4994           agg(1,2)=a23der*xj\r
4995           agg(2,2)=a23der*yj\r
4996           agg(3,2)=a23der*zj\r
4997           agg(1,3)=a32der*xj\r
4998           agg(2,3)=a32der*yj\r
4999           agg(3,3)=a32der*zj\r
5000           agg(1,4)=a33der*xj\r
5001           agg(2,4)=a33der*yj\r
5002           agg(3,4)=a33der*zj\r
5003 C Add the contributions coming from er\r
5004           fac3=-3.0d0*fac\r
5005           do k=1,3\r
5006             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)\r
5007             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)\r
5008             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)\r
5009             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)\r
5010           enddo\r
5011           do k=1,3\r
5012 C Derivatives in DC(i) \r
5013 cgrad            ghalf1=0.5d0*agg(k,1)\r
5014 cgrad            ghalf2=0.5d0*agg(k,2)\r
5015 cgrad            ghalf3=0.5d0*agg(k,3)\r
5016 cgrad            ghalf4=0.5d0*agg(k,4)\r
5017             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))\r
5018      &      -3.0d0*uryg(k,2)*vry)!+ghalf1\r
5019             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))\r
5020      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2\r
5021             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))\r
5022      &      -3.0d0*urzg(k,2)*vry)!+ghalf3\r
5023             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))\r
5024      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4\r
5025 C Derivatives in DC(i+1)\r
5026             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))\r
5027      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)\r
5028             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))\r
5029      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)\r
5030             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))\r
5031      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)\r
5032             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))\r
5033      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)\r
5034 C Derivatives in DC(j)\r
5035             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))\r
5036      &      -3.0d0*vryg(k,2)*ury)!+ghalf1\r
5037             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))\r
5038      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2\r
5039             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))\r
5040      &      -3.0d0*vryg(k,2)*urz)!+ghalf3\r
5041             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) \r
5042      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4\r
5043 C Derivatives in DC(j+1) or DC(nres-1)\r
5044             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))\r
5045      &      -3.0d0*vryg(k,3)*ury)\r
5046             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))\r
5047      &      -3.0d0*vrzg(k,3)*ury)\r
5048             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))\r
5049      &      -3.0d0*vryg(k,3)*urz)\r
5050             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) \r
5051      &      -3.0d0*vrzg(k,3)*urz)\r
5052 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then\r
5053 cgrad              do l=1,4\r
5054 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)\r
5055 cgrad              enddo\r
5056 cgrad            endif\r
5057           enddo\r
5058           acipa(1,1)=a22\r
5059           acipa(1,2)=a23\r
5060           acipa(2,1)=a32\r
5061           acipa(2,2)=a33\r
5062           a22=-a22\r
5063           a23=-a23\r
5064           do l=1,2\r
5065             do k=1,3\r
5066               agg(k,l)=-agg(k,l)\r
5067               aggi(k,l)=-aggi(k,l)\r
5068               aggi1(k,l)=-aggi1(k,l)\r
5069               aggj(k,l)=-aggj(k,l)\r
5070               aggj1(k,l)=-aggj1(k,l)\r
5071             enddo\r
5072           enddo\r
5073           if (j.lt.nres-1) then\r
5074             a22=-a22\r
5075             a32=-a32\r
5076             do l=1,3,2\r
5077               do k=1,3\r
5078                 agg(k,l)=-agg(k,l)\r
5079                 aggi(k,l)=-aggi(k,l)\r
5080                 aggi1(k,l)=-aggi1(k,l)\r
5081                 aggj(k,l)=-aggj(k,l)\r
5082                 aggj1(k,l)=-aggj1(k,l)\r
5083               enddo\r
5084             enddo\r
5085           else\r
5086             a22=-a22\r
5087             a23=-a23\r
5088             a32=-a32\r
5089             a33=-a33\r
5090             do l=1,4\r
5091               do k=1,3\r
5092                 agg(k,l)=-agg(k,l)\r
5093                 aggi(k,l)=-aggi(k,l)\r
5094                 aggi1(k,l)=-aggi1(k,l)\r
5095                 aggj(k,l)=-aggj(k,l)\r
5096                 aggj1(k,l)=-aggj1(k,l)\r
5097               enddo\r
5098             enddo \r
5099           endif    \r
5100           ENDIF ! WCORR\r
5101           IF (wel_loc.gt.0.0d0) THEN\r
5102 C Contribution to the local-electrostatic energy coming from the i-j pair\r
5103           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)\r
5104      &     +a33*muij(4)\r
5105 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij\r
5106 \r
5107           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')\r
5108      &            'eelloc',i,j,eel_loc_ij\r
5109 \r
5110           eel_loc=eel_loc+eel_loc_ij\r
5111 C Partial derivatives in virtual-bond dihedral angles gamma\r
5112           if (i.gt.1)\r
5113      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+ \r
5114      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)\r
5115      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)\r
5116           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ \r
5117      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)\r
5118      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)\r
5119 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)\r
5120           do l=1,3\r
5121             ggg(l)=agg(l,1)*muij(1)+\r
5122      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)\r
5123             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)\r
5124             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)\r
5125 cgrad            ghalf=0.5d0*ggg(l)\r
5126 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf\r
5127 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf\r
5128           enddo\r
5129 cgrad          do k=i+1,j2\r
5130 cgrad            do l=1,3\r
5131 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)\r
5132 cgrad            enddo\r
5133 cgrad          enddo\r
5134 C Remaining derivatives of eello\r
5135           do l=1,3\r
5136             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+\r
5137      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)\r
5138             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+\r
5139      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)\r
5140             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+\r
5141      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)\r
5142             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+\r
5143      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)\r
5144           enddo\r
5145           ENDIF\r
5146 C Change 12/26/95 to calculate four-body contributions to H-bonding energy\r
5147 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then\r
5148           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0\r
5149      &       .and. num_conti.le.maxconts) then\r
5150 c            write (iout,*) i,j," entered corr"\r
5151 C\r
5152 C Calculate the contact function. The ith column of the array JCONT will \r
5153 C contain the numbers of atoms that make contacts with the atom I (of numbers\r
5154 C greater than I). The arrays FACONT and GACONT will contain the values of\r
5155 C the contact function and its derivative.\r
5156 c           r0ij=1.02D0*rpp(iteli,itelj)\r
5157 c           r0ij=1.11D0*rpp(iteli,itelj)\r
5158             r0ij=2.20D0*rpp(iteli,itelj)\r
5159 c           r0ij=1.55D0*rpp(iteli,itelj)\r
5160             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)\r
5161             if (fcont.gt.0.0D0) then\r
5162               num_conti=num_conti+1\r
5163               if (num_conti.gt.maxconts) then\r
5164                 write (iout,*) 'WARNING - max. # of contacts exceeded;',\r
5165      &                         ' will skip next contacts for this conf.'\r
5166               else\r
5167                 jcont_hb(num_conti,i)=j\r
5168 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,\r
5169 cd     &           " jcont_hb",jcont_hb(num_conti,i)\r
5170                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. \r
5171      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN\r
5172 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el\r
5173 C  terms.\r
5174                 d_cont(num_conti,i)=rij\r
5175 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij\r
5176 C     --- Electrostatic-interaction matrix --- \r
5177                 a_chuj(1,1,num_conti,i)=a22\r
5178                 a_chuj(1,2,num_conti,i)=a23\r
5179                 a_chuj(2,1,num_conti,i)=a32\r
5180                 a_chuj(2,2,num_conti,i)=a33\r
5181 C     --- Gradient of rij\r
5182                 do kkk=1,3\r
5183                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)\r
5184                 enddo\r
5185                 kkll=0\r
5186                 do k=1,2\r
5187                   do l=1,2\r
5188                     kkll=kkll+1\r
5189                     do m=1,3\r
5190                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)\r
5191                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)\r
5192                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)\r
5193                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)\r
5194                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)\r
5195                     enddo\r
5196                   enddo\r
5197                 enddo\r
5198                 ENDIF\r
5199                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN\r
5200 C Calculate contact energies\r
5201                 cosa4=4.0D0*cosa\r
5202                 wij=cosa-3.0D0*cosb*cosg\r
5203                 cosbg1=cosb+cosg\r
5204                 cosbg2=cosb-cosg\r
5205 c               fac3=dsqrt(-ael6i)/r0ij**3     \r
5206                 fac3=dsqrt(-ael6i)*r3ij\r
5207 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)\r
5208                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1\r
5209                 if (ees0tmp.gt.0) then\r
5210                   ees0pij=dsqrt(ees0tmp)\r
5211                 else\r
5212                   ees0pij=0\r
5213                 endif\r
5214 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)\r
5215                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2\r
5216                 if (ees0tmp.gt.0) then\r
5217                   ees0mij=dsqrt(ees0tmp)\r
5218                 else\r
5219                   ees0mij=0\r
5220                 endif\r
5221 c               ees0mij=0.0D0\r
5222                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)\r
5223                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)\r
5224 C Diagnostics. Comment out or remove after debugging!\r
5225 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij\r
5226 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij\r
5227 c               ees0m(num_conti,i)=0.0D0\r
5228 C End diagnostics.\r
5229 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,\r
5230 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont\r
5231 C Angular derivatives of the contact function\r
5232                 ees0pij1=fac3/ees0pij \r
5233                 ees0mij1=fac3/ees0mij\r
5234                 fac3p=-3.0D0*fac3*rrmij\r
5235                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)\r
5236                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)\r
5237 c               ees0mij1=0.0D0\r
5238                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)\r
5239                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)\r
5240                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)\r
5241                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)\r
5242                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2) \r
5243                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)\r
5244                 ecosap=ecosa1+ecosa2\r
5245                 ecosbp=ecosb1+ecosb2\r
5246                 ecosgp=ecosg1+ecosg2\r
5247                 ecosam=ecosa1-ecosa2\r
5248                 ecosbm=ecosb1-ecosb2\r
5249                 ecosgm=ecosg1-ecosg2\r
5250 C Diagnostics\r
5251 c               ecosap=ecosa1\r
5252 c               ecosbp=ecosb1\r
5253 c               ecosgp=ecosg1\r
5254 c               ecosam=0.0D0\r
5255 c               ecosbm=0.0D0\r
5256 c               ecosgm=0.0D0\r
5257 C End diagnostics\r
5258                 facont_hb(num_conti,i)=fcont\r
5259                 fprimcont=fprimcont/rij\r
5260 cd              facont_hb(num_conti,i)=1.0D0\r
5261 C Following line is for diagnostics.\r
5262 cd              fprimcont=0.0D0\r
5263                 do k=1,3\r
5264                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)\r
5265                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)\r
5266                 enddo\r
5267                 do k=1,3\r
5268                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)\r
5269                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)\r
5270                 enddo\r
5271                 gggp(1)=gggp(1)+ees0pijp*xj\r
5272                 gggp(2)=gggp(2)+ees0pijp*yj\r
5273                 gggp(3)=gggp(3)+ees0pijp*zj\r
5274                 gggm(1)=gggm(1)+ees0mijp*xj\r
5275                 gggm(2)=gggm(2)+ees0mijp*yj\r
5276                 gggm(3)=gggm(3)+ees0mijp*zj\r
5277 C Derivatives due to the contact function\r
5278                 gacont_hbr(1,num_conti,i)=fprimcont*xj\r
5279                 gacont_hbr(2,num_conti,i)=fprimcont*yj\r
5280                 gacont_hbr(3,num_conti,i)=fprimcont*zj\r
5281                 do k=1,3\r
5282 c\r
5283 c 10/24/08 cgrad and ! comments indicate the parts of the code removed \r
5284 c          following the change of gradient-summation algorithm.\r
5285 c\r
5286 cgrad                  ghalfp=0.5D0*gggp(k)\r
5287 cgrad                  ghalfm=0.5D0*gggm(k)\r
5288                   gacontp_hb1(k,num_conti,i)=!ghalfp\r
5289      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))\r
5290      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)\r
5291                   gacontp_hb2(k,num_conti,i)=!ghalfp\r
5292      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))\r
5293      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)\r
5294                   gacontp_hb3(k,num_conti,i)=gggp(k)\r
5295                   gacontm_hb1(k,num_conti,i)=!ghalfm\r
5296      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))\r
5297      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)\r
5298                   gacontm_hb2(k,num_conti,i)=!ghalfm\r
5299      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))\r
5300      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)\r
5301                   gacontm_hb3(k,num_conti,i)=gggm(k)\r
5302                 enddo\r
5303 C Diagnostics. Comment out or remove after debugging!\r
5304 cdiag           do k=1,3\r
5305 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0\r
5306 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0\r
5307 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0\r
5308 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0\r
5309 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0\r
5310 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0\r
5311 cdiag           enddo\r
5312               ENDIF ! wcorr\r
5313               endif  ! num_conti.le.maxconts\r
5314             endif  ! fcont.gt.0\r
5315           endif    ! j.gt.i+1\r
5316           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then\r
5317             do k=1,4\r
5318               do l=1,3\r
5319                 ghalf=0.5d0*agg(l,k)\r
5320                 aggi(l,k)=aggi(l,k)+ghalf\r
5321                 aggi1(l,k)=aggi1(l,k)+agg(l,k)\r
5322                 aggj(l,k)=aggj(l,k)+ghalf\r
5323               enddo\r
5324             enddo\r
5325             if (j.eq.nres-1 .and. i.lt.j-2) then\r
5326               do k=1,4\r
5327                 do l=1,3\r
5328                   aggj1(l,k)=aggj1(l,k)+agg(l,k)\r
5329                 enddo\r
5330               enddo\r
5331             endif\r
5332           endif\r
5333 c          t_eelecij=t_eelecij+MPI_Wtime()-time00\r
5334       return\r
5335       end\r
5336 \r
5337 \r
5338 C--------------------------------------------------------------------\r
5339 \r
5340 \r
5341       subroutine eturn3(i,eello_turn3)\r
5342 C Third- and fourth-order contributions from turns\r
5343       implicit real*8 (a-h,o-z)\r
5344       include 'DIMENSIONS'\r
5345       include 'COMMON.IOUNITS'\r
5346       include 'COMMON.GEO'\r
5347       include 'COMMON.VAR'\r
5348       include 'COMMON.LOCAL'\r
5349       include 'COMMON.CHAIN'\r
5350       include 'COMMON.DERIV'\r
5351       include 'COMMON.INTERACT'\r
5352       include 'COMMON.CONTACTS'\r
5353       include 'COMMON.TORSION'\r
5354       include 'COMMON.VECTORS'\r
5355       include 'COMMON.FFIELD'\r
5356       include 'COMMON.CONTROL'\r
5357       dimension ggg(3)\r
5358       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),\r
5359      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),\r
5360      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)\r
5361       double precision agg(3,4),aggi(3,4),aggi1(3,4),\r
5362      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)\r
5363       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,\r
5364      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,\r
5365      &    num_conti,j1,j2\r
5366       j=i+2\r
5367 c      write (iout,*) "eturn3",i,j,j1,j2\r
5368       a_temp(1,1)=a22\r
5369       a_temp(1,2)=a23\r
5370       a_temp(2,1)=a32\r
5371       a_temp(2,2)=a33\r
5372 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC\r
5373 C\r
5374 C               Third-order contributions\r
5375 C        \r
5376 C                 (i+2)o----(i+3)\r
5377 C                      | |\r
5378 C                      | |\r
5379 C                 (i+1)o----i\r
5380 C\r
5381 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC   \r
5382 cd        call checkint_turn3(i,a_temp,eello_turn3_num)\r
5383         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))\r
5384         call transpose2(auxmat(1,1),auxmat1(1,1))\r
5385         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))\r
5386         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))\r
5387         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')\r
5388      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))\r
5389 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',\r
5390 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),\r
5391 cd     &    ' eello_turn3_num',4*eello_turn3_num\r
5392 C Derivatives in gamma(i)\r
5393         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))\r
5394         call transpose2(auxmat2(1,1),auxmat3(1,1))\r
5395         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))\r
5396         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))\r
5397 C Derivatives in gamma(i+1)\r
5398         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))\r
5399         call transpose2(auxmat2(1,1),auxmat3(1,1))\r
5400         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))\r
5401         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)\r
5402      &    +0.5d0*(pizda(1,1)+pizda(2,2))\r
5403 C Cartesian derivatives\r
5404         do l=1,3\r
5405 c            ghalf1=0.5d0*agg(l,1)\r
5406 c            ghalf2=0.5d0*agg(l,2)\r
5407 c            ghalf3=0.5d0*agg(l,3)\r
5408 c            ghalf4=0.5d0*agg(l,4)\r
5409           a_temp(1,1)=aggi(l,1)!+ghalf1\r
5410           a_temp(1,2)=aggi(l,2)!+ghalf2\r
5411           a_temp(2,1)=aggi(l,3)!+ghalf3\r
5412           a_temp(2,2)=aggi(l,4)!+ghalf4\r
5413           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))\r
5414           gcorr3_turn(l,i)=gcorr3_turn(l,i)\r
5415      &      +0.5d0*(pizda(1,1)+pizda(2,2))\r
5416           a_temp(1,1)=aggi1(l,1)!+agg(l,1)\r
5417           a_temp(1,2)=aggi1(l,2)!+agg(l,2)\r
5418           a_temp(2,1)=aggi1(l,3)!+agg(l,3)\r
5419           a_temp(2,2)=aggi1(l,4)!+agg(l,4)\r
5420           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))\r
5421           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)\r
5422      &      +0.5d0*(pizda(1,1)+pizda(2,2))\r
5423           a_temp(1,1)=aggj(l,1)!+ghalf1\r
5424           a_temp(1,2)=aggj(l,2)!+ghalf2\r
5425           a_temp(2,1)=aggj(l,3)!+ghalf3\r
5426           a_temp(2,2)=aggj(l,4)!+ghalf4\r
5427           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))\r
5428           gcorr3_turn(l,j)=gcorr3_turn(l,j)\r
5429      &      +0.5d0*(pizda(1,1)+pizda(2,2))\r
5430           a_temp(1,1)=aggj1(l,1)\r
5431           a_temp(1,2)=aggj1(l,2)\r
5432           a_temp(2,1)=aggj1(l,3)\r
5433           a_temp(2,2)=aggj1(l,4)\r
5434           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))\r
5435           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)\r
5436      &      +0.5d0*(pizda(1,1)+pizda(2,2))\r
5437         enddo\r
5438       return\r
5439       end\r
5440 \r
5441 \r
5442 C-------------------------------------------------------------------------------\r
5443 \r
5444 \r
5445       subroutine eturn4(i,eello_turn4)\r
5446 C Third- and fourth-order contributions from turns\r
5447       implicit real*8 (a-h,o-z)\r
5448       include 'DIMENSIONS'\r
5449       include 'COMMON.IOUNITS'\r
5450       include 'COMMON.GEO'\r
5451       include 'COMMON.VAR'\r
5452       include 'COMMON.LOCAL'\r
5453       include 'COMMON.CHAIN'\r
5454       include 'COMMON.DERIV'\r
5455       include 'COMMON.INTERACT'\r
5456       include 'COMMON.CONTACTS'\r
5457       include 'COMMON.TORSION'\r
5458       include 'COMMON.VECTORS'\r
5459       include 'COMMON.FFIELD'\r
5460       include 'COMMON.CONTROL'\r
5461       dimension ggg(3)\r
5462       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),\r
5463      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),\r
5464      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)\r
5465       double precision agg(3,4),aggi(3,4),aggi1(3,4),\r
5466      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)\r
5467       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,\r
5468      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,\r
5469      &    num_conti,j1,j2\r
5470       j=i+3\r
5471 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC\r
5472 C\r
5473 C               Fourth-order contributions\r
5474 C        \r
5475 C                 (i+3)o----(i+4)\r
5476 C                     /  |\r
5477 C               (i+2)o   |\r
5478 C                     \  |\r
5479 C                 (i+1)o----i\r
5480 C\r
5481 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC   \r
5482 cd        call checkint_turn4(i,a_temp,eello_turn4_num)\r
5483 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2\r
5484         a_temp(1,1)=a22\r
5485         a_temp(1,2)=a23\r
5486         a_temp(2,1)=a32\r
5487         a_temp(2,2)=a33\r
5488         iti1=itortyp(itype(i+1))\r
5489         iti2=itortyp(itype(i+2))\r
5490         iti3=itortyp(itype(i+3))\r
5491 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3\r
5492         call transpose2(EUg(1,1,i+1),e1t(1,1))\r
5493         call transpose2(Eug(1,1,i+2),e2t(1,1))\r
5494         call transpose2(Eug(1,1,i+3),e3t(1,1))\r
5495         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))\r
5496         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))\r
5497         s1=scalar2(b1(1,iti2),auxvec(1))\r
5498         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))\r
5499         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1)) \r
5500         s2=scalar2(b1(1,iti1),auxvec(1))\r
5501         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))\r
5502         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))\r
5503         s3=0.5d0*(pizda(1,1)+pizda(2,2))\r
5504         eello_turn4=eello_turn4-(s1+s2+s3)\r
5505         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')\r
5506      &      'eturn4',i,j,-(s1+s2+s3)\r
5507 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),\r
5508 cd     &    ' eello_turn4_num',8*eello_turn4_num\r
5509 C Derivatives in gamma(i)\r
5510         call transpose2(EUgder(1,1,i+1),e1tder(1,1))\r
5511         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))\r
5512         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))\r
5513         s1=scalar2(b1(1,iti2),auxvec(1))\r
5514         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))\r
5515         s3=0.5d0*(pizda(1,1)+pizda(2,2))\r
5516         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)\r
5517 C Derivatives in gamma(i+1)\r
5518         call transpose2(EUgder(1,1,i+2),e2tder(1,1))\r
5519         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1)) \r
5520         s2=scalar2(b1(1,iti1),auxvec(1))\r
5521         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))\r
5522         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))\r
5523         s3=0.5d0*(pizda(1,1)+pizda(2,2))\r
5524         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)\r
5525 C Derivatives in gamma(i+2)\r
5526         call transpose2(EUgder(1,1,i+3),e3tder(1,1))\r
5527         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))\r
5528         s1=scalar2(b1(1,iti2),auxvec(1))\r
5529         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))\r
5530         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1)) \r
5531         s2=scalar2(b1(1,iti1),auxvec(1))\r
5532         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))\r
5533         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))\r
5534         s3=0.5d0*(pizda(1,1)+pizda(2,2))\r
5535         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)\r
5536 C Cartesian derivatives\r
5537 C Derivatives of this turn contributions in DC(i+2)\r
5538         if (j.lt.nres-1) then\r
5539           do l=1,3\r
5540             a_temp(1,1)=agg(l,1)\r
5541             a_temp(1,2)=agg(l,2)\r
5542             a_temp(2,1)=agg(l,3)\r
5543             a_temp(2,2)=agg(l,4)\r
5544             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))\r
5545             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))\r
5546             s1=scalar2(b1(1,iti2),auxvec(1))\r
5547             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))\r
5548             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1)) \r
5549             s2=scalar2(b1(1,iti1),auxvec(1))\r
5550             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))\r
5551             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))\r
5552             s3=0.5d0*(pizda(1,1)+pizda(2,2))\r
5553             ggg(l)=-(s1+s2+s3)\r
5554             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)\r
5555           enddo\r
5556         endif\r
5557 C Remaining derivatives of this turn contribution\r
5558         do l=1,3\r
5559           a_temp(1,1)=aggi(l,1)\r
5560           a_temp(1,2)=aggi(l,2)\r
5561           a_temp(2,1)=aggi(l,3)\r
5562           a_temp(2,2)=aggi(l,4)\r
5563           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))\r
5564           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))\r
5565           s1=scalar2(b1(1,iti2),auxvec(1))\r
5566           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))\r
5567           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1)) \r
5568           s2=scalar2(b1(1,iti1),auxvec(1))\r
5569           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))\r
5570           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))\r
5571           s3=0.5d0*(pizda(1,1)+pizda(2,2))\r
5572           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)\r
5573           a_temp(1,1)=aggi1(l,1)\r
5574           a_temp(1,2)=aggi1(l,2)\r
5575           a_temp(2,1)=aggi1(l,3)\r
5576           a_temp(2,2)=aggi1(l,4)\r
5577           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))\r
5578           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))\r
5579           s1=scalar2(b1(1,iti2),auxvec(1))\r
5580           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))\r
5581           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1)) \r
5582           s2=scalar2(b1(1,iti1),auxvec(1))\r
5583           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))\r
5584           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))\r
5585           s3=0.5d0*(pizda(1,1)+pizda(2,2))\r
5586           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)\r
5587           a_temp(1,1)=aggj(l,1)\r
5588           a_temp(1,2)=aggj(l,2)\r
5589           a_temp(2,1)=aggj(l,3)\r
5590           a_temp(2,2)=aggj(l,4)\r
5591           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))\r
5592           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))\r
5593           s1=scalar2(b1(1,iti2),auxvec(1))\r
5594           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))\r
5595           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1)) \r
5596           s2=scalar2(b1(1,iti1),auxvec(1))\r
5597           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))\r
5598           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))\r
5599           s3=0.5d0*(pizda(1,1)+pizda(2,2))\r
5600           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)\r
5601           a_temp(1,1)=aggj1(l,1)\r
5602           a_temp(1,2)=aggj1(l,2)\r
5603           a_temp(2,1)=aggj1(l,3)\r
5604           a_temp(2,2)=aggj1(l,4)\r
5605           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))\r
5606           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))\r
5607           s1=scalar2(b1(1,iti2),auxvec(1))\r
5608           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))\r
5609           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1)) \r
5610           s2=scalar2(b1(1,iti1),auxvec(1))\r
5611           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))\r
5612           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))\r
5613           s3=0.5d0*(pizda(1,1)+pizda(2,2))\r
5614 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3\r
5615           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)\r
5616         enddo\r
5617       return\r
5618       end\r
5619 \r
5620 \r
5621 C-----------------------------------------------------------------------------\r
5622 \r
5623 \r
5624       subroutine vecpr(u,v,w)\r
5625       implicit real*8(a-h,o-z)\r
5626       dimension u(3),v(3),w(3)\r
5627       w(1)=u(2)*v(3)-u(3)*v(2)\r
5628       w(2)=-u(1)*v(3)+u(3)*v(1)\r
5629       w(3)=u(1)*v(2)-u(2)*v(1)\r
5630       return\r
5631       end\r
5632 \r
5633 \r
5634 C--------------------------------------------------------------------\r
5635 \r
5636 \r
5637       subroutine unormderiv(u,ugrad,unorm,ungrad)\r
5638 C This subroutine computes the derivatives of a normalized vector u, given\r
5639 C the derivatives computed without normalization conditions, ugrad. Returns\r
5640 C ungrad.\r
5641       implicit none\r
5642       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)\r
5643       double precision vec(3)\r
5644       double precision scalar\r
5645       integer i,j\r
5646 c      write (2,*) 'ugrad',ugrad\r
5647 c      write (2,*) 'u',u\r
5648       do i=1,3\r
5649         vec(i)=scalar(ugrad(1,i),u(1))\r
5650       enddo\r
5651 c      write (2,*) 'vec',vec\r
5652       do i=1,3\r
5653         do j=1,3\r
5654           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm\r
5655         enddo\r
5656       enddo\r
5657 c      write (2,*) 'ungrad',ungrad\r
5658       return\r
5659       end\r
5660 \r
5661 \r
5662 C--------------------------------------------------------------------\r
5663 \r
5664 \r
5665       subroutine escp_soft_sphere(evdw2,evdw2_14)\r
5666 C\r
5667 C This subroutine calculates the excluded-volume interaction energy between\r
5668 C peptide-group centers and side chains and its gradient in virtual-bond and\r
5669 C side-chain vectors.\r
5670 C\r
5671       implicit real*8 (a-h,o-z)\r
5672       include 'DIMENSIONS'\r
5673       include 'COMMON.GEO'\r
5674       include 'COMMON.VAR'\r
5675       include 'COMMON.LOCAL'\r
5676       include 'COMMON.CHAIN'\r
5677       include 'COMMON.DERIV'\r
5678       include 'COMMON.INTERACT'\r
5679       include 'COMMON.FFIELD'\r
5680       include 'COMMON.IOUNITS'\r
5681       include 'COMMON.CONTROL'\r
5682       dimension ggg(3)\r
5683       evdw2=0.0D0\r
5684       evdw2_14=0.0d0\r
5685       r0_scp=4.5d0\r
5686 cd    print '(a)','Enter ESCP'\r
5687 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e\r
5688       do i=iatscp_s,iatscp_e\r
5689         iteli=itel(i)\r
5690         xi=0.5D0*(c(1,i)+c(1,i+1))\r
5691         yi=0.5D0*(c(2,i)+c(2,i+1))\r
5692         zi=0.5D0*(c(3,i)+c(3,i+1))\r
5693 \r
5694         do iint=1,nscp_gr(i)\r
5695 \r
5696         do j=iscpstart(i,iint),iscpend(i,iint)\r
5697           itypj=itype(j)\r
5698 C Uncomment following three lines for SC-p interactions\r
5699 c         xj=c(1,nres+j)-xi\r
5700 c         yj=c(2,nres+j)-yi\r
5701 c         zj=c(3,nres+j)-zi\r
5702 C Uncomment following three lines for Ca-p interactions\r
5703           xj=c(1,j)-xi\r
5704           yj=c(2,j)-yi\r
5705           zj=c(3,j)-zi\r
5706           rij=xj*xj+yj*yj+zj*zj\r
5707           r0ij=r0_scp\r
5708           r0ijsq=r0ij*r0ij\r
5709           if (rij.lt.r0ijsq) then\r
5710             evdwij=0.25d0*(rij-r0ijsq)**2\r
5711             fac=rij-r0ijsq\r
5712           else\r
5713             evdwij=0.0d0\r
5714             fac=0.0d0\r
5715           endif \r
5716           evdw2=evdw2+evdwij\r
5717 C\r
5718 C Calculate contributions to the gradient in the virtual-bond and SC vectors.\r
5719 C\r
5720           ggg(1)=xj*fac\r
5721           ggg(2)=yj*fac\r
5722           ggg(3)=zj*fac\r
5723 cgrad          if (j.lt.i) then\r
5724 cd          write (iout,*) 'j<i'\r
5725 C Uncomment following three lines for SC-p interactions\r
5726 c           do k=1,3\r
5727 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)\r
5728 c           enddo\r
5729 cgrad          else\r
5730 cd          write (iout,*) 'j>i'\r
5731 cgrad            do k=1,3\r
5732 cgrad              ggg(k)=-ggg(k)\r
5733 C Uncomment following line for SC-p interactions\r
5734 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)\r
5735 cgrad            enddo\r
5736 cgrad          endif\r
5737 cgrad          do k=1,3\r
5738 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)\r
5739 cgrad          enddo\r
5740 cgrad          kstart=min0(i+1,j)\r
5741 cgrad          kend=max0(i-1,j-1)\r
5742 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend\r
5743 cd        write (iout,*) ggg(1),ggg(2),ggg(3)\r
5744 cgrad          do k=kstart,kend\r
5745 cgrad            do l=1,3\r
5746 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)\r
5747 cgrad            enddo\r
5748 cgrad          enddo\r
5749           do k=1,3\r
5750             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)\r
5751             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)\r
5752           enddo\r
5753         enddo\r
5754 \r
5755         enddo ! iint\r
5756       enddo ! i\r
5757       return\r
5758       end\r
5759 \r
5760 \r
5761 C-----------------------------------------------------------------------------\r
5762 \r
5763 \r
5764       subroutine escp(evdw2,evdw2_14)\r
5765 C\r
5766 C This subroutine calculates the excluded-volume interaction energy between\r
5767 C peptide-group centers and side chains and its gradient in virtual-bond and\r
5768 C side-chain vectors.\r
5769 C\r
5770       implicit real*8 (a-h,o-z)\r
5771       include 'DIMENSIONS'\r
5772       include 'COMMON.GEO'\r
5773       include 'COMMON.VAR'\r
5774       include 'COMMON.LOCAL'\r
5775       include 'COMMON.CHAIN'\r
5776       include 'COMMON.DERIV'\r
5777       include 'COMMON.INTERACT'\r
5778       include 'COMMON.FFIELD'\r
5779       include 'COMMON.IOUNITS'\r
5780       include 'COMMON.CONTROL'\r
5781       dimension ggg(3)\r
5782       evdw2=0.0D0\r
5783       evdw2_14=0.0d0\r
5784 cd    print '(a)','Enter ESCP'\r
5785 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e\r
5786       do i=iatscp_s,iatscp_e\r
5787         iteli=itel(i)\r
5788         xi=0.5D0*(c(1,i)+c(1,i+1))\r
5789         yi=0.5D0*(c(2,i)+c(2,i+1))\r
5790         zi=0.5D0*(c(3,i)+c(3,i+1))\r
5791 \r
5792         do iint=1,nscp_gr(i)\r
5793 \r
5794         do j=iscpstart(i,iint),iscpend(i,iint)\r
5795           itypj=itype(j)\r
5796 C Uncomment following three lines for SC-p interactions\r
5797 c         xj=c(1,nres+j)-xi\r
5798 c         yj=c(2,nres+j)-yi\r
5799 c         zj=c(3,nres+j)-zi\r
5800 C Uncomment following three lines for Ca-p interactions\r
5801           xj=c(1,j)-xi\r
5802           yj=c(2,j)-yi\r
5803           zj=c(3,j)-zi\r
5804           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)\r
5805           fac=rrij**expon2\r
5806           e1=fac*fac*aad(itypj,iteli)\r
5807           e2=fac*bad(itypj,iteli)\r
5808           if (iabs(j-i) .le. 2) then\r
5809             e1=scal14*e1\r
5810             e2=scal14*e2\r
5811             evdw2_14=evdw2_14+e1+e2\r
5812           endif\r
5813           evdwij=e1+e2\r
5814           evdw2=evdw2+evdwij\r
5815           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')\r
5816      &        'evdw2',i,j,evdwij\r
5817 C\r
5818 C Calculate contributions to the gradient in the virtual-bond and SC vectors.\r
5819 C\r
5820           fac=-(evdwij+e1)*rrij\r
5821           ggg(1)=xj*fac\r
5822           ggg(2)=yj*fac\r
5823           ggg(3)=zj*fac\r
5824 cgrad          if (j.lt.i) then\r
5825 cd          write (iout,*) 'j<i'\r
5826 C Uncomment following three lines for SC-p interactions\r
5827 c           do k=1,3\r
5828 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)\r
5829 c           enddo\r
5830 cgrad          else\r
5831 cd          write (iout,*) 'j>i'\r
5832 cgrad            do k=1,3\r
5833 cgrad              ggg(k)=-ggg(k)\r
5834 C Uncomment following line for SC-p interactions\r
5835 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)\r
5836 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)\r
5837 cgrad            enddo\r
5838 cgrad          endif\r
5839 cgrad          do k=1,3\r
5840 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)\r
5841 cgrad          enddo\r
5842 cgrad          kstart=min0(i+1,j)\r
5843 cgrad          kend=max0(i-1,j-1)\r
5844 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend\r
5845 cd        write (iout,*) ggg(1),ggg(2),ggg(3)\r
5846 cgrad          do k=kstart,kend\r
5847 cgrad            do l=1,3\r
5848 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)\r
5849 cgrad            enddo\r
5850 cgrad          enddo\r
5851           do k=1,3\r
5852             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)\r
5853             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)\r
5854           enddo\r
5855         enddo\r
5856 \r
5857         enddo ! iint\r
5858       enddo ! i\r
5859       do i=1,nct\r
5860         do j=1,3\r
5861           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)\r
5862           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)\r
5863           gradx_scp(j,i)=expon*gradx_scp(j,i)\r
5864         enddo\r
5865       enddo\r
5866 C******************************************************************************\r
5867 C\r
5868 C                              N O T E !!!\r
5869 C\r
5870 C To save time the factor EXPON has been extracted from ALL components\r
5871 C of GVDWC and GRADX. Remember to multiply them by this factor before further \r
5872 C use!\r
5873 C\r
5874 C******************************************************************************\r
5875       return\r
5876       end\r
5877 \r
5878 \r
5879 C--------------------------------------------------------------------\r
5880 \r
5881 \r
5882       subroutine edis(ehpb)\r
5883 C \r
5884 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.\r
5885 C\r
5886       implicit real*8 (a-h,o-z)\r
5887       include 'DIMENSIONS'\r
5888       include 'COMMON.SBRIDGE'\r
5889       include 'COMMON.CHAIN'\r
5890       include 'COMMON.DERIV'\r
5891       include 'COMMON.VAR'\r
5892       include 'COMMON.INTERACT'\r
5893       include 'COMMON.IOUNITS'\r
5894       dimension ggg(3)\r
5895       ehpb=0.0D0\r
5896 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr\r
5897 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end\r
5898       if (link_end.eq.0) return\r
5899       do i=link_start,link_end\r
5900 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a\r
5901 C CA-CA distance used in regularization of structure.\r
5902         ii=ihpb(i)\r
5903         jj=jhpb(i)\r
5904 C iii and jjj point to the residues for which the distance is assigned.\r
5905         if (ii.gt.nres) then\r
5906           iii=ii-nres\r
5907           jjj=jj-nres \r
5908         else\r
5909           iii=ii\r
5910           jjj=jj\r
5911         endif\r
5912 cd        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj\r
5913 C 24/11/03 AL: SS bridges handled separately because of introducing a specific\r
5914 C    distance and angle dependent SS bond potential.\r
5915         if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then\r
5916           call ssbond_ene(iii,jjj,eij)\r
5917           ehpb=ehpb+2*eij\r
5918 cd          write (iout,*) "eij",eij\r
5919         else\r
5920 C Calculate the distance between the two points and its difference from the\r
5921 C target distance.\r
5922         dd=dist(ii,jj)\r
5923         rdis=dd-dhpb(i)\r
5924 C Get the force constant corresponding to this distance.\r
5925         waga=forcon(i)\r
5926 C Calculate the contribution to energy.\r
5927         ehpb=ehpb+waga*rdis*rdis\r
5928 C\r
5929 C Evaluate gradient.\r
5930 C\r
5931         fac=waga*rdis/dd\r
5932 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,\r
5933 cd   &   ' waga=',waga,' fac=',fac\r
5934         do j=1,3\r
5935           ggg(j)=fac*(c(j,jj)-c(j,ii))\r
5936         enddo\r
5937 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)\r
5938 C If this is a SC-SC distance, we need to calculate the contributions to the\r
5939 C Cartesian gradient in the SC vectors (ghpbx).\r
5940         if (iii.lt.ii) then\r
5941           do j=1,3\r
5942             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)\r
5943             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)\r
5944           enddo\r
5945         endif\r
5946 cgrad        do j=iii,jjj-1\r
5947 cgrad          do k=1,3\r
5948 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)\r
5949 cgrad          enddo\r
5950 cgrad        enddo\r
5951         do k=1,3\r
5952           ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)\r
5953           ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)\r
5954         enddo\r
5955         endif\r
5956       enddo\r
5957       ehpb=0.5D0*ehpb\r
5958       return\r
5959       end\r
5960 \r
5961 \r
5962 C--------------------------------------------------------------------\r
5963 \r
5964 \r
5965       subroutine ssbond_ene(i,j,eij)\r
5966 C \r
5967 C Calculate the distance and angle dependent SS-bond potential energy\r
5968 C using a free-energy function derived based on RHF/6-31G** ab initio\r
5969 C calculations of diethyl disulfide.\r
5970 C\r
5971 C A. Liwo and U. Kozlowska, 11/24/03\r
5972 C\r
5973       implicit real*8 (a-h,o-z)\r
5974       include 'DIMENSIONS'\r
5975       include 'COMMON.SBRIDGE'\r
5976       include 'COMMON.CHAIN'\r
5977       include 'COMMON.DERIV'\r
5978       include 'COMMON.LOCAL'\r
5979       include 'COMMON.INTERACT'\r
5980       include 'COMMON.VAR'\r
5981       include 'COMMON.IOUNITS'\r
5982       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)\r
5983       itypi=itype(i)\r
5984       xi=c(1,nres+i)\r
5985       yi=c(2,nres+i)\r
5986       zi=c(3,nres+i)\r
5987       dxi=dc_norm(1,nres+i)\r
5988       dyi=dc_norm(2,nres+i)\r
5989       dzi=dc_norm(3,nres+i)\r
5990 c      dsci_inv=dsc_inv(itypi)\r
5991       dsci_inv=vbld_inv(nres+i)\r
5992       itypj=itype(j)\r
5993 c      dscj_inv=dsc_inv(itypj)\r
5994       dscj_inv=vbld_inv(nres+j)\r
5995       xj=c(1,nres+j)-xi\r
5996       yj=c(2,nres+j)-yi\r
5997       zj=c(3,nres+j)-zi\r
5998       dxj=dc_norm(1,nres+j)\r
5999       dyj=dc_norm(2,nres+j)\r
6000       dzj=dc_norm(3,nres+j)\r
6001       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)\r
6002       rij=dsqrt(rrij)\r
6003       erij(1)=xj*rij\r
6004       erij(2)=yj*rij\r
6005       erij(3)=zj*rij\r
6006       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)\r
6007       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)\r
6008       om12=dxi*dxj+dyi*dyj+dzi*dzj\r
6009       do k=1,3\r
6010         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))\r
6011         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))\r
6012       enddo\r
6013       rij=1.0d0/rij\r
6014       deltad=rij-d0cm\r
6015       deltat1=1.0d0-om1\r
6016       deltat2=1.0d0+om2\r
6017       deltat12=om2-om1+2.0d0\r
6018       cosphi=om12-om1*om2\r
6019       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)\r
6020      &  +akct*deltad*deltat12\r
6021      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi\r
6022 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,\r
6023 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,\r
6024 c     &  " deltat12",deltat12," eij",eij \r
6025       ed=2*akcm*deltad+akct*deltat12\r
6026       pom1=akct*deltad\r
6027       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi\r
6028       eom1=-2*akth*deltat1-pom1-om2*pom2\r
6029       eom2= 2*akth*deltat2+pom1-om1*pom2\r
6030       eom12=pom2\r
6031       do k=1,3\r
6032         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)\r
6033         ghpbx(k,i)=ghpbx(k,i)-ggk\r
6034      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))\r
6035      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv\r
6036         ghpbx(k,j)=ghpbx(k,j)+ggk\r
6037      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))\r
6038      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv\r
6039         ghpbc(k,i)=ghpbc(k,i)-ggk\r
6040         ghpbc(k,j)=ghpbc(k,j)+ggk\r
6041       enddo\r
6042 C\r
6043 C Calculate the components of the gradient in DC and X\r
6044 C\r
6045 cgrad      do k=i,j-1\r
6046 cgrad        do l=1,3\r
6047 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)\r
6048 cgrad        enddo\r
6049 cgrad      enddo\r
6050       return\r
6051       end\r
6052 \r
6053 \r
6054 C--------------------------------------------------------------------\r
6055 \r
6056 \r
6057       subroutine ebond(estr)\r
6058 c\r
6059 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds\r
6060 c\r
6061       implicit real*8 (a-h,o-z)\r
6062       include 'DIMENSIONS'\r
6063       include 'COMMON.LOCAL'\r
6064       include 'COMMON.GEO'\r
6065       include 'COMMON.INTERACT'\r
6066       include 'COMMON.DERIV'\r
6067       include 'COMMON.VAR'\r
6068       include 'COMMON.CHAIN'\r
6069       include 'COMMON.IOUNITS'\r
6070       include 'COMMON.NAMES'\r
6071       include 'COMMON.FFIELD'\r
6072       include 'COMMON.CONTROL'\r
6073       include 'COMMON.SETUP'\r
6074       double precision u(3),ud(3)\r
6075       estr=0.0d0\r
6076       do i=ibondp_start,ibondp_end\r
6077         diff = vbld(i)-vbldp0\r
6078 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff\r
6079         estr=estr+diff*diff\r
6080         do j=1,3\r
6081           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)\r
6082         enddo\r
6083 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)\r
6084       enddo\r
6085       estr=0.5d0*AKP*estr\r
6086 c\r
6087 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included\r
6088 c\r
6089       do i=ibond_start,ibond_end\r
6090         iti=itype(i)\r
6091         if (iti.ne.10) then\r
6092           nbi=nbondterm(iti)\r
6093           if (nbi.eq.1) then\r
6094             diff=vbld(i+nres)-vbldsc0(1,iti)\r
6095 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,\r
6096 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff\r
6097             estr=estr+0.5d0*AKSC(1,iti)*diff*diff\r
6098             do j=1,3\r
6099               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)\r
6100             enddo\r
6101           else\r
6102             do j=1,nbi\r
6103               diff=vbld(i+nres)-vbldsc0(j,iti) \r
6104               ud(j)=aksc(j,iti)*diff\r
6105               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff\r
6106             enddo\r
6107             uprod=u(1)\r
6108             do j=2,nbi\r
6109               uprod=uprod*u(j)\r
6110             enddo\r
6111             usum=0.0d0\r
6112             usumsqder=0.0d0\r
6113             do j=1,nbi\r
6114               uprod1=1.0d0\r
6115               uprod2=1.0d0\r
6116               do k=1,nbi\r
6117                 if (k.ne.j) then\r
6118                   uprod1=uprod1*u(k)\r
6119                   uprod2=uprod2*u(k)*u(k)\r
6120                 endif\r
6121               enddo\r
6122               usum=usum+uprod1\r
6123               usumsqder=usumsqder+ud(j)*uprod2   \r
6124             enddo\r
6125             estr=estr+uprod/usum\r
6126             do j=1,3\r
6127              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)\r
6128             enddo\r
6129           endif\r
6130         endif\r
6131       enddo\r
6132       return\r
6133       end \r
6134 #ifdef CRYST_THETA\r
6135 \r
6136 \r
6137 C--------------------------------------------------------------------\r
6138 \r
6139 \r
6140       subroutine ebend(etheta)\r
6141 C\r
6142 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral\r
6143 C angles gamma and its derivatives in consecutive thetas and gammas.\r
6144 C\r
6145       implicit real*8 (a-h,o-z)\r
6146       include 'DIMENSIONS'\r
6147       include 'COMMON.LOCAL'\r
6148       include 'COMMON.GEO'\r
6149       include 'COMMON.INTERACT'\r
6150       include 'COMMON.DERIV'\r
6151       include 'COMMON.VAR'\r
6152       include 'COMMON.CHAIN'\r
6153       include 'COMMON.IOUNITS'\r
6154       include 'COMMON.NAMES'\r
6155       include 'COMMON.FFIELD'\r
6156       include 'COMMON.CONTROL'\r
6157       common /calcthet/ term1,term2,termm,diffak,ratak,\r
6158      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,\r
6159      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it\r
6160       double precision y(2),z(2)\r
6161       delta=0.02d0*pi\r
6162 c      time11=dexp(-2*time)\r
6163 c      time12=1.0d0\r
6164       etheta=0.0D0\r
6165 c     write (*,'(a,i2)') 'EBEND ICG=',icg\r
6166       do i=ithet_start,ithet_end\r
6167 C Zero the energy function and its derivative at 0 or pi.\r
6168         call splinthet(theta(i),0.5d0*delta,ss,ssd)\r
6169         it=itype(i-1)\r
6170         if (i.gt.3) then\r
6171 #ifdef OSF\r
6172           phii=phi(i)\r
6173           if (phii.ne.phii) phii=150.0\r
6174 #else\r
6175           phii=phi(i)\r
6176 #endif\r
6177           y(1)=dcos(phii)\r
6178           y(2)=dsin(phii)\r
6179         else \r
6180           y(1)=0.0D0\r
6181           y(2)=0.0D0\r
6182         endif\r
6183         if (i.lt.nres) then\r
6184 #ifdef OSF\r
6185           phii1=phi(i+1)\r
6186           if (phii1.ne.phii1) phii1=150.0\r
6187           phii1=pinorm(phii1)\r
6188           z(1)=cos(phii1)\r
6189 #else\r
6190           phii1=phi(i+1)\r
6191           z(1)=dcos(phii1)\r
6192 #endif\r
6193           z(2)=dsin(phii1)\r
6194         else\r
6195           z(1)=0.0D0\r
6196           z(2)=0.0D0\r
6197         endif  \r
6198 C Calculate the "mean" value of theta from the part of the distribution\r
6199 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).\r
6200 C In following comments this theta will be referred to as t_c.\r
6201         thet_pred_mean=0.0d0\r
6202         do k=1,2\r
6203           athetk=athet(k,it)\r
6204           bthetk=bthet(k,it)\r
6205           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)\r
6206         enddo\r
6207         dthett=thet_pred_mean*ssd\r
6208         thet_pred_mean=thet_pred_mean*ss+a0thet(it)\r
6209 C Derivatives of the "mean" values in gamma1 and gamma2.\r
6210         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss\r
6211         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss\r
6212         if (theta(i).gt.pi-delta) then\r
6213           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,\r
6214      &         E_tc0)\r
6215           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)\r
6216           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)\r
6217           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,\r
6218      &        E_theta)\r
6219           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,\r
6220      &        E_tc)\r
6221         else if (theta(i).lt.delta) then\r
6222           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)\r
6223           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)\r
6224           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,\r
6225      &        E_theta)\r
6226           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)\r
6227           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,\r
6228      &        E_tc)\r
6229         else\r
6230           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,\r
6231      &        E_theta,E_tc)\r
6232         endif\r
6233         etheta=etheta+ethetai\r
6234         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')\r
6235      &      'ebend',i,ethetai\r
6236         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1\r
6237         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2\r
6238         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)\r
6239       enddo\r
6240 C Ufff.... We've done all this!!! \r
6241       return\r
6242       end\r
6243 \r
6244 \r
6245 C---------------------------------------------------------------------------\r
6246 \r
6247 \r
6248       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,\r
6249      &     E_tc)\r
6250       implicit real*8 (a-h,o-z)\r
6251       include 'DIMENSIONS'\r
6252       include 'COMMON.LOCAL'\r
6253       include 'COMMON.IOUNITS'\r
6254       common /calcthet/ term1,term2,termm,diffak,ratak,\r
6255      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,\r
6256      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it\r
6257 C Calculate the contributions to both Gaussian lobes.\r
6258 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)\r
6259 C The "polynomial part" of the "standard deviation" of this part of \r
6260 C the distribution.\r
6261         sig=polthet(3,it)\r
6262         do j=2,0,-1\r
6263           sig=sig*thet_pred_mean+polthet(j,it)\r
6264         enddo\r
6265 C Derivative of the "interior part" of the "standard deviation of the" \r
6266 C gamma-dependent Gaussian lobe in t_c.\r
6267         sigtc=3*polthet(3,it)\r
6268         do j=2,1,-1\r
6269           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)\r
6270         enddo\r
6271         sigtc=sig*sigtc\r
6272 C Set the parameters of both Gaussian lobes of the distribution.\r
6273 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)\r
6274         fac=sig*sig+sigc0(it)\r
6275         sigcsq=fac+fac\r
6276         sigc=1.0D0/sigcsq\r
6277 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c\r
6278         sigsqtc=-4.0D0*sigcsq*sigtc\r
6279 c       print *,i,sig,sigtc,sigsqtc\r
6280 C Following variable (sigtc) is d[sigma(t_c)]/dt_c\r
6281         sigtc=-sigtc/(fac*fac)\r
6282 C Following variable is sigma(t_c)**(-2)\r
6283         sigcsq=sigcsq*sigcsq\r
6284         sig0i=sig0(it)\r
6285         sig0inv=1.0D0/sig0i**2\r
6286         delthec=thetai-thet_pred_mean\r
6287         delthe0=thetai-theta0i\r
6288         term1=-0.5D0*sigcsq*delthec*delthec\r
6289         term2=-0.5D0*sig0inv*delthe0*delthe0\r
6290 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and\r
6291 C NaNs in taking the logarithm. We extract the largest exponent which is added\r
6292 C to the energy (this being the log of the distribution) at the end of energy\r
6293 C term evaluation for this virtual-bond angle.\r
6294         if (term1.gt.term2) then\r
6295           termm=term1\r
6296           term2=dexp(term2-termm)\r
6297           term1=1.0d0\r
6298         else\r
6299           termm=term2\r
6300           term1=dexp(term1-termm)\r
6301           term2=1.0d0\r
6302         endif\r
6303 C The ratio between the gamma-independent and gamma-dependent lobes of\r
6304 C the distribution is a Gaussian function of thet_pred_mean too.\r
6305         diffak=gthet(2,it)-thet_pred_mean\r
6306         ratak=diffak/gthet(3,it)**2\r
6307         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)\r
6308 C Let's differentiate it in thet_pred_mean NOW.\r
6309         aktc=ak*ratak\r
6310 C Now put together the distribution terms to make complete distribution.\r
6311         termexp=term1+ak*term2\r
6312         termpre=sigc+ak*sig0i\r
6313 C Contribution of the bending energy from this theta is just the -log of\r
6314 C the sum of the contributions from the two lobes and the pre-exponential\r
6315 C factor. Simple enough, isn't it?\r
6316         ethetai=(-dlog(termexp)-termm+dlog(termpre))\r
6317 C NOW the derivatives!!!\r
6318 C 6/6/97 Take into account the deformation.\r
6319         E_theta=(delthec*sigcsq*term1\r
6320      &       +ak*delthe0*sig0inv*term2)/termexp\r
6321         E_tc=((sigtc+aktc*sig0i)/termpre\r
6322      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+\r
6323      &       aktc*term2)/termexp)\r
6324       return\r
6325       end\r
6326 \r
6327 \r
6328 c--------------------------------------------------------------------\r
6329 \r
6330 \r
6331       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)\r
6332       implicit real*8 (a-h,o-z)\r
6333       include 'DIMENSIONS'\r
6334       include 'COMMON.LOCAL'\r
6335       include 'COMMON.IOUNITS'\r
6336       common /calcthet/ term1,term2,termm,diffak,ratak,\r
6337      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,\r
6338      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it\r
6339       delthec=thetai-thet_pred_mean\r
6340       delthe0=thetai-theta0i\r
6341 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).\r
6342       t3 = thetai-thet_pred_mean\r
6343       t6 = t3**2\r
6344       t9 = term1\r
6345       t12 = t3*sigcsq\r
6346       t14 = t12+t6*sigsqtc\r
6347       t16 = 1.0d0\r
6348       t21 = thetai-theta0i\r
6349       t23 = t21**2\r
6350       t26 = term2\r
6351       t27 = t21*t26\r
6352       t32 = termexp\r
6353       t40 = t32**2\r
6354       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9\r
6355      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40\r
6356      & *(-t12*t9-ak*sig0inv*t27)\r
6357       return\r
6358       end\r
6359 #else\r
6360 \r
6361 \r
6362 C--------------------------------------------------------------------\r
6363 \r
6364 \r
6365       subroutine ebend(etheta)\r
6366 C\r
6367 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral\r
6368 C angles gamma and its derivatives in consecutive thetas and gammas.\r
6369 C ab initio-derived potentials from \r
6370 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203\r
6371 C\r
6372       implicit real*8 (a-h,o-z)\r
6373       include 'DIMENSIONS'\r
6374       include 'COMMON.LOCAL'\r
6375       include 'COMMON.GEO'\r
6376       include 'COMMON.INTERACT'\r
6377       include 'COMMON.DERIV'\r
6378       include 'COMMON.VAR'\r
6379       include 'COMMON.CHAIN'\r
6380       include 'COMMON.IOUNITS'\r
6381       include 'COMMON.NAMES'\r
6382       include 'COMMON.FFIELD'\r
6383       include 'COMMON.CONTROL'\r
6384       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),\r
6385      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),\r
6386      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),\r
6387      & sinph1ph2(maxdouble,maxdouble)\r
6388       logical lprn /.false./, lprn1 /.false./\r
6389       etheta=0.0D0\r
6390       do i=ithet_start,ithet_end\r
6391         dethetai=0.0d0\r
6392         dephii=0.0d0\r
6393         dephii1=0.0d0\r
6394         theti2=0.5d0*theta(i)\r
6395         ityp2=ithetyp(itype(i-1))\r
6396         do k=1,nntheterm\r
6397           coskt(k)=dcos(k*theti2)\r
6398           sinkt(k)=dsin(k*theti2)\r
6399         enddo\r
6400         if (i.gt.3) then\r
6401 #ifdef OSF\r
6402           phii=phi(i)\r
6403           if (phii.ne.phii) phii=150.0\r
6404 #else\r
6405           phii=phi(i)\r
6406 #endif\r
6407           ityp1=ithetyp(itype(i-2))\r
6408           do k=1,nsingle\r
6409             cosph1(k)=dcos(k*phii)\r
6410             sinph1(k)=dsin(k*phii)\r
6411           enddo\r
6412         else\r
6413           phii=0.0d0\r
6414           ityp1=nthetyp+1\r
6415           do k=1,nsingle\r
6416             cosph1(k)=0.0d0\r
6417             sinph1(k)=0.0d0\r
6418           enddo \r
6419         endif\r
6420         if (i.lt.nres) then\r
6421 #ifdef OSF\r
6422           phii1=phi(i+1)\r
6423           if (phii1.ne.phii1) phii1=150.0\r
6424           phii1=pinorm(phii1)\r
6425 #else\r
6426           phii1=phi(i+1)\r
6427 #endif\r
6428           ityp3=ithetyp(itype(i))\r
6429           do k=1,nsingle\r
6430             cosph2(k)=dcos(k*phii1)\r
6431             sinph2(k)=dsin(k*phii1)\r
6432           enddo\r
6433         else\r
6434           phii1=0.0d0\r
6435           ityp3=nthetyp+1\r
6436           do k=1,nsingle\r
6437             cosph2(k)=0.0d0\r
6438             sinph2(k)=0.0d0\r
6439           enddo\r
6440         endif  \r
6441         ethetai=aa0thet(ityp1,ityp2,ityp3)\r
6442         do k=1,ndouble\r
6443           do l=1,k-1\r
6444             ccl=cosph1(l)*cosph2(k-l)\r
6445             ssl=sinph1(l)*sinph2(k-l)\r
6446             scl=sinph1(l)*cosph2(k-l)\r
6447             csl=cosph1(l)*sinph2(k-l)\r
6448             cosph1ph2(l,k)=ccl-ssl\r
6449             cosph1ph2(k,l)=ccl+ssl\r
6450             sinph1ph2(l,k)=scl+csl\r
6451             sinph1ph2(k,l)=scl-csl\r
6452           enddo\r
6453         enddo\r
6454         if (lprn) then\r
6455         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,\r
6456      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1\r
6457         write (iout,*) "coskt and sinkt"\r
6458         do k=1,nntheterm\r
6459           write (iout,*) k,coskt(k),sinkt(k)\r
6460         enddo\r
6461         endif\r
6462         do k=1,ntheterm\r
6463           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)\r
6464           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)\r
6465      &      *coskt(k)\r
6466           if (lprn)\r
6467      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),\r
6468      &     " ethetai",ethetai\r
6469         enddo\r
6470         if (lprn) then\r
6471         write (iout,*) "cosph and sinph"\r
6472         do k=1,nsingle\r
6473           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)\r
6474         enddo\r
6475         write (iout,*) "cosph1ph2 and sinph2ph2"\r
6476         do k=2,ndouble\r
6477           do l=1,k-1\r
6478             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),\r
6479      &         sinph1ph2(l,k),sinph1ph2(k,l) \r
6480           enddo\r
6481         enddo\r
6482         write(iout,*) "ethetai",ethetai\r
6483         endif\r
6484         do m=1,ntheterm2\r
6485           do k=1,nsingle\r
6486             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)\r
6487      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)\r
6488      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)\r
6489      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)\r
6490             ethetai=ethetai+sinkt(m)*aux\r
6491             dethetai=dethetai+0.5d0*m*aux*coskt(m)\r
6492             dephii=dephii+k*sinkt(m)*(\r
6493      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-\r
6494      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))\r
6495             dephii1=dephii1+k*sinkt(m)*(\r
6496      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-\r
6497      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))\r
6498             if (lprn)\r
6499      &      write (iout,*) "m",m," k",k," bbthet",\r
6500      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",\r
6501      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",\r
6502      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",\r
6503      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai\r
6504           enddo\r
6505         enddo\r
6506         if (lprn)\r
6507      &  write(iout,*) "ethetai",ethetai\r
6508         do m=1,ntheterm3\r
6509           do k=2,ndouble\r
6510             do l=1,k-1\r
6511               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+\r
6512      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+\r
6513      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+\r
6514      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)\r
6515               ethetai=ethetai+sinkt(m)*aux\r
6516               dethetai=dethetai+0.5d0*m*coskt(m)*aux\r
6517               dephii=dephii+l*sinkt(m)*(\r
6518      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-\r
6519      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+\r
6520      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+\r
6521      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))\r
6522               dephii1=dephii1+(k-l)*sinkt(m)*(\r
6523      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+\r
6524      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+\r
6525      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-\r
6526      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))\r
6527               if (lprn) then\r
6528               write (iout,*) "m",m," k",k," l",l," ffthet",\r
6529      &            ffthet(l,k,m,ityp1,ityp2,ityp3),\r
6530      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",\r
6531      &            ggthet(l,k,m,ityp1,ityp2,ityp3),\r
6532      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai\r
6533               write (iout,*) cosph1ph2(l,k)*sinkt(m),\r
6534      &            cosph1ph2(k,l)*sinkt(m),\r
6535      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)\r
6536               endif\r
6537             enddo\r
6538           enddo\r
6539         enddo\r
6540 10      continue\r
6541         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') \r
6542      &   i,theta(i)*rad2deg,phii*rad2deg,\r
6543      &   phii1*rad2deg,ethetai\r
6544         etheta=etheta+ethetai\r
6545         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii\r
6546         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1\r
6547         gloc(nphi+i-2,icg)=wang*dethetai\r
6548       enddo\r
6549       return\r
6550       end\r
6551 #endif\r
6552 #ifdef CRYST_SC\r
6553 \r
6554 \r
6555 c--------------------------------------------------------------------\r
6556 \r
6557 \r
6558       subroutine esc(escloc)\r
6559 C Calculate the local energy of a side chain and its derivatives in the\r
6560 C corresponding virtual-bond valence angles THETA and the spherical angles \r
6561 C ALPHA and OMEGA.\r
6562       implicit real*8 (a-h,o-z)\r
6563       include 'DIMENSIONS'\r
6564       include 'COMMON.GEO'\r
6565       include 'COMMON.LOCAL'\r
6566       include 'COMMON.VAR'\r
6567       include 'COMMON.INTERACT'\r
6568       include 'COMMON.DERIV'\r
6569       include 'COMMON.CHAIN'\r
6570       include 'COMMON.IOUNITS'\r
6571       include 'COMMON.NAMES'\r
6572       include 'COMMON.FFIELD'\r
6573       include 'COMMON.CONTROL'\r
6574       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),\r
6575      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)\r
6576       common /sccalc/ time11,time12,time112,theti,it,nlobit\r
6577       delta=0.02d0*pi\r
6578       escloc=0.0D0\r
6579 c     write (iout,'(a)') 'ESC'\r
6580       do i=loc_start,loc_end\r
6581         it=itype(i)\r
6582         if (it.eq.10) goto 1\r
6583         nlobit=nlob(it)\r
6584 c       print *,'i=',i,' it=',it,' nlobit=',nlobit\r
6585 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad\r
6586         theti=theta(i+1)-pipol\r
6587         x(1)=dtan(theti)\r
6588         x(2)=alph(i)\r
6589         x(3)=omeg(i)\r
6590 \r
6591         if (x(2).gt.pi-delta) then\r
6592           xtemp(1)=x(1)\r
6593           xtemp(2)=pi-delta\r
6594           xtemp(3)=x(3)\r
6595           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)\r
6596           xtemp(2)=pi\r
6597           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)\r
6598           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),\r
6599      &        escloci,dersc(2))\r
6600           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),\r
6601      &        ddersc0(1),dersc(1))\r
6602           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),\r
6603      &        ddersc0(3),dersc(3))\r
6604           xtemp(2)=pi-delta\r
6605           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)\r
6606           xtemp(2)=pi\r
6607           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)\r
6608           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,\r
6609      &            dersc0(2),esclocbi,dersc02)\r
6610           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),\r
6611      &            dersc12,dersc01)\r
6612           call splinthet(x(2),0.5d0*delta,ss,ssd)\r
6613           dersc0(1)=dersc01\r
6614           dersc0(2)=dersc02\r
6615           dersc0(3)=0.0d0\r
6616           do k=1,3\r
6617             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)\r
6618           enddo\r
6619           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)\r
6620 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,\r
6621 c    &             esclocbi,ss,ssd\r
6622           escloci=ss*escloci+(1.0d0-ss)*esclocbi\r
6623 c         escloci=esclocbi\r
6624 c         write (iout,*) escloci\r
6625         else if (x(2).lt.delta) then\r
6626           xtemp(1)=x(1)\r
6627           xtemp(2)=delta\r
6628           xtemp(3)=x(3)\r
6629           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)\r
6630           xtemp(2)=0.0d0\r
6631           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)\r
6632           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),\r
6633      &        escloci,dersc(2))\r
6634           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),\r
6635      &        ddersc0(1),dersc(1))\r
6636           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),\r
6637      &        ddersc0(3),dersc(3))\r
6638           xtemp(2)=delta\r
6639           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)\r
6640           xtemp(2)=0.0d0\r
6641           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)\r
6642           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,\r
6643      &            dersc0(2),esclocbi,dersc02)\r
6644           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),\r
6645      &            dersc12,dersc01)\r
6646           dersc0(1)=dersc01\r
6647           dersc0(2)=dersc02\r
6648           dersc0(3)=0.0d0\r
6649           call splinthet(x(2),0.5d0*delta,ss,ssd)\r
6650           do k=1,3\r
6651             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)\r
6652           enddo\r
6653           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)\r
6654 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,\r
6655 c    &             esclocbi,ss,ssd\r
6656           escloci=ss*escloci+(1.0d0-ss)*esclocbi\r
6657 c         write (iout,*) escloci\r
6658         else\r
6659           call enesc(x,escloci,dersc,ddummy,.false.)\r
6660         endif\r
6661 \r
6662         escloc=escloc+escloci\r
6663         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')\r
6664      &     'escloc',i,escloci\r
6665 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc\r
6666 \r
6667         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+\r
6668      &   wscloc*dersc(1)\r
6669         gloc(ialph(i,1),icg)=wscloc*dersc(2)\r
6670         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)\r
6671     1   continue\r
6672       enddo\r
6673       return\r
6674       end\r
6675 \r
6676 \r
6677 C--------------------------------------------------------------------\r
6678 \r
6679 \r
6680       subroutine enesc(x,escloci,dersc,ddersc,mixed)\r
6681       implicit real*8 (a-h,o-z)\r
6682       include 'DIMENSIONS'\r
6683       include 'COMMON.GEO'\r
6684       include 'COMMON.LOCAL'\r
6685       include 'COMMON.IOUNITS'\r
6686       common /sccalc/ time11,time12,time112,theti,it,nlobit\r
6687       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)\r
6688       double precision contr(maxlob,-1:1)\r
6689       logical mixed\r
6690 c       write (iout,*) 'it=',it,' nlobit=',nlobit\r
6691         escloc_i=0.0D0\r
6692         do j=1,3\r
6693           dersc(j)=0.0D0\r
6694           if (mixed) ddersc(j)=0.0d0\r
6695         enddo\r
6696         x3=x(3)\r
6697 \r
6698 C Because of periodicity of the dependence of the SC energy in omega we have\r
6699 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).\r
6700 C To avoid underflows, first compute & store the exponents.\r
6701 \r
6702         do iii=-1,1\r
6703 \r
6704           x(3)=x3+iii*dwapi\r
6705  \r
6706           do j=1,nlobit\r
6707             do k=1,3\r
6708               z(k)=x(k)-censc(k,j,it)\r
6709             enddo\r
6710             do k=1,3\r
6711               Axk=0.0D0\r
6712               do l=1,3\r
6713                 Axk=Axk+gaussc(l,k,j,it)*z(l)\r
6714               enddo\r
6715               Ax(k,j,iii)=Axk\r
6716             enddo \r
6717             expfac=0.0D0 \r
6718             do k=1,3\r
6719               expfac=expfac+Ax(k,j,iii)*z(k)\r
6720             enddo\r
6721             contr(j,iii)=expfac\r
6722           enddo ! j\r
6723 \r
6724         enddo ! iii\r
6725 \r
6726         x(3)=x3\r
6727 C As in the case of ebend, we want to avoid underflows in exponentiation and\r
6728 C subsequent NaNs and INFs in energy calculation.\r
6729 C Find the largest exponent\r
6730         emin=contr(1,-1)\r
6731         do iii=-1,1\r
6732           do j=1,nlobit\r
6733             if (emin.gt.contr(j,iii)) emin=contr(j,iii)\r
6734           enddo \r
6735         enddo\r
6736         emin=0.5D0*emin\r
6737 cd      print *,'it=',it,' emin=',emin\r
6738 \r
6739 C Compute the contribution to SC energy and derivatives\r
6740         do iii=-1,1\r
6741 \r
6742           do j=1,nlobit\r
6743 #ifdef OSF\r
6744             adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin\r
6745             if(adexp.ne.adexp) adexp=1.0\r
6746             expfac=dexp(adexp)\r
6747 #else\r
6748             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)\r
6749 #endif\r
6750 cd          print *,'j=',j,' expfac=',expfac\r
6751             escloc_i=escloc_i+expfac\r
6752             do k=1,3\r
6753               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac\r
6754             enddo\r
6755             if (mixed) then\r
6756               do k=1,3,2\r
6757                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)\r
6758      &            +gaussc(k,2,j,it))*expfac\r
6759               enddo\r
6760             endif\r
6761           enddo\r
6762 \r
6763         enddo ! iii\r
6764 \r
6765         dersc(1)=dersc(1)/cos(theti)**2\r
6766         ddersc(1)=ddersc(1)/cos(theti)**2\r
6767         ddersc(3)=ddersc(3)\r
6768 \r
6769         escloci=-(dlog(escloc_i)-emin)\r
6770         do j=1,3\r
6771           dersc(j)=dersc(j)/escloc_i\r
6772         enddo\r
6773         if (mixed) then\r
6774           do j=1,3,2\r
6775             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))\r
6776           enddo\r
6777         endif\r
6778       return\r
6779       end\r
6780 \r
6781 \r
6782 C--------------------------------------------------------------------\r
6783 \r
6784 \r
6785       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)\r
6786       implicit real*8 (a-h,o-z)\r
6787       include 'DIMENSIONS'\r
6788       include 'COMMON.GEO'\r
6789       include 'COMMON.LOCAL'\r
6790       include 'COMMON.IOUNITS'\r
6791       common /sccalc/ time11,time12,time112,theti,it,nlobit\r
6792       double precision x(3),z(3),Ax(3,maxlob),dersc(3)\r
6793       double precision contr(maxlob)\r
6794       logical mixed\r
6795 \r
6796       escloc_i=0.0D0\r
6797 \r
6798       do j=1,3\r
6799         dersc(j)=0.0D0\r
6800       enddo\r
6801 \r
6802       do j=1,nlobit\r
6803         do k=1,2\r
6804           z(k)=x(k)-censc(k,j,it)\r
6805         enddo\r
6806         z(3)=dwapi\r
6807         do k=1,3\r
6808           Axk=0.0D0\r
6809           do l=1,3\r
6810             Axk=Axk+gaussc(l,k,j,it)*z(l)\r
6811           enddo\r
6812           Ax(k,j)=Axk\r
6813         enddo \r
6814         expfac=0.0D0 \r
6815         do k=1,3\r
6816           expfac=expfac+Ax(k,j)*z(k)\r
6817         enddo\r
6818         contr(j)=expfac\r
6819       enddo ! j\r
6820 \r
6821 C As in the case of ebend, we want to avoid underflows in exponentiation and\r
6822 C subsequent NaNs and INFs in energy calculation.\r
6823 C Find the largest exponent\r
6824       emin=contr(1)\r
6825       do j=1,nlobit\r
6826         if (emin.gt.contr(j)) emin=contr(j)\r
6827       enddo \r
6828       emin=0.5D0*emin\r
6829  \r
6830 C Compute the contribution to SC energy and derivatives\r
6831 \r
6832       dersc12=0.0d0\r
6833       do j=1,nlobit\r
6834         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)\r
6835         escloc_i=escloc_i+expfac\r
6836         do k=1,2\r
6837           dersc(k)=dersc(k)+Ax(k,j)*expfac\r
6838         enddo\r
6839         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)\r
6840      &            +gaussc(1,2,j,it))*expfac\r
6841         dersc(3)=0.0d0\r
6842       enddo\r
6843 \r
6844       dersc(1)=dersc(1)/cos(theti)**2\r
6845       dersc12=dersc12/cos(theti)**2\r
6846       escloci=-(dlog(escloc_i)-emin)\r
6847       do j=1,2\r
6848         dersc(j)=dersc(j)/escloc_i\r
6849       enddo\r
6850       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))\r
6851       return\r
6852       end\r
6853 #else\r
6854 \r
6855 \r
6856 c--------------------------------------------------------------------\r
6857 \r
6858 \r
6859       subroutine esc(escloc)\r
6860 C Calculate the local energy of a side chain and its derivatives in the\r
6861 C corresponding virtual-bond valence angles THETA and the spherical angles \r
6862 C ALPHA and OMEGA derived from AM1 all-atom calculations.\r
6863 C added by Urszula Kozlowska. 07/11/2007\r
6864 C\r
6865       implicit real*8 (a-h,o-z)\r
6866       include 'DIMENSIONS'\r
6867       include 'COMMON.GEO'\r
6868       include 'COMMON.LOCAL'\r
6869       include 'COMMON.VAR'\r
6870       include 'COMMON.SCROT'\r
6871       include 'COMMON.INTERACT'\r
6872       include 'COMMON.DERIV'\r
6873       include 'COMMON.CHAIN'\r
6874       include 'COMMON.IOUNITS'\r
6875       include 'COMMON.NAMES'\r
6876       include 'COMMON.FFIELD'\r
6877       include 'COMMON.CONTROL'\r
6878       include 'COMMON.VECTORS'\r
6879       double precision x_prime(3),y_prime(3),z_prime(3)\r
6880      &    , sumene,dsc_i,dp2_i,x(65),\r
6881      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,\r
6882      &    de_dxx,de_dyy,de_dzz,de_dt\r
6883       double precision s1_t,s1_6_t,s2_t,s2_6_t\r
6884       double precision \r
6885      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),\r
6886      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),\r
6887      & dt_dCi(3),dt_dCi1(3)\r
6888       common /sccalc/ time11,time12,time112,theti,it,nlobit\r
6889       delta=0.02d0*pi\r
6890       escloc=0.0D0\r
6891       do i=loc_start,loc_end\r
6892         costtab(i+1) =dcos(theta(i+1))\r
6893         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))\r
6894         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))\r
6895         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))\r
6896         cosfac2=0.5d0/(1.0d0+costtab(i+1))\r
6897         cosfac=dsqrt(cosfac2)\r
6898         sinfac2=0.5d0/(1.0d0-costtab(i+1))\r
6899         sinfac=dsqrt(sinfac2)\r
6900         it=itype(i)\r
6901         if (it.eq.10) goto 1\r
6902 c\r
6903 C  Compute the axes of tghe local cartesian coordinates system; store in\r
6904 c   x_prime, y_prime and z_prime \r
6905 c\r
6906         do j=1,3\r
6907           x_prime(j) = 0.00\r
6908           y_prime(j) = 0.00\r
6909           z_prime(j) = 0.00\r
6910         enddo\r
6911 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),\r
6912 C     &   dc_norm(3,i+nres)\r
6913         do j = 1,3\r
6914           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac\r
6915           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac\r
6916         enddo\r
6917         do j = 1,3\r
6918           z_prime(j) = -uz(j,i-1)\r
6919         enddo     \r
6920 c       write (2,*) "i",i\r
6921 c       write (2,*) "x_prime",(x_prime(j),j=1,3)\r
6922 c       write (2,*) "y_prime",(y_prime(j),j=1,3)\r
6923 c       write (2,*) "z_prime",(z_prime(j),j=1,3)\r
6924 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),\r
6925 c      & " xy",scalar(x_prime(1),y_prime(1)),\r
6926 c      & " xz",scalar(x_prime(1),z_prime(1)),\r
6927 c      & " yy",scalar(y_prime(1),y_prime(1)),\r
6928 c      & " yz",scalar(y_prime(1),z_prime(1)),\r
6929 c      & " zz",scalar(z_prime(1),z_prime(1))\r
6930 c\r
6931 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),\r
6932 C to local coordinate system. Store in xx, yy, zz.\r
6933 c\r
6934         xx=0.0d0\r
6935         yy=0.0d0\r
6936         zz=0.0d0\r
6937         do j = 1,3\r
6938           xx = xx + x_prime(j)*dc_norm(j,i+nres)\r
6939           yy = yy + y_prime(j)*dc_norm(j,i+nres)\r
6940           zz = zz + z_prime(j)*dc_norm(j,i+nres)\r
6941         enddo\r
6942 \r
6943         xxtab(i)=xx\r
6944         yytab(i)=yy\r
6945         zztab(i)=zz\r
6946 C\r
6947 C Compute the energy of the ith side cbain\r
6948 C\r
6949 c        write (2,*) "xx",xx," yy",yy," zz",zz\r
6950         it=itype(i)\r
6951         do j = 1,65\r
6952           x(j) = sc_parmin(j,it) \r
6953         enddo\r
6954 #ifdef CHECK_COORD\r
6955 Cc diagnostics - remove later\r
6956         xx1 = dcos(alph(2))\r
6957         yy1 = dsin(alph(2))*dcos(omeg(2))\r
6958         zz1 = -dsin(alph(2))*dsin(omeg(2))\r
6959         write(2,'(3f8.1,3f9.3,1x,3f9.3)') \r
6960      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,\r
6961      &    xx1,yy1,zz1\r
6962 C,"  --- ", xx_w,yy_w,zz_w\r
6963 c end diagnostics\r
6964 #endif\r
6965         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2\r
6966      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy\r
6967      &   + x(10)*yy*zz\r
6968         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2\r
6969      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy\r
6970      & + x(20)*yy*zz\r
6971         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2\r
6972      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy\r
6973      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3\r
6974      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx\r
6975      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy\r
6976      &  +x(40)*xx*yy*zz\r
6977         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2\r
6978      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy\r
6979      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3\r
6980      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx\r
6981      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy\r
6982      &  +x(60)*xx*yy*zz\r
6983         dsc_i   = 0.743d0+x(61)\r
6984         dp2_i   = 1.9d0+x(62)\r
6985         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i\r
6986      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))\r
6987         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i\r
6988      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))\r
6989         s1=(1+x(63))/(0.1d0 + dscp1)\r
6990         s1_6=(1+x(64))/(0.1d0 + dscp1**6)\r
6991         s2=(1+x(65))/(0.1d0 + dscp2)\r
6992         s2_6=(1+x(65))/(0.1d0 + dscp2**6)\r
6993         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)\r
6994      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)\r
6995 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,\r
6996 c     &   sumene4,\r
6997 c     &   dscp1,dscp2,sumene\r
6998 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))\r
6999         escloc = escloc + sumene\r
7000 c        write (2,*) "i",i," escloc",sumene,escloc\r
7001 #ifdef DEBUG\r
7002 C\r
7003 C This section to check the numerical derivatives of the energy of ith side\r
7004 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert\r
7005 C #define DEBUG in the code to turn it on.\r
7006 C\r
7007         write (2,*) "sumene               =",sumene\r
7008         aincr=1.0d-7\r
7009         xxsave=xx\r
7010         xx=xx+aincr\r
7011         write (2,*) xx,yy,zz\r
7012         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))\r
7013         de_dxx_num=(sumenep-sumene)/aincr\r
7014         xx=xxsave\r
7015         write (2,*) "xx+ sumene from enesc=",sumenep\r
7016         yysave=yy\r
7017         yy=yy+aincr\r
7018         write (2,*) xx,yy,zz\r
7019         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))\r
7020         de_dyy_num=(sumenep-sumene)/aincr\r
7021         yy=yysave\r
7022         write (2,*) "yy+ sumene from enesc=",sumenep\r
7023         zzsave=zz\r
7024         zz=zz+aincr\r
7025         write (2,*) xx,yy,zz\r
7026         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))\r
7027         de_dzz_num=(sumenep-sumene)/aincr\r
7028         zz=zzsave\r
7029         write (2,*) "zz+ sumene from enesc=",sumenep\r
7030         costsave=cost2tab(i+1)\r
7031         sintsave=sint2tab(i+1)\r
7032         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))\r
7033         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))\r
7034         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))\r
7035         de_dt_num=(sumenep-sumene)/aincr\r
7036         write (2,*) " t+ sumene from enesc=",sumenep\r
7037         cost2tab(i+1)=costsave\r
7038         sint2tab(i+1)=sintsave\r
7039 C End of diagnostics section.\r
7040 #endif\r
7041 C        \r
7042 C Compute the gradient of esc\r
7043 C\r
7044         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2\r
7045         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2\r
7046         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2\r
7047         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2\r
7048         pom_dx=dsc_i*dp2_i*cost2tab(i+1)\r
7049         pom_dy=dsc_i*dp2_i*sint2tab(i+1)\r
7050         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))\r
7051         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))\r
7052         pom1=(sumene3*sint2tab(i+1)+sumene1)\r
7053      &     *(pom_s1/dscp1+pom_s16*dscp1**4)\r
7054         pom2=(sumene4*cost2tab(i+1)+sumene2)\r
7055      &     *(pom_s2/dscp2+pom_s26*dscp2**4)\r
7056         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy\r
7057         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2\r
7058      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)\r
7059      &  +x(40)*yy*zz\r
7060         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy\r
7061         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2\r
7062      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)\r
7063      &  +x(60)*yy*zz\r
7064         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)\r
7065      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)\r
7066      &        +(pom1+pom2)*pom_dx\r
7067 #ifdef DEBUG\r
7068         write(2,*), "de_dxx = ", de_dxx,de_dxx_num\r
7069 #endif\r
7070 C\r
7071         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz\r
7072         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2\r
7073      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)\r
7074      &  +x(40)*xx*zz\r
7075         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz\r
7076         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz\r
7077      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz\r
7078      &  +x(59)*zz**2 +x(60)*xx*zz\r
7079         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)\r
7080      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)\r
7081      &        +(pom1-pom2)*pom_dy\r
7082 #ifdef DEBUG\r
7083         write(2,*), "de_dyy = ", de_dyy,de_dyy_num\r
7084 #endif\r
7085 C\r
7086         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy\r
7087      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx \r
7088      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) \r
7089      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6) \r
7090      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2   \r
7091      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy  \r
7092      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)\r
7093      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)\r
7094 #ifdef DEBUG\r
7095         write(2,*), "de_dzz = ", de_dzz,de_dzz_num\r
7096 #endif\r
7097 C\r
7098         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) \r
7099      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)\r
7100      &  +pom1*pom_dt1+pom2*pom_dt2\r
7101 #ifdef DEBUG\r
7102         write(2,*), "de_dt = ", de_dt,de_dt_num\r
7103 #endif\r
7104 c \r
7105 C\r
7106        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))\r
7107        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))\r
7108        cosfac2xx=cosfac2*xx\r
7109        sinfac2yy=sinfac2*yy\r
7110        do k = 1,3\r
7111          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*\r
7112      &      vbld_inv(i+1)\r
7113          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*\r
7114      &      vbld_inv(i)\r
7115          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)\r
7116          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)\r
7117 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,\r
7118 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)\r
7119 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),\r
7120 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)\r
7121          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx\r
7122          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx\r
7123          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy\r
7124          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy\r
7125          dZZ_Ci1(k)=0.0d0\r
7126          dZZ_Ci(k)=0.0d0\r
7127          do j=1,3\r
7128            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)\r
7129            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)\r
7130          enddo\r
7131           \r
7132          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))\r
7133          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))\r
7134          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))\r
7135 c\r
7136          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)\r
7137          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)\r
7138        enddo\r
7139 \r
7140        do k=1,3\r
7141          dXX_Ctab(k,i)=dXX_Ci(k)\r
7142          dXX_C1tab(k,i)=dXX_Ci1(k)\r
7143          dYY_Ctab(k,i)=dYY_Ci(k)\r
7144          dYY_C1tab(k,i)=dYY_Ci1(k)\r
7145          dZZ_Ctab(k,i)=dZZ_Ci(k)\r
7146          dZZ_C1tab(k,i)=dZZ_Ci1(k)\r
7147          dXX_XYZtab(k,i)=dXX_XYZ(k)\r
7148          dYY_XYZtab(k,i)=dYY_XYZ(k)\r
7149          dZZ_XYZtab(k,i)=dZZ_XYZ(k)\r
7150        enddo\r
7151 \r
7152        do k = 1,3\r
7153 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",\r
7154 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)\r
7155 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",\r
7156 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)\r
7157 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",\r
7158 c     &    dt_dci(k)\r
7159 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",\r
7160 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k) \r
7161          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)\r
7162      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)\r
7163          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)\r
7164      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)\r
7165          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)\r
7166      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)\r
7167        enddo\r
7168 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),\r
7169 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)  \r
7170 \r
7171 C to check gradient call subroutine check_grad\r
7172 \r
7173     1 continue\r
7174       enddo\r
7175       return\r
7176       end\r
7177 \r
7178 \r
7179 c--------------------------------------------------------------------\r
7180 \r
7181 \r
7182       double precision function enesc(x,xx,yy,zz,cost2,sint2)\r
7183       implicit none\r
7184       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,\r
7185      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6\r
7186       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2\r
7187      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy\r
7188      &   + x(10)*yy*zz\r
7189       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2\r
7190      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy\r
7191      & + x(20)*yy*zz\r
7192       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2\r
7193      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy\r
7194      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3\r
7195      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx\r
7196      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy\r
7197      &  +x(40)*xx*yy*zz\r
7198       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2\r
7199      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy\r
7200      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3\r
7201      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx\r
7202      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy\r
7203      &  +x(60)*xx*yy*zz\r
7204       dsc_i   = 0.743d0+x(61)\r
7205       dp2_i   = 1.9d0+x(62)\r
7206       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i\r
7207      &          *(xx*cost2+yy*sint2))\r
7208       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i\r
7209      &          *(xx*cost2-yy*sint2))\r
7210       s1=(1+x(63))/(0.1d0 + dscp1)\r
7211       s1_6=(1+x(64))/(0.1d0 + dscp1**6)\r
7212       s2=(1+x(65))/(0.1d0 + dscp2)\r
7213       s2_6=(1+x(65))/(0.1d0 + dscp2**6)\r
7214       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)\r
7215      & + (sumene4*cost2 +sumene2)*(s2+s2_6)\r
7216       enesc=sumene\r
7217       return\r
7218       end\r
7219 #endif\r
7220 \r
7221 \r
7222 c--------------------------------------------------------------------\r
7223 \r
7224 \r
7225       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)\r
7226 C\r
7227 C This procedure calculates two-body contact function g(rij) and its derivative:\r
7228 C\r
7229 C           eps0ij                                     !       x < -1\r
7230 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1\r
7231 C            0                                         !       x > 1\r
7232 C\r
7233 C where x=(rij-r0ij)/delta\r
7234 C\r
7235 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy\r
7236 C\r
7237       implicit none\r
7238       double precision rij,r0ij,eps0ij,fcont,fprimcont\r
7239       double precision x,x2,x4,delta\r
7240 c     delta=0.02D0*r0ij\r
7241 c      delta=0.2D0*r0ij\r
7242       x=(rij-r0ij)/delta\r
7243       if (x.lt.-1.0D0) then\r
7244         fcont=eps0ij\r
7245         fprimcont=0.0D0\r
7246       else if (x.le.1.0D0) then  \r
7247         x2=x*x\r
7248         x4=x2*x2\r
7249         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)\r
7250         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta\r
7251       else\r
7252         fcont=0.0D0\r
7253         fprimcont=0.0D0\r
7254       endif\r
7255       return\r
7256       end\r
7257 \r
7258 \r
7259 c--------------------------------------------------------------------\r
7260 \r
7261 \r
7262       subroutine splinthet(theti,delta,ss,ssder)\r
7263       implicit real*8 (a-h,o-z)\r
7264       include 'DIMENSIONS'\r
7265       include 'COMMON.VAR'\r
7266       include 'COMMON.GEO'\r
7267       thetup=pi-delta\r
7268       thetlow=delta\r
7269       if (theti.gt.pipol) then\r
7270         call gcont(theti,thetup,1.0d0,delta,ss,ssder)\r
7271       else\r
7272         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)\r
7273         ssder=-ssder\r
7274       endif\r
7275       return\r
7276       end\r
7277 \r
7278 \r
7279 c--------------------------------------------------------------------\r
7280 \r
7281 \r
7282       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)\r
7283       implicit none\r
7284       double precision x,x0,delta,f0,f1,fprim0,f,fprim\r
7285       double precision ksi,ksi2,ksi3,a1,a2,a3\r
7286       a1=fprim0*delta/(f1-f0)\r
7287       a2=3.0d0-2.0d0*a1\r
7288       a3=a1-2.0d0\r
7289       ksi=(x-x0)/delta\r
7290       ksi2=ksi*ksi\r
7291       ksi3=ksi2*ksi  \r
7292       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))\r
7293       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))\r
7294       return\r
7295       end\r
7296 \r
7297 \r
7298 c--------------------------------------------------------------------\r
7299 \r
7300 \r
7301       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)\r
7302       implicit none\r
7303       double precision x,x0,delta,f0x,f1x,fprim0x,fx\r
7304       double precision ksi,ksi2,ksi3,a1,a2,a3\r
7305       ksi=(x-x0)/delta  \r
7306       ksi2=ksi*ksi\r
7307       ksi3=ksi2*ksi\r
7308       a1=fprim0x*delta\r
7309       a2=3*(f1x-f0x)-2*fprim0x*delta\r
7310       a3=fprim0x*delta-2*(f1x-f0x)\r
7311       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3\r
7312       return\r
7313       end\r
7314 \r
7315 \r
7316 C--------------------------------------------------------------------\r
7317 #ifdef CRYST_TOR\r
7318 C--------------------------------------------------------------------\r
7319 \r
7320 \r
7321       subroutine etor(etors,edihcnstr)\r
7322       implicit real*8 (a-h,o-z)\r
7323       include 'DIMENSIONS'\r
7324       include 'COMMON.VAR'\r
7325       include 'COMMON.GEO'\r
7326       include 'COMMON.LOCAL'\r
7327       include 'COMMON.TORSION'\r
7328       include 'COMMON.INTERACT'\r
7329       include 'COMMON.DERIV'\r
7330       include 'COMMON.CHAIN'\r
7331       include 'COMMON.NAMES'\r
7332       include 'COMMON.IOUNITS'\r
7333       include 'COMMON.FFIELD'\r
7334       include 'COMMON.TORCNSTR'\r
7335       include 'COMMON.CONTROL'\r
7336       logical lprn\r
7337 C Set lprn=.true. for debugging\r
7338       lprn=.false.\r
7339 c      lprn=.true.\r
7340       etors=0.0D0\r
7341       do i=iphi_start,iphi_end\r
7342       etors_ii=0.0D0\r
7343         itori=itortyp(itype(i-2))\r
7344         itori1=itortyp(itype(i-1))\r
7345         phii=phi(i)\r
7346         gloci=0.0D0\r
7347 C Proline-Proline pair is a special case...\r
7348         if (itori.eq.3 .and. itori1.eq.3) then\r
7349           if (phii.gt.-dwapi3) then\r
7350             cosphi=dcos(3*phii)\r
7351             fac=1.0D0/(1.0D0-cosphi)\r
7352             etorsi=v1(1,3,3)*fac\r
7353             etorsi=etorsi+etorsi\r
7354             etors=etors+etorsi-v1(1,3,3)\r
7355             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)      \r
7356             gloci=gloci-3*fac*etorsi*dsin(3*phii)\r
7357           endif\r
7358           do j=1,3\r
7359             v1ij=v1(j+1,itori,itori1)\r
7360             v2ij=v2(j+1,itori,itori1)\r
7361             cosphi=dcos(j*phii)\r
7362             sinphi=dsin(j*phii)\r
7363             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)\r
7364             if (energy_dec) etors_ii=etors_ii+\r
7365      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)\r
7366             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)\r
7367           enddo\r
7368         else \r
7369           do j=1,nterm_old\r
7370             v1ij=v1(j,itori,itori1)\r
7371             v2ij=v2(j,itori,itori1)\r
7372             cosphi=dcos(j*phii)\r
7373             sinphi=dsin(j*phii)\r
7374             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)\r
7375             if (energy_dec) etors_ii=etors_ii+\r
7376      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)\r
7377             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)\r
7378           enddo\r
7379         endif\r
7380         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')\r
7381      &        'etor',i,etors_ii\r
7382         if (lprn)\r
7383      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')\r
7384      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,\r
7385      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)\r
7386         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci\r
7387 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)\r
7388       enddo\r
7389 ! 6/20/98 - dihedral angle constraints\r
7390       edihcnstr=0.0d0\r
7391       do i=1,ndih_constr\r
7392         itori=idih_constr(i)\r
7393         phii=phi(itori)\r
7394         difi=phii-phi0(i)\r
7395         if (difi.gt.drange(i)) then\r
7396           difi=difi-drange(i)\r
7397           edihcnstr=edihcnstr+0.25d0*ftors*difi**4\r
7398           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3\r
7399         else if (difi.lt.-drange(i)) then\r
7400           difi=difi+drange(i)\r
7401           edihcnstr=edihcnstr+0.25d0*ftors*difi**4\r
7402           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3\r
7403         endif\r
7404 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,\r
7405 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)\r
7406       enddo\r
7407 !      write (iout,*) 'edihcnstr',edihcnstr\r
7408       return\r
7409       end\r
7410 \r
7411 \r
7412 c--------------------------------------------------------------------\r
7413 \r
7414 \r
7415       subroutine etor_d(etors_d)\r
7416       etors_d=0.0d0\r
7417       return\r
7418       end\r
7419 \r
7420 \r
7421 c--------------------------------------------------------------------\r
7422 \r
7423 \r
7424 #else\r
7425       subroutine etor(etors,edihcnstr)\r
7426       implicit real*8 (a-h,o-z)\r
7427       include 'DIMENSIONS'\r
7428       include 'COMMON.VAR'\r
7429       include 'COMMON.GEO'\r
7430       include 'COMMON.LOCAL'\r
7431       include 'COMMON.TORSION'\r
7432       include 'COMMON.INTERACT'\r
7433       include 'COMMON.DERIV'\r
7434       include 'COMMON.CHAIN'\r
7435       include 'COMMON.NAMES'\r
7436       include 'COMMON.IOUNITS'\r
7437       include 'COMMON.FFIELD'\r
7438       include 'COMMON.TORCNSTR'\r
7439       include 'COMMON.CONTROL'\r
7440       logical lprn\r
7441 C Set lprn=.true. for debugging\r
7442       lprn=.false.\r
7443 c     lprn=.true.\r
7444       etors=0.0D0\r
7445       do i=iphi_start,iphi_end\r
7446       etors_ii=0.0D0\r
7447         itori=itortyp(itype(i-2))\r
7448         itori1=itortyp(itype(i-1))\r
7449         phii=phi(i)\r
7450         gloci=0.0D0\r
7451 C Regular cosine and sine terms\r
7452         do j=1,nterm(itori,itori1)\r
7453           v1ij=v1(j,itori,itori1)\r
7454           v2ij=v2(j,itori,itori1)\r
7455           cosphi=dcos(j*phii)\r
7456           sinphi=dsin(j*phii)\r
7457           etors=etors+v1ij*cosphi+v2ij*sinphi\r
7458           if (energy_dec) etors_ii=etors_ii+\r
7459      &                v1ij*cosphi+v2ij*sinphi\r
7460           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)\r
7461         enddo\r
7462 C Lorentz terms\r
7463 C                         v1\r
7464 C  E = SUM ----------------------------------- - v1\r
7465 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1\r
7466 C\r
7467         cosphi=dcos(0.5d0*phii)\r
7468         sinphi=dsin(0.5d0*phii)\r
7469         do j=1,nlor(itori,itori1)\r
7470           vl1ij=vlor1(j,itori,itori1)\r
7471           vl2ij=vlor2(j,itori,itori1)\r
7472           vl3ij=vlor3(j,itori,itori1)\r
7473           pom=vl2ij*cosphi+vl3ij*sinphi\r
7474           pom1=1.0d0/(pom*pom+1.0d0)\r
7475           etors=etors+vl1ij*pom1\r
7476           if (energy_dec) etors_ii=etors_ii+\r
7477      &                vl1ij*pom1\r
7478           pom=-pom*pom1*pom1\r
7479           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom\r
7480         enddo\r
7481 C Subtract the constant term\r
7482         etors=etors-v0(itori,itori1)\r
7483           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')\r
7484      &         'etor',i,etors_ii-v0(itori,itori1)\r
7485         if (lprn)\r
7486      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')\r
7487      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,\r
7488      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)\r
7489         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci\r
7490 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)\r
7491       enddo\r
7492 ! 6/20/98 - dihedral angle constraints\r
7493       edihcnstr=0.0d0\r
7494 c      do i=1,ndih_constr\r
7495       do i=idihconstr_start,idihconstr_end\r
7496         itori=idih_constr(i)\r
7497         phii=phi(itori)\r
7498         difi=pinorm(phii-phi0(i))\r
7499         if (difi.gt.drange(i)) then\r
7500           difi=difi-drange(i)\r
7501           edihcnstr=edihcnstr+0.25d0*ftors*difi**4\r
7502           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3\r
7503         else if (difi.lt.-drange(i)) then\r
7504           difi=difi+drange(i)\r
7505           edihcnstr=edihcnstr+0.25d0*ftors*difi**4\r
7506           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3\r
7507         else\r
7508           difi=0.0\r
7509         endif\r
7510 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,\r
7511 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),\r
7512 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)\r
7513       enddo\r
7514 cd       write (iout,*) 'edihcnstr',edihcnstr\r
7515       return\r
7516       end\r
7517 \r
7518 \r
7519 c--------------------------------------------------------------------\r
7520 \r
7521 \r
7522       subroutine etor_d(etors_d)\r
7523 C 6/23/01 Compute double torsional energy\r
7524       implicit real*8 (a-h,o-z)\r
7525       include 'DIMENSIONS'\r
7526       include 'COMMON.VAR'\r
7527       include 'COMMON.GEO'\r
7528       include 'COMMON.LOCAL'\r
7529       include 'COMMON.TORSION'\r
7530       include 'COMMON.INTERACT'\r
7531       include 'COMMON.DERIV'\r
7532       include 'COMMON.CHAIN'\r
7533       include 'COMMON.NAMES'\r
7534       include 'COMMON.IOUNITS'\r
7535       include 'COMMON.FFIELD'\r
7536       include 'COMMON.TORCNSTR'\r
7537       logical lprn\r
7538 C Set lprn=.true. for debugging\r
7539       lprn=.false.\r
7540 c     lprn=.true.\r
7541       etors_d=0.0D0\r
7542       do i=iphid_start,iphid_end\r
7543         itori=itortyp(itype(i-2))\r
7544         itori1=itortyp(itype(i-1))\r
7545         itori2=itortyp(itype(i))\r
7546         phii=phi(i)\r
7547         phii1=phi(i+1)\r
7548         gloci1=0.0D0\r
7549         gloci2=0.0D0\r
7550 C Regular cosine and sine terms\r
7551         do j=1,ntermd_1(itori,itori1,itori2)\r
7552           v1cij=v1c(1,j,itori,itori1,itori2)\r
7553           v1sij=v1s(1,j,itori,itori1,itori2)\r
7554           v2cij=v1c(2,j,itori,itori1,itori2)\r
7555           v2sij=v1s(2,j,itori,itori1,itori2)\r
7556           cosphi1=dcos(j*phii)\r
7557           sinphi1=dsin(j*phii)\r
7558           cosphi2=dcos(j*phii1)\r
7559           sinphi2=dsin(j*phii1)\r
7560           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+\r
7561      &     v2cij*cosphi2+v2sij*sinphi2\r
7562           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)\r
7563           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)\r
7564         enddo\r
7565         do k=2,ntermd_2(itori,itori1,itori2)\r
7566           do l=1,k-1\r
7567             v1cdij = v2c(k,l,itori,itori1,itori2)\r
7568             v2cdij = v2c(l,k,itori,itori1,itori2)\r
7569             v1sdij = v2s(k,l,itori,itori1,itori2)\r
7570             v2sdij = v2s(l,k,itori,itori1,itori2)\r
7571             cosphi1p2=dcos(l*phii+(k-l)*phii1)\r
7572             cosphi1m2=dcos(l*phii-(k-l)*phii1)\r
7573             sinphi1p2=dsin(l*phii+(k-l)*phii1)\r
7574             sinphi1m2=dsin(l*phii-(k-l)*phii1)\r
7575             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+\r
7576      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2\r
7577             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2\r
7578      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)\r
7579             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2\r
7580      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2) \r
7581           enddo\r
7582         enddo\r
7583         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1\r
7584         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2\r
7585       enddo\r
7586       return\r
7587       end\r
7588 #endif\r
7589 \r
7590 \r
7591 c--------------------------------------------------------------------\r
7592 \r
7593 \r
7594       subroutine eback_sc_corr(esccor)\r
7595 c 7/21/2007 Correlations between the backbone-local and side-chain-local\r
7596 c        conformational states; temporarily implemented as differences\r
7597 c        between UNRES torsional potentials (dependent on three types of\r
7598 c        residues) and the torsional potentials dependent on all 20 types\r
7599 c        of residues computed from AM1  energy surfaces of terminally-blocked\r
7600 c        amino-acid residues.\r
7601       implicit real*8 (a-h,o-z)\r
7602       include 'DIMENSIONS'\r
7603       include 'COMMON.VAR'\r
7604       include 'COMMON.GEO'\r
7605       include 'COMMON.LOCAL'\r
7606       include 'COMMON.TORSION'\r
7607       include 'COMMON.SCCOR'\r
7608       include 'COMMON.INTERACT'\r
7609       include 'COMMON.DERIV'\r
7610       include 'COMMON.CHAIN'\r
7611       include 'COMMON.NAMES'\r
7612       include 'COMMON.IOUNITS'\r
7613       include 'COMMON.FFIELD'\r
7614       include 'COMMON.CONTROL'\r
7615       logical lprn\r
7616 C Set lprn=.true. for debugging\r
7617       write (*,*) "eback_sc_corr 01"\r
7618       lprn=.false.\r
7619 c      lprn=.true.\r
7620 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor\r
7621       esccor=0.0D0\r
7622       do i=iphi_start,iphi_end\r
7623       write (*,*) "eback_sc_corr 02"\r
7624         esccor_ii=0.0D0\r
7625         itori=itype(i-2)\r
7626         itori1=itype(i-1)\r
7627         phii=phi(i)\r
7628         gloci=0.0D0\r
7629         do j=1,nterm_sccor\r
7630       write (*,*) "eback_sc_corr 03"\r
7631           v1ij=v1sccor(j,itori,itori1)\r
7632           v2ij=v2sccor(j,itori,itori1)\r
7633           cosphi=dcos(j*phii)\r
7634           sinphi=dsin(j*phii)\r
7635           esccor=esccor+v1ij*cosphi+v2ij*sinphi\r
7636           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)\r
7637         enddo\r
7638         if (lprn)\r
7639      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')\r
7640      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,\r
7641      &  (v1sccor(j,itori,itori1),j=1,6),(v2sccor(j,itori,itori1),j=1,6)\r
7642         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci\r
7643       enddo\r
7644       write (*,*) "eback_sc_corr 04"\r
7645       return\r
7646       end\r
7647 \r
7648 \r
7649 c--------------------------------------------------------------------\r
7650 \r
7651 \r
7652       subroutine multibody(ecorr)\r
7653 C This subroutine calculates multi-body contributions to energy following\r
7654 C the idea of Skolnick et al. If side chains I and J make a contact and\r
7655 C at the same time side chains I+1 and J+1 make a contact, an extra \r
7656 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.\r
7657       implicit real*8 (a-h,o-z)\r
7658       include 'DIMENSIONS'\r
7659       include 'COMMON.IOUNITS'\r
7660       include 'COMMON.DERIV'\r
7661       include 'COMMON.INTERACT'\r
7662       include 'COMMON.CONTACTS'\r
7663       double precision gx(3),gx1(3)\r
7664       logical lprn\r
7665 \r
7666 C Set lprn=.true. for debugging\r
7667       lprn=.false.\r
7668 \r
7669       if (lprn) then\r
7670         write (iout,'(a)') 'Contact function values:'\r
7671         do i=nnt,nct-2\r
7672           write (iout,'(i2,20(1x,i2,f10.5))') \r
7673      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))\r
7674         enddo\r
7675       endif\r
7676       ecorr=0.0D0\r
7677       do i=nnt,nct\r
7678         do j=1,3\r
7679           gradcorr(j,i)=0.0D0\r
7680           gradxorr(j,i)=0.0D0\r
7681         enddo\r
7682       enddo\r
7683       do i=nnt,nct-2\r
7684 \r
7685         DO ISHIFT = 3,4\r
7686 \r
7687         i1=i+ishift\r
7688         num_conti=num_cont(i)\r
7689         num_conti1=num_cont(i1)\r
7690         do jj=1,num_conti\r
7691           j=jcont(jj,i)\r
7692           do kk=1,num_conti1\r
7693             j1=jcont(kk,i1)\r
7694             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then\r
7695 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,\r
7696 cd   &                   ' ishift=',ishift\r
7697 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously. \r
7698 C The system gains extra energy.\r
7699               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)\r
7700             endif   ! j1==j+-ishift\r
7701           enddo     ! kk  \r
7702         enddo       ! jj\r
7703 \r
7704         ENDDO ! ISHIFT\r
7705 \r
7706       enddo         ! i\r
7707       return\r
7708       end\r
7709 \r
7710 \r
7711 c--------------------------------------------------------------------\r
7712 \r
7713 \r
7714       double precision function esccorr(i,j,k,l,jj,kk)\r
7715       implicit real*8 (a-h,o-z)\r
7716       include 'DIMENSIONS'\r
7717       include 'COMMON.IOUNITS'\r
7718       include 'COMMON.DERIV'\r
7719       include 'COMMON.INTERACT'\r
7720       include 'COMMON.CONTACTS'\r
7721       double precision gx(3),gx1(3)\r
7722       logical lprn\r
7723       lprn=.false.\r
7724       eij=facont(jj,i)\r
7725       ekl=facont(kk,k)\r
7726 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl\r
7727 C Calculate the multi-body contribution to energy.\r
7728 C Calculate multi-body contributions to the gradient.\r
7729 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),\r
7730 cd   & k,l,(gacont(m,kk,k),m=1,3)\r
7731       do m=1,3\r
7732         gx(m) =ekl*gacont(m,jj,i)\r
7733         gx1(m)=eij*gacont(m,kk,k)\r
7734         gradxorr(m,i)=gradxorr(m,i)-gx(m)\r
7735         gradxorr(m,j)=gradxorr(m,j)+gx(m)\r
7736         gradxorr(m,k)=gradxorr(m,k)-gx1(m)\r
7737         gradxorr(m,l)=gradxorr(m,l)+gx1(m)\r
7738       enddo\r
7739       do m=i,j-1\r
7740         do ll=1,3\r
7741           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)\r
7742         enddo\r
7743       enddo\r
7744       do m=k,l-1\r
7745         do ll=1,3\r
7746           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)\r
7747         enddo\r
7748       enddo \r
7749       esccorr=-eij*ekl\r
7750       return\r
7751       end\r
7752 \r
7753 \r
7754 c--------------------------------------------------------------------\r
7755 \r
7756 \r
7757       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)\r
7758 C This subroutine calculates multi-body contributions to hydrogen-bonding \r
7759       implicit real*8 (a-h,o-z)\r
7760       include 'DIMENSIONS'\r
7761       include 'COMMON.IOUNITS'\r
7762 #ifdef MPI\r
7763       include "mpif.h"\r
7764       parameter (max_cont=maxconts)\r
7765       parameter (max_dim=26)\r
7766       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error\r
7767       double precision zapas(max_dim,maxconts,max_fg_procs),\r
7768      &  zapas_recv(max_dim,maxconts,max_fg_procs)\r
7769       common /przechowalnia/ zapas\r
7770       integer status(MPI_STATUS_SIZE),req(maxconts*2),\r
7771      &  status_array(MPI_STATUS_SIZE,maxconts*2)\r
7772 #endif\r
7773       include 'COMMON.SETUP'\r
7774       include 'COMMON.FFIELD'\r
7775       include 'COMMON.DERIV'\r
7776       include 'COMMON.INTERACT'\r
7777       include 'COMMON.CONTACTS'\r
7778       include 'COMMON.CONTROL'\r
7779       include 'COMMON.LOCAL'\r
7780       double precision gx(3),gx1(3),time00\r
7781       logical lprn,ldone\r
7782 \r
7783 C Set lprn=.true. for debugging\r
7784       lprn=.false.\r
7785 #ifdef MPI\r
7786       n_corr=0\r
7787       n_corr1=0\r
7788       if (nfgtasks.le.1) goto 30\r
7789       if (lprn) then\r
7790         write (iout,'(a)') 'Contact function values before RECEIVE:'\r
7791         do i=nnt,nct-2\r
7792           write (iout,'(2i3,50(1x,i2,f5.2))') \r
7793      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),\r
7794      &    j=1,num_cont_hb(i))\r
7795         enddo\r
7796       endif\r
7797       call flush(iout)\r
7798       do i=1,ntask_cont_from\r
7799         ncont_recv(i)=0\r
7800       enddo\r
7801       do i=1,ntask_cont_to\r
7802         ncont_sent(i)=0\r
7803       enddo\r
7804 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",\r
7805 c     & ntask_cont_to\r
7806 C Make the list of contacts to send to send to other procesors\r
7807 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end\r
7808 c      call flush(iout)\r
7809       do i=iturn3_start,iturn3_end\r
7810 c        write (iout,*) "make contact list turn3",i," num_cont",\r
7811 c     &    num_cont_hb(i)\r
7812         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))\r
7813       enddo\r
7814       do i=iturn4_start,iturn4_end\r
7815 c        write (iout,*) "make contact list turn4",i," num_cont",\r
7816 c     &   num_cont_hb(i)\r
7817         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))\r
7818       enddo\r
7819       do ii=1,nat_sent\r
7820         i=iat_sent(ii)\r
7821 c        write (iout,*) "make contact list longrange",i,ii," num_cont",\r
7822 c     &    num_cont_hb(i)\r
7823         do j=1,num_cont_hb(i)\r
7824         do k=1,4\r
7825           jjc=jcont_hb(j,i)\r
7826           iproc=iint_sent_local(k,jjc,ii)\r
7827 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc\r
7828           if (iproc.gt.0) then\r
7829             ncont_sent(iproc)=ncont_sent(iproc)+1\r
7830             nn=ncont_sent(iproc)\r
7831             zapas(1,nn,iproc)=i\r
7832             zapas(2,nn,iproc)=jjc\r
7833             zapas(3,nn,iproc)=facont_hb(j,i)\r
7834             zapas(4,nn,iproc)=ees0p(j,i)\r
7835             zapas(5,nn,iproc)=ees0m(j,i)\r
7836             zapas(6,nn,iproc)=gacont_hbr(1,j,i)\r
7837             zapas(7,nn,iproc)=gacont_hbr(2,j,i)\r
7838             zapas(8,nn,iproc)=gacont_hbr(3,j,i)\r
7839             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)\r
7840             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)\r
7841             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)\r
7842             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)\r
7843             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)\r
7844             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)\r
7845             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)\r
7846             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)\r
7847             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)\r
7848             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)\r
7849             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)\r
7850             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)\r
7851             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)\r
7852             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)\r
7853             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)\r
7854             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)\r
7855             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)\r
7856             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)\r
7857           endif\r
7858         enddo\r
7859         enddo\r
7860       enddo\r
7861       if (lprn) then\r
7862       write (iout,*) \r
7863      &  "Numbers of contacts to be sent to other processors",\r
7864      &  (ncont_sent(i),i=1,ntask_cont_to)\r
7865       write (iout,*) "Contacts sent"\r
7866       do ii=1,ntask_cont_to\r
7867         nn=ncont_sent(ii)\r
7868         iproc=itask_cont_to(ii)\r
7869         write (iout,*) nn," contacts to processor",iproc,\r
7870      &   " of CONT_TO_COMM group"\r
7871         do i=1,nn\r
7872           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)\r
7873         enddo\r
7874       enddo\r
7875       call flush(iout)\r
7876       endif\r
7877       CorrelType=477\r
7878       CorrelID=fg_rank+1\r
7879       CorrelType1=478\r
7880       CorrelID1=nfgtasks+fg_rank+1\r
7881       ireq=0\r
7882 C Receive the numbers of needed contacts from other processors \r
7883       do ii=1,ntask_cont_from\r
7884         iproc=itask_cont_from(ii)\r
7885         ireq=ireq+1\r
7886         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,\r
7887      &    FG_COMM,req(ireq),IERR)\r
7888       enddo\r
7889 c      write (iout,*) "IRECV ended"\r
7890 c      call flush(iout)\r
7891 C Send the number of contacts needed by other processors\r
7892       do ii=1,ntask_cont_to\r
7893         iproc=itask_cont_to(ii)\r
7894         ireq=ireq+1\r
7895         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,\r
7896      &    FG_COMM,req(ireq),IERR)\r
7897       enddo\r
7898 c      write (iout,*) "ISEND ended"\r
7899 c      write (iout,*) "number of requests (nn)",ireq\r
7900       call flush(iout)\r
7901       if (ireq.gt.0) \r
7902      &  call MPI_Waitall(ireq,req,status_array,ierr)\r
7903 c      write (iout,*) \r
7904 c     &  "Numbers of contacts to be received from other processors",\r
7905 c     &  (ncont_recv(i),i=1,ntask_cont_from)\r
7906 c      call flush(iout)\r
7907 C Receive contacts\r
7908       ireq=0\r
7909       do ii=1,ntask_cont_from\r
7910         iproc=itask_cont_from(ii)\r
7911         nn=ncont_recv(ii)\r
7912 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,\r
7913 c     &   " of CONT_TO_COMM group"\r
7914         call flush(iout)\r
7915         if (nn.gt.0) then\r
7916           ireq=ireq+1\r
7917           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,\r
7918      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)\r
7919 c          write (iout,*) "ireq,req",ireq,req(ireq)\r
7920         endif\r
7921       enddo\r
7922 C Send the contacts to processors that need them\r
7923       do ii=1,ntask_cont_to\r
7924         iproc=itask_cont_to(ii)\r
7925         nn=ncont_sent(ii)\r
7926 c        write (iout,*) nn," contacts to processor",iproc,\r
7927 c     &   " of CONT_TO_COMM group"\r
7928         if (nn.gt.0) then\r
7929           ireq=ireq+1 \r
7930           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,\r
7931      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)\r
7932 c          write (iout,*) "ireq,req",ireq,req(ireq)\r
7933 c          do i=1,nn\r
7934 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)\r
7935 c          enddo\r
7936         endif  \r
7937       enddo\r
7938 c      write (iout,*) "number of requests (contacts)",ireq\r
7939 c      write (iout,*) "req",(req(i),i=1,4)\r
7940 c      call flush(iout)\r
7941       if (ireq.gt.0) \r
7942      & call MPI_Waitall(ireq,req,status_array,ierr)\r
7943       do iii=1,ntask_cont_from\r
7944         iproc=itask_cont_from(iii)\r
7945         nn=ncont_recv(iii)\r
7946         if (lprn) then\r
7947         write (iout,*) "Received",nn," contacts from processor",iproc,\r
7948      &   " of CONT_FROM_COMM group"\r
7949         call flush(iout)\r
7950         do i=1,nn\r
7951           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)\r
7952         enddo\r
7953         call flush(iout)\r
7954         endif\r
7955         do i=1,nn\r
7956           ii=zapas_recv(1,i,iii)\r
7957 c Flag the received contacts to prevent double-counting\r
7958           jj=-zapas_recv(2,i,iii)\r
7959 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj\r
7960 c          call flush(iout)\r
7961           nnn=num_cont_hb(ii)+1\r
7962           num_cont_hb(ii)=nnn\r
7963           jcont_hb(nnn,ii)=jj\r
7964           facont_hb(nnn,ii)=zapas_recv(3,i,iii)\r
7965           ees0p(nnn,ii)=zapas_recv(4,i,iii)\r
7966           ees0m(nnn,ii)=zapas_recv(5,i,iii)\r
7967           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)\r
7968           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)\r
7969           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)\r
7970           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)\r
7971           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)\r
7972           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)\r
7973           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)\r
7974           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)\r
7975           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)\r
7976           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)\r
7977           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)\r
7978           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)\r
7979           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)\r
7980           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)\r
7981           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)\r
7982           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)\r
7983           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)\r
7984           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)\r
7985           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)\r
7986           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)\r
7987           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)\r
7988         enddo\r
7989       enddo\r
7990       call flush(iout)\r
7991       if (lprn) then\r
7992         write (iout,'(a)') 'Contact function values after receive:'\r
7993         do i=nnt,nct-2\r
7994           write (iout,'(2i3,50(1x,i3,f5.2))') \r
7995      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),\r
7996      &    j=1,num_cont_hb(i))\r
7997         enddo\r
7998         call flush(iout)\r
7999       endif\r
8000    30 continue\r
8001 #endif\r
8002       if (lprn) then\r
8003         write (iout,'(a)') 'Contact function values:'\r
8004         do i=nnt,nct-2\r
8005           write (iout,'(2i3,50(1x,i3,f5.2))') \r
8006      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),\r
8007      &    j=1,num_cont_hb(i))\r
8008         enddo\r
8009       endif\r
8010       ecorr=0.0D0\r
8011 C Remove the loop below after debugging !!!\r
8012       do i=nnt,nct\r
8013         do j=1,3\r
8014           gradcorr(j,i)=0.0D0\r
8015           gradxorr(j,i)=0.0D0\r
8016         enddo\r
8017       enddo\r
8018 C Calculate the local-electrostatic correlation terms\r
8019       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)\r
8020         i1=i+1\r
8021         num_conti=num_cont_hb(i)\r
8022         num_conti1=num_cont_hb(i+1)\r
8023         do jj=1,num_conti\r
8024           j=jcont_hb(jj,i)\r
8025           jp=iabs(j)\r
8026           do kk=1,num_conti1\r
8027             j1=jcont_hb(kk,i1)\r
8028             jp1=iabs(j1)\r
8029 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,\r
8030 c     &         ' jj=',jj,' kk=',kk\r
8031             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 \r
8032      &          .or. j.lt.0 .and. j1.gt.0) .and.\r
8033      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then\r
8034 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously. \r
8035 C The system gains extra energy.\r
8036               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)\r
8037               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')\r
8038      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)\r
8039               n_corr=n_corr+1\r
8040             else if (j1.eq.j) then\r
8041 C Contacts I-J and I-(J+1) occur simultaneously. \r
8042 C The system loses extra energy.\r
8043 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0) \r
8044             endif\r
8045           enddo ! kk\r
8046           do kk=1,num_conti\r
8047             j1=jcont_hb(kk,i)\r
8048 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,\r
8049 c    &         ' jj=',jj,' kk=',kk\r
8050             if (j1.eq.j+1) then\r
8051 C Contacts I-J and (I+1)-J occur simultaneously. \r
8052 C The system loses extra energy.\r
8053 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)\r
8054             endif ! j1==j+1\r
8055           enddo ! kk\r
8056         enddo ! jj\r
8057       enddo ! i\r
8058       return\r
8059       end\r
8060 \r
8061 \r
8062 c--------------------------------------------------------------------\r
8063 \r
8064 \r
8065       subroutine add_hb_contact(ii,jj,itask)\r
8066       implicit real*8 (a-h,o-z)\r
8067       include "DIMENSIONS"\r
8068       include "COMMON.IOUNITS"\r
8069       integer max_cont\r
8070       integer max_dim\r
8071       parameter (max_cont=maxconts)\r
8072       parameter (max_dim=26)\r
8073       include "COMMON.CONTACTS"\r
8074       double precision zapas(max_dim,maxconts,max_fg_procs),\r
8075      &  zapas_recv(max_dim,maxconts,max_fg_procs)\r
8076       common /przechowalnia/ zapas\r
8077       integer i,j,ii,jj,iproc,itask(4),nn\r
8078 c      write (iout,*) "itask",itask\r
8079       do i=1,2\r
8080         iproc=itask(i)\r
8081         if (iproc.gt.0) then\r
8082           do j=1,num_cont_hb(ii)\r
8083             jjc=jcont_hb(j,ii)\r
8084 c            write (iout,*) "i",ii," j",jj," jjc",jjc\r
8085             if (jjc.eq.jj) then\r
8086               ncont_sent(iproc)=ncont_sent(iproc)+1\r
8087               nn=ncont_sent(iproc)\r
8088               zapas(1,nn,iproc)=ii\r
8089               zapas(2,nn,iproc)=jjc\r
8090               zapas(3,nn,iproc)=facont_hb(j,ii)\r
8091               zapas(4,nn,iproc)=ees0p(j,ii)\r
8092               zapas(5,nn,iproc)=ees0m(j,ii)\r
8093               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)\r
8094               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)\r
8095               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)\r
8096               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)\r
8097               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)\r
8098               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)\r
8099               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)\r
8100               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)\r
8101               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)\r
8102               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)\r
8103               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)\r
8104               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)\r
8105               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)\r
8106               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)\r
8107               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)\r
8108               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)\r
8109               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)\r
8110               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)\r
8111               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)\r
8112               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)\r
8113               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)\r
8114               exit\r
8115             endif\r
8116           enddo\r
8117         endif\r
8118       enddo\r
8119       return\r
8120       end\r
8121 \r
8122 \r
8123 c--------------------------------------------------------------------\r
8124 \r
8125 \r
8126       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,\r
8127      &  n_corr1)\r
8128 C This subroutine calculates multi-body contributions to hydrogen-bonding \r
8129       implicit real*8 (a-h,o-z)\r
8130       include 'DIMENSIONS'\r
8131       include 'COMMON.IOUNITS'\r
8132 #ifdef MPI\r
8133       include "mpif.h"\r
8134       parameter (max_cont=maxconts)\r
8135       parameter (max_dim=70)\r
8136       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error\r
8137       double precision zapas(max_dim,maxconts,max_fg_procs),\r
8138      &  zapas_recv(max_dim,maxconts,max_fg_procs)\r
8139       common /przechowalnia/ zapas\r
8140       integer status(MPI_STATUS_SIZE),req(maxconts*2),\r
8141      &  status_array(MPI_STATUS_SIZE,maxconts*2)\r
8142 #endif\r
8143       include 'COMMON.SETUP'\r
8144       include 'COMMON.FFIELD'\r
8145       include 'COMMON.DERIV'\r
8146       include 'COMMON.LOCAL'\r
8147       include 'COMMON.INTERACT'\r
8148       include 'COMMON.CONTACTS'\r
8149       include 'COMMON.CHAIN'\r
8150       include 'COMMON.CONTROL'\r
8151       double precision gx(3),gx1(3)\r
8152       integer num_cont_hb_old(maxres)\r
8153       logical lprn,ldone\r
8154       double precision eello4,eello5,eelo6,eello_turn6\r
8155       external eello4,eello5,eello6,eello_turn6\r
8156 C Set lprn=.true. for debugging\r
8157       lprn=.false.\r
8158       eturn6=0.0d0\r
8159 #ifdef MPI\r
8160       do i=1,nres\r
8161         num_cont_hb_old(i)=num_cont_hb(i)\r
8162       enddo\r
8163       n_corr=0\r
8164       n_corr1=0\r
8165       if (nfgtasks.le.1) goto 30\r
8166       if (lprn) then\r
8167         write (iout,'(a)') 'Contact function values before RECEIVE:'\r
8168         do i=nnt,nct-2\r
8169           write (iout,'(2i3,50(1x,i2,f5.2))') \r
8170      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),\r
8171      &    j=1,num_cont_hb(i))\r
8172         enddo\r
8173       endif\r
8174       call flush(iout)\r
8175       do i=1,ntask_cont_from\r
8176         ncont_recv(i)=0\r
8177       enddo\r
8178       do i=1,ntask_cont_to\r
8179         ncont_sent(i)=0\r
8180       enddo\r
8181 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",\r
8182 c     & ntask_cont_to\r
8183 C Make the list of contacts to send to send to other procesors\r
8184       do i=iturn3_start,iturn3_end\r
8185 c        write (iout,*) "make contact list turn3",i," num_cont",\r
8186 c     &    num_cont_hb(i)\r
8187         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))\r
8188       enddo\r
8189       do i=iturn4_start,iturn4_end\r
8190 c        write (iout,*) "make contact list turn4",i," num_cont",\r
8191 c     &   num_cont_hb(i)\r
8192         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))\r
8193       enddo\r
8194       do ii=1,nat_sent\r
8195         i=iat_sent(ii)\r
8196 c        write (iout,*) "make contact list longrange",i,ii," num_cont",\r
8197 c     &    num_cont_hb(i)\r
8198         do j=1,num_cont_hb(i)\r
8199         do k=1,4\r
8200           jjc=jcont_hb(j,i)\r
8201           iproc=iint_sent_local(k,jjc,ii)\r
8202 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc\r
8203           if (iproc.ne.0) then\r
8204             ncont_sent(iproc)=ncont_sent(iproc)+1\r
8205             nn=ncont_sent(iproc)\r
8206             zapas(1,nn,iproc)=i\r
8207             zapas(2,nn,iproc)=jjc\r
8208             zapas(3,nn,iproc)=d_cont(j,i)\r
8209             ind=3\r
8210             do kk=1,3\r
8211               ind=ind+1\r
8212               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)\r
8213             enddo\r
8214             do kk=1,2\r
8215               do ll=1,2\r
8216                 ind=ind+1\r
8217                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)\r
8218               enddo\r
8219             enddo\r
8220             do jj=1,5\r
8221               do kk=1,3\r
8222                 do ll=1,2\r
8223                   do mm=1,2\r
8224                     ind=ind+1\r
8225                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)\r
8226                   enddo\r
8227                 enddo\r
8228               enddo\r
8229             enddo\r
8230           endif\r
8231         enddo\r
8232         enddo\r
8233       enddo\r
8234       if (lprn) then\r
8235       write (iout,*) \r
8236      &  "Numbers of contacts to be sent to other processors",\r
8237      &  (ncont_sent(i),i=1,ntask_cont_to)\r
8238       write (iout,*) "Contacts sent"\r
8239       do ii=1,ntask_cont_to\r
8240         nn=ncont_sent(ii)\r
8241         iproc=itask_cont_to(ii)\r
8242         write (iout,*) nn," contacts to processor",iproc,\r
8243      &   " of CONT_TO_COMM group"\r
8244         do i=1,nn\r
8245           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)\r
8246         enddo\r
8247       enddo\r
8248       call flush(iout)\r
8249       endif\r
8250       CorrelType=477\r
8251       CorrelID=fg_rank+1\r
8252       CorrelType1=478\r
8253       CorrelID1=nfgtasks+fg_rank+1\r
8254       ireq=0\r
8255 C Receive the numbers of needed contacts from other processors \r
8256       do ii=1,ntask_cont_from\r
8257         iproc=itask_cont_from(ii)\r
8258         ireq=ireq+1\r
8259         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,\r
8260      &    FG_COMM,req(ireq),IERR)\r
8261       enddo\r
8262 c      write (iout,*) "IRECV ended"\r
8263 c      call flush(iout)\r
8264 C Send the number of contacts needed by other processors\r
8265       do ii=1,ntask_cont_to\r
8266         iproc=itask_cont_to(ii)\r
8267         ireq=ireq+1\r
8268         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,\r
8269      &    FG_COMM,req(ireq),IERR)\r
8270       enddo\r
8271 c      write (iout,*) "ISEND ended"\r
8272 c      write (iout,*) "number of requests (nn)",ireq\r
8273       call flush(iout)\r
8274       if (ireq.gt.0) \r
8275      &  call MPI_Waitall(ireq,req,status_array,ierr)\r
8276 c      write (iout,*) \r
8277 c     &  "Numbers of contacts to be received from other processors",\r
8278 c     &  (ncont_recv(i),i=1,ntask_cont_from)\r
8279 c      call flush(iout)\r
8280 C Receive contacts\r
8281       ireq=0\r
8282       do ii=1,ntask_cont_from\r
8283         iproc=itask_cont_from(ii)\r
8284         nn=ncont_recv(ii)\r
8285 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,\r
8286 c     &   " of CONT_TO_COMM group"\r
8287         call flush(iout)\r
8288         if (nn.gt.0) then\r
8289           ireq=ireq+1\r
8290           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,\r
8291      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)\r
8292 c          write (iout,*) "ireq,req",ireq,req(ireq)\r
8293         endif\r
8294       enddo\r
8295 C Send the contacts to processors that need them\r
8296       do ii=1,ntask_cont_to\r
8297         iproc=itask_cont_to(ii)\r
8298         nn=ncont_sent(ii)\r
8299 c        write (iout,*) nn," contacts to processor",iproc,\r
8300 c     &   " of CONT_TO_COMM group"\r
8301         if (nn.gt.0) then\r
8302           ireq=ireq+1 \r
8303           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,\r
8304      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)\r
8305 c          write (iout,*) "ireq,req",ireq,req(ireq)\r
8306 c          do i=1,nn\r
8307 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)\r
8308 c          enddo\r
8309         endif  \r
8310       enddo\r
8311 c      write (iout,*) "number of requests (contacts)",ireq\r
8312 c      write (iout,*) "req",(req(i),i=1,4)\r
8313 c      call flush(iout)\r
8314       if (ireq.gt.0) \r
8315      & call MPI_Waitall(ireq,req,status_array,ierr)\r
8316       do iii=1,ntask_cont_from\r
8317         iproc=itask_cont_from(iii)\r
8318         nn=ncont_recv(iii)\r
8319         if (lprn) then\r
8320         write (iout,*) "Received",nn," contacts from processor",iproc,\r
8321      &   " of CONT_FROM_COMM group"\r
8322         call flush(iout)\r
8323         do i=1,nn\r
8324           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)\r
8325         enddo\r
8326         call flush(iout)\r
8327         endif\r
8328         do i=1,nn\r
8329           ii=zapas_recv(1,i,iii)\r
8330 c Flag the received contacts to prevent double-counting\r
8331           jj=-zapas_recv(2,i,iii)\r
8332 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj\r
8333 c          call flush(iout)\r
8334           nnn=num_cont_hb(ii)+1\r
8335           num_cont_hb(ii)=nnn\r
8336           jcont_hb(nnn,ii)=jj\r
8337           d_cont(nnn,ii)=zapas_recv(3,i,iii)\r
8338           ind=3\r
8339           do kk=1,3\r
8340             ind=ind+1\r
8341             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)\r
8342           enddo\r
8343           do kk=1,2\r
8344             do ll=1,2\r
8345               ind=ind+1\r
8346               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)\r
8347             enddo\r
8348           enddo\r
8349           do jj=1,5\r
8350             do kk=1,3\r
8351               do ll=1,2\r
8352                 do mm=1,2\r
8353                   ind=ind+1\r
8354                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)\r
8355                 enddo\r
8356               enddo\r
8357             enddo\r
8358           enddo\r
8359         enddo\r
8360       enddo\r
8361       call flush(iout)\r
8362       if (lprn) then\r
8363         write (iout,'(a)') 'Contact function values after receive:'\r
8364         do i=nnt,nct-2\r
8365           write (iout,'(2i3,50(1x,i3,5f6.3))') \r
8366      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),\r
8367      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))\r
8368         enddo\r
8369         call flush(iout)\r
8370       endif\r
8371    30 continue\r
8372 #endif\r
8373       if (lprn) then\r
8374         write (iout,'(a)') 'Contact function values:'\r
8375         do i=nnt,nct-2\r
8376           write (iout,'(2i3,50(1x,i2,5f6.3))') \r
8377      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),\r
8378      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))\r
8379         enddo\r
8380       endif\r
8381       ecorr=0.0D0\r
8382       ecorr5=0.0d0\r
8383       ecorr6=0.0d0\r
8384 C Remove the loop below after debugging !!!\r
8385       do i=nnt,nct\r
8386         do j=1,3\r
8387           gradcorr(j,i)=0.0D0\r
8388           gradxorr(j,i)=0.0D0\r
8389         enddo\r
8390       enddo\r
8391 C Calculate the dipole-dipole interaction energies\r
8392       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then\r
8393       do i=iatel_s,iatel_e+1\r
8394         num_conti=num_cont_hb(i)\r
8395         do jj=1,num_conti\r
8396           j=jcont_hb(jj,i)\r
8397 #ifdef MOMENT\r
8398           call dipole(i,j,jj)\r
8399 #endif\r
8400         enddo\r
8401       enddo\r
8402       endif\r
8403 C Calculate the local-electrostatic correlation terms\r
8404 c                write (iout,*) "gradcorr5 in eello5 before loop"\r
8405 c                do iii=1,nres\r
8406 c                  write (iout,'(i5,3f10.5)') \r
8407 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)\r
8408 c                enddo\r
8409       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)\r
8410 c        write (iout,*) "corr loop i",i\r
8411         i1=i+1\r
8412         num_conti=num_cont_hb(i)\r
8413         num_conti1=num_cont_hb(i+1)\r
8414         do jj=1,num_conti\r
8415           j=jcont_hb(jj,i)\r
8416           jp=iabs(j)\r
8417           do kk=1,num_conti1\r
8418             j1=jcont_hb(kk,i1)\r
8419             jp1=iabs(j1)\r
8420 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,\r
8421 c     &         ' jj=',jj,' kk=',kk\r
8422 c            if (j1.eq.j+1 .or. j1.eq.j-1) then\r
8423             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 \r
8424      &          .or. j.lt.0 .and. j1.gt.0) .and.\r
8425      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then\r
8426 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously. \r
8427 C The system gains extra energy.\r
8428               n_corr=n_corr+1\r
8429               sqd1=dsqrt(d_cont(jj,i))\r
8430               sqd2=dsqrt(d_cont(kk,i1))\r
8431               sred_geom = sqd1*sqd2\r
8432               IF (sred_geom.lt.cutoff_corr) THEN\r
8433                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,\r
8434      &            ekont,fprimcont)\r
8435 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,\r
8436 cd     &         ' jj=',jj,' kk=',kk\r
8437                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont\r
8438                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont\r
8439                 do l=1,3\r
8440                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)\r
8441                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)\r
8442                 enddo\r
8443                 n_corr1=n_corr1+1\r
8444 cd               write (iout,*) 'sred_geom=',sred_geom,\r
8445 cd     &          ' ekont=',ekont,' fprim=',fprimcont,\r
8446 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2\r
8447 cd               write (iout,*) "g_contij",g_contij\r
8448 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)\r
8449 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)\r
8450                 call calc_eello(i,jp,i+1,jp1,jj,kk)\r
8451                 if (wcorr4.gt.0.0d0) \r
8452      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)\r
8453                   if (energy_dec.and.wcorr4.gt.0.0d0) \r
8454      1                 write (iout,'(a6,4i5,0pf7.3)')\r
8455      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)\r
8456 c                write (iout,*) "gradcorr5 before eello5"\r
8457 c                do iii=1,nres\r
8458 c                  write (iout,'(i5,3f10.5)') \r
8459 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)\r
8460 c                enddo\r
8461                 if (wcorr5.gt.0.0d0)\r
8462      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)\r
8463 c                write (iout,*) "gradcorr5 after eello5"\r
8464 c                do iii=1,nres\r
8465 c                  write (iout,'(i5,3f10.5)') \r
8466 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)\r
8467 c                enddo\r
8468                   if (energy_dec.and.wcorr5.gt.0.0d0) \r
8469      1                 write (iout,'(a6,4i5,0pf7.3)')\r
8470      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)\r
8471 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6\r
8472 cd                write(2,*)'ijkl',i,jp,i+1,jp1 \r
8473                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3\r
8474      &               .or. wturn6.eq.0.0d0))then\r
8475 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1\r
8476                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)\r
8477                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')\r
8478      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)\r
8479 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,\r
8480 cd     &            'ecorr6=',ecorr6\r
8481 cd                write (iout,'(4e15.5)') sred_geom,\r
8482 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),\r
8483 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),\r
8484 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))\r
8485                 else if (wturn6.gt.0.0d0\r
8486      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then\r
8487 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1\r
8488                   eturn6=eturn6+eello_turn6(i,jj,kk)\r
8489                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')\r
8490      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)\r
8491 cd                  write (2,*) 'multibody_eello:eturn6',eturn6\r
8492                 endif\r
8493               ENDIF\r
8494 1111          continue\r
8495             endif\r
8496           enddo ! kk\r
8497         enddo ! jj\r
8498       enddo ! i\r
8499       do i=1,nres\r
8500         num_cont_hb(i)=num_cont_hb_old(i)\r
8501       enddo\r
8502 c                write (iout,*) "gradcorr5 in eello5"\r
8503 c                do iii=1,nres\r
8504 c                  write (iout,'(i5,3f10.5)') \r
8505 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)\r
8506 c                enddo\r
8507       return\r
8508       end\r
8509 \r
8510 \r
8511 c--------------------------------------------------------------------\r
8512 \r
8513 \r
8514       subroutine add_hb_contact_eello(ii,jj,itask)\r
8515       implicit real*8 (a-h,o-z)\r
8516       include "DIMENSIONS"\r
8517       include "COMMON.IOUNITS"\r
8518       integer max_cont\r
8519       integer max_dim\r
8520       parameter (max_cont=maxconts)\r
8521       parameter (max_dim=70)\r
8522       include "COMMON.CONTACTS"\r
8523       double precision zapas(max_dim,maxconts,max_fg_procs),\r
8524      &  zapas_recv(max_dim,maxconts,max_fg_procs)\r
8525       common /przechowalnia/ zapas\r
8526       integer i,j,ii,jj,iproc,itask(4),nn\r
8527 c      write (iout,*) "itask",itask\r
8528       do i=1,2\r
8529         iproc=itask(i)\r
8530         if (iproc.gt.0) then\r
8531           do j=1,num_cont_hb(ii)\r
8532             jjc=jcont_hb(j,ii)\r
8533 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc\r
8534             if (jjc.eq.jj) then\r
8535               ncont_sent(iproc)=ncont_sent(iproc)+1\r
8536               nn=ncont_sent(iproc)\r
8537               zapas(1,nn,iproc)=ii\r
8538               zapas(2,nn,iproc)=jjc\r
8539               zapas(3,nn,iproc)=d_cont(j,ii)\r
8540               ind=3\r
8541               do kk=1,3\r
8542                 ind=ind+1\r
8543                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)\r
8544               enddo\r
8545               do kk=1,2\r
8546                 do ll=1,2\r
8547                   ind=ind+1\r
8548                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)\r
8549                 enddo\r
8550               enddo\r
8551               do jj=1,5\r
8552                 do kk=1,3\r
8553                   do ll=1,2\r
8554                     do mm=1,2\r
8555                       ind=ind+1\r
8556                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)\r
8557                     enddo\r
8558                   enddo\r
8559                 enddo\r
8560               enddo\r
8561               exit\r
8562             endif\r
8563           enddo\r
8564         endif\r
8565       enddo\r
8566       return\r
8567       end\r
8568 \r
8569 \r
8570 c--------------------------------------------------------------------\r
8571 \r
8572 \r
8573       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)\r
8574       implicit real*8 (a-h,o-z)\r
8575       include 'DIMENSIONS'\r
8576       include 'COMMON.IOUNITS'\r
8577       include 'COMMON.DERIV'\r
8578       include 'COMMON.INTERACT'\r
8579       include 'COMMON.CONTACTS'\r
8580       double precision gx(3),gx1(3)\r
8581       logical lprn\r
8582       lprn=.false.\r
8583       eij=facont_hb(jj,i)\r
8584       ekl=facont_hb(kk,k)\r
8585       ees0pij=ees0p(jj,i)\r
8586       ees0pkl=ees0p(kk,k)\r
8587       ees0mij=ees0m(jj,i)\r
8588       ees0mkl=ees0m(kk,k)\r
8589       ekont=eij*ekl\r
8590       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)\r
8591 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)\r
8592 C Following 4 lines for diagnostics.\r
8593 cd    ees0pkl=0.0D0\r
8594 cd    ees0pij=1.0D0\r
8595 cd    ees0mkl=0.0D0\r
8596 cd    ees0mij=1.0D0\r
8597 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')\r
8598 c     & 'Contacts ',i,j,\r
8599 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l\r
8600 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,\r
8601 c     & 'gradcorr_long'\r
8602 C Calculate the multi-body contribution to energy.\r
8603 c      ecorr=ecorr+ekont*ees\r
8604 C Calculate multi-body contributions to the gradient.\r
8605       coeffpees0pij=coeffp*ees0pij\r
8606       coeffmees0mij=coeffm*ees0mij\r
8607       coeffpees0pkl=coeffp*ees0pkl\r
8608       coeffmees0mkl=coeffm*ees0mkl\r
8609       do ll=1,3\r
8610 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)\r
8611         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi\r
8612      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+\r
8613      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))\r
8614         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi\r
8615      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+\r
8616      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))\r
8617 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)\r
8618         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk\r
8619      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+\r
8620      &  coeffmees0mij*gacontm_hb1(ll,kk,k))\r
8621         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk\r
8622      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+\r
8623      &  coeffmees0mij*gacontm_hb2(ll,kk,k))\r
8624         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-\r
8625      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+\r
8626      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))\r
8627         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij\r
8628         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij\r
8629         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-\r
8630      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+\r
8631      &     coeffmees0mij*gacontm_hb3(ll,kk,k))\r
8632         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl\r
8633         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl\r
8634 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl\r
8635       enddo\r
8636 c      write (iout,*)\r
8637 cgrad      do m=i+1,j-1\r
8638 cgrad        do ll=1,3\r
8639 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+\r
8640 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-\r
8641 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+\r
8642 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))\r
8643 cgrad        enddo\r
8644 cgrad      enddo\r
8645 cgrad      do m=k+1,l-1\r
8646 cgrad        do ll=1,3\r
8647 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+\r
8648 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-\r
8649 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+\r
8650 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))\r
8651 cgrad        enddo\r
8652 cgrad      enddo \r
8653 c      write (iout,*) "ehbcorr",ekont*ees\r
8654       ehbcorr=ekont*ees\r
8655       return\r
8656       end\r
8657 #ifdef MOMENT\r
8658 \r
8659 \r
8660 C--------------------------------------------------------------------\r
8661 \r
8662 \r
8663       subroutine dipole(i,j,jj)\r
8664       implicit real*8 (a-h,o-z)\r
8665       include 'DIMENSIONS'\r
8666       include 'COMMON.IOUNITS'\r
8667       include 'COMMON.CHAIN'\r
8668       include 'COMMON.FFIELD'\r
8669       include 'COMMON.DERIV'\r
8670       include 'COMMON.INTERACT'\r
8671       include 'COMMON.CONTACTS'\r
8672       include 'COMMON.TORSION'\r
8673       include 'COMMON.VAR'\r
8674       include 'COMMON.GEO'\r
8675       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),\r
8676      &  auxmat(2,2)\r
8677       iti1 = itortyp(itype(i+1))\r
8678       if (j.lt.nres-1) then\r
8679         itj1 = itortyp(itype(j+1))\r
8680       else\r
8681         itj1=ntortyp+1\r
8682       endif\r
8683       do iii=1,2\r
8684         dipi(iii,1)=Ub2(iii,i)\r
8685         dipderi(iii)=Ub2der(iii,i)\r
8686         dipi(iii,2)=b1(iii,iti1)\r
8687         dipj(iii,1)=Ub2(iii,j)\r
8688         dipderj(iii)=Ub2der(iii,j)\r
8689         dipj(iii,2)=b1(iii,itj1)\r
8690       enddo\r
8691       kkk=0\r
8692       do iii=1,2\r
8693         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1)) \r
8694         do jjj=1,2\r
8695           kkk=kkk+1\r
8696           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))\r
8697         enddo\r
8698       enddo\r
8699       do kkk=1,5\r
8700         do lll=1,3\r
8701           mmm=0\r
8702           do iii=1,2\r
8703             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),\r
8704      &        auxvec(1))\r
8705             do jjj=1,2\r
8706               mmm=mmm+1\r
8707               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))\r
8708             enddo\r
8709           enddo\r
8710         enddo\r
8711       enddo\r
8712       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))\r
8713       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))\r
8714       do iii=1,2\r
8715         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))\r
8716       enddo\r
8717       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))\r
8718       do iii=1,2\r
8719         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))\r
8720       enddo\r
8721       return\r
8722       end\r
8723 #endif\r
8724 \r
8725 \r
8726 C--------------------------------------------------------------------\r
8727 \r
8728 \r
8729       subroutine calc_eello(i,j,k,l,jj,kk)\r
8730 C \r
8731 C This subroutine computes matrices and vectors needed to calculate \r
8732 C the fourth-, fifth-, and sixth-order local-electrostatic terms.\r
8733 C\r
8734       implicit real*8 (a-h,o-z)\r
8735       include 'DIMENSIONS'\r
8736       include 'COMMON.IOUNITS'\r
8737       include 'COMMON.CHAIN'\r
8738       include 'COMMON.DERIV'\r
8739       include 'COMMON.INTERACT'\r
8740       include 'COMMON.CONTACTS'\r
8741       include 'COMMON.TORSION'\r
8742       include 'COMMON.VAR'\r
8743       include 'COMMON.GEO'\r
8744       include 'COMMON.FFIELD'\r
8745       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),\r
8746      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)\r
8747       logical lprn\r
8748       common /kutas/ lprn\r
8749 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,\r
8750 cd     & ' jj=',jj,' kk=',kk\r
8751 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return\r
8752 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)\r
8753 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)\r
8754       do iii=1,2\r
8755         do jjj=1,2\r
8756           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)\r
8757           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)\r
8758         enddo\r
8759       enddo\r
8760       call transpose2(aa1(1,1),aa1t(1,1))\r
8761       call transpose2(aa2(1,1),aa2t(1,1))\r
8762       do kkk=1,5\r
8763         do lll=1,3\r
8764           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),\r
8765      &      aa1tder(1,1,lll,kkk))\r
8766           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),\r
8767      &      aa2tder(1,1,lll,kkk))\r
8768         enddo\r
8769       enddo \r
8770       if (l.eq.j+1) then\r
8771 C parallel orientation of the two CA-CA-CA frames.\r
8772         if (i.gt.1) then\r
8773           iti=itortyp(itype(i))\r
8774         else\r
8775           iti=ntortyp+1\r
8776         endif\r
8777         itk1=itortyp(itype(k+1))\r
8778         itj=itortyp(itype(j))\r
8779         if (l.lt.nres-1) then\r
8780           itl1=itortyp(itype(l+1))\r
8781         else\r
8782           itl1=ntortyp+1\r
8783         endif\r
8784 C A1 kernel(j+1) A2T\r
8785 cd        do iii=1,2\r
8786 cd          write (iout,'(3f10.5,5x,3f10.5)') \r
8787 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)\r
8788 cd        enddo\r
8789         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),\r
8790      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),\r
8791      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))\r
8792 C Following matrices are needed only for 6-th order cumulants\r
8793         IF (wcorr6.gt.0.0d0) THEN\r
8794         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),\r
8795      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),\r
8796      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))\r
8797         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),\r
8798      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),\r
8799      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),\r
8800      &   ADtEAderx(1,1,1,1,1,1))\r
8801         lprn=.false.\r
8802         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),\r
8803      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),\r
8804      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),\r
8805      &   ADtEA1derx(1,1,1,1,1,1))\r
8806         ENDIF\r
8807 C End 6-th order cumulants\r
8808 cd        lprn=.false.\r
8809 cd        if (lprn) then\r
8810 cd        write (2,*) 'In calc_eello6'\r
8811 cd        do iii=1,2\r
8812 cd          write (2,*) 'iii=',iii\r
8813 cd          do kkk=1,5\r
8814 cd            write (2,*) 'kkk=',kkk\r
8815 cd            do jjj=1,2\r
8816 cd              write (2,'(3(2f10.5),5x)') \r
8817 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)\r
8818 cd            enddo\r
8819 cd          enddo\r
8820 cd        enddo\r
8821 cd        endif\r
8822         call transpose2(EUgder(1,1,k),auxmat(1,1))\r
8823         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))\r
8824         call transpose2(EUg(1,1,k),auxmat(1,1))\r
8825         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))\r
8826         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))\r
8827         do iii=1,2\r
8828           do kkk=1,5\r
8829             do lll=1,3\r
8830               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),\r
8831      &          EAEAderx(1,1,lll,kkk,iii,1))\r
8832             enddo\r
8833           enddo\r
8834         enddo\r
8835 C A1T kernel(i+1) A2\r
8836         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),\r
8837      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),\r
8838      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))\r
8839 C Following matrices are needed only for 6-th order cumulants\r
8840         IF (wcorr6.gt.0.0d0) THEN\r
8841         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),\r
8842      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),\r
8843      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))\r
8844         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),\r
8845      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),\r
8846      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),\r
8847      &   ADtEAderx(1,1,1,1,1,2))\r
8848         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),\r
8849      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),\r
8850      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),\r
8851      &   ADtEA1derx(1,1,1,1,1,2))\r
8852         ENDIF\r
8853 C End 6-th order cumulants\r
8854         call transpose2(EUgder(1,1,l),auxmat(1,1))\r
8855         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))\r
8856         call transpose2(EUg(1,1,l),auxmat(1,1))\r
8857         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))\r
8858         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))\r
8859         do iii=1,2\r
8860           do kkk=1,5\r
8861             do lll=1,3\r
8862               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),\r
8863      &          EAEAderx(1,1,lll,kkk,iii,2))\r
8864             enddo\r
8865           enddo\r
8866         enddo\r
8867 C AEAb1 and AEAb2\r
8868 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.\r
8869 C They are needed only when the fifth- or the sixth-order cumulants are\r
8870 C indluded.\r
8871         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN\r
8872         call transpose2(AEA(1,1,1),auxmat(1,1))\r
8873         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))\r
8874         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))\r
8875         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))\r
8876         call transpose2(AEAderg(1,1,1),auxmat(1,1))\r
8877         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))\r
8878         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))\r
8879         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))\r
8880         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))\r
8881         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))\r
8882         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))\r
8883         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))\r
8884         call transpose2(AEA(1,1,2),auxmat(1,1))\r
8885         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))\r
8886         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))\r
8887         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))\r
8888         call transpose2(AEAderg(1,1,2),auxmat(1,1))\r
8889         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))\r
8890         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))\r
8891         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))\r
8892         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))\r
8893         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))\r
8894         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))\r
8895         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))\r
8896 C Calculate the Cartesian derivatives of the vectors.\r
8897         do iii=1,2\r
8898           do kkk=1,5\r
8899             do lll=1,3\r
8900               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))\r
8901               call matvec2(auxmat(1,1),b1(1,iti),\r
8902      &          AEAb1derx(1,lll,kkk,iii,1,1))\r
8903               call matvec2(auxmat(1,1),Ub2(1,i),\r
8904      &          AEAb2derx(1,lll,kkk,iii,1,1))\r
8905               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),\r
8906      &          AEAb1derx(1,lll,kkk,iii,2,1))\r
8907               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),\r
8908      &          AEAb2derx(1,lll,kkk,iii,2,1))\r
8909               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))\r
8910               call matvec2(auxmat(1,1),b1(1,itj),\r
8911      &          AEAb1derx(1,lll,kkk,iii,1,2))\r
8912               call matvec2(auxmat(1,1),Ub2(1,j),\r
8913      &          AEAb2derx(1,lll,kkk,iii,1,2))\r
8914               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),\r
8915      &          AEAb1derx(1,lll,kkk,iii,2,2))\r
8916               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),\r
8917      &          AEAb2derx(1,lll,kkk,iii,2,2))\r
8918             enddo\r
8919           enddo\r
8920         enddo\r
8921         ENDIF\r
8922 C End vectors\r
8923       else\r
8924 C Antiparallel orientation of the two CA-CA-CA frames.\r
8925         if (i.gt.1) then\r
8926           iti=itortyp(itype(i))\r
8927         else\r
8928           iti=ntortyp+1\r
8929         endif\r
8930         itk1=itortyp(itype(k+1))\r
8931         itl=itortyp(itype(l))\r
8932         itj=itortyp(itype(j))\r
8933         if (j.lt.nres-1) then\r
8934           itj1=itortyp(itype(j+1))\r
8935         else \r
8936           itj1=ntortyp+1\r
8937         endif\r
8938 C A2 kernel(j-1)T A1T\r
8939         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),\r
8940      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),\r
8941      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))\r
8942 C Following matrices are needed only for 6-th order cumulants\r
8943         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.\r
8944      &     j.eq.i+4 .and. l.eq.i+3)) THEN\r
8945         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),\r
8946      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),\r
8947      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))\r
8948         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),\r
8949      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),\r
8950      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),\r
8951      &   ADtEAderx(1,1,1,1,1,1))\r
8952         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),\r
8953      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),\r
8954      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),\r
8955      &   ADtEA1derx(1,1,1,1,1,1))\r
8956         ENDIF\r
8957 C End 6-th order cumulants\r
8958         call transpose2(EUgder(1,1,k),auxmat(1,1))\r
8959         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))\r
8960         call transpose2(EUg(1,1,k),auxmat(1,1))\r
8961         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))\r
8962         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))\r
8963         do iii=1,2\r
8964           do kkk=1,5\r
8965             do lll=1,3\r
8966               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),\r
8967      &          EAEAderx(1,1,lll,kkk,iii,1))\r
8968             enddo\r
8969           enddo\r
8970         enddo\r
8971 C A2T kernel(i+1)T A1\r
8972         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),\r
8973      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),\r
8974      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))\r
8975 C Following matrices are needed only for 6-th order cumulants\r
8976         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.\r
8977      &     j.eq.i+4 .and. l.eq.i+3)) THEN\r
8978         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),\r
8979      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),\r
8980      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))\r
8981         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),\r
8982      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),\r
8983      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),\r
8984      &   ADtEAderx(1,1,1,1,1,2))\r
8985         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),\r
8986      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),\r
8987      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),\r
8988      &   ADtEA1derx(1,1,1,1,1,2))\r
8989         ENDIF\r
8990 C End 6-th order cumulants\r
8991         call transpose2(EUgder(1,1,j),auxmat(1,1))\r
8992         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))\r
8993         call transpose2(EUg(1,1,j),auxmat(1,1))\r
8994         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))\r
8995         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))\r
8996         do iii=1,2\r
8997           do kkk=1,5\r
8998             do lll=1,3\r
8999               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),\r
9000      &          EAEAderx(1,1,lll,kkk,iii,2))\r
9001             enddo\r
9002           enddo\r
9003         enddo\r
9004 C AEAb1 and AEAb2\r
9005 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.\r
9006 C They are needed only when the fifth- or the sixth-order cumulants are\r
9007 C indluded.\r
9008         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.\r
9009      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN\r
9010         call transpose2(AEA(1,1,1),auxmat(1,1))\r
9011         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))\r
9012         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))\r
9013         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))\r
9014         call transpose2(AEAderg(1,1,1),auxmat(1,1))\r
9015         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))\r
9016         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))\r
9017         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))\r
9018         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))\r
9019         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))\r
9020         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))\r
9021         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))\r
9022         call transpose2(AEA(1,1,2),auxmat(1,1))\r
9023         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))\r
9024         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))\r
9025         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))\r
9026         call transpose2(AEAderg(1,1,2),auxmat(1,1))\r
9027         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))\r
9028         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))\r
9029         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))\r
9030         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))\r
9031         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))\r
9032         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))\r
9033         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))\r
9034 C Calculate the Cartesian derivatives of the vectors.\r
9035         do iii=1,2\r
9036           do kkk=1,5\r
9037             do lll=1,3\r
9038               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))\r
9039               call matvec2(auxmat(1,1),b1(1,iti),\r
9040      &          AEAb1derx(1,lll,kkk,iii,1,1))\r
9041               call matvec2(auxmat(1,1),Ub2(1,i),\r
9042      &          AEAb2derx(1,lll,kkk,iii,1,1))\r
9043               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),\r
9044      &          AEAb1derx(1,lll,kkk,iii,2,1))\r
9045               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),\r
9046      &          AEAb2derx(1,lll,kkk,iii,2,1))\r
9047               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))\r
9048               call matvec2(auxmat(1,1),b1(1,itl),\r
9049      &          AEAb1derx(1,lll,kkk,iii,1,2))\r
9050               call matvec2(auxmat(1,1),Ub2(1,l),\r
9051      &          AEAb2derx(1,lll,kkk,iii,1,2))\r
9052               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),\r
9053      &          AEAb1derx(1,lll,kkk,iii,2,2))\r
9054               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),\r
9055      &          AEAb2derx(1,lll,kkk,iii,2,2))\r
9056             enddo\r
9057           enddo\r
9058         enddo\r
9059         ENDIF\r
9060 C End vectors\r
9061       endif\r
9062       return\r
9063       end\r
9064 \r
9065 \r
9066 C--------------------------------------------------------------------\r
9067 \r
9068 \r
9069       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,\r
9070      &  KK,KKderg,AKA,AKAderg,AKAderx)\r
9071       implicit none\r
9072       integer nderg\r
9073       logical transp\r
9074       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),\r
9075      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),\r
9076      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)\r
9077       integer iii,kkk,lll\r
9078       integer jjj,mmm\r
9079       logical lprn\r
9080       common /kutas/ lprn\r
9081       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))\r
9082       do iii=1,nderg \r
9083         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,\r
9084      &    AKAderg(1,1,iii))\r
9085       enddo\r
9086 cd      if (lprn) write (2,*) 'In kernel'\r
9087       do kkk=1,5\r
9088 cd        if (lprn) write (2,*) 'kkk=',kkk\r
9089         do lll=1,3\r
9090           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),\r
9091      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))\r
9092 cd          if (lprn) then\r
9093 cd            write (2,*) 'lll=',lll\r
9094 cd            write (2,*) 'iii=1'\r
9095 cd            do jjj=1,2\r
9096 cd              write (2,'(3(2f10.5),5x)') \r
9097 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)\r
9098 cd            enddo\r
9099 cd          endif\r
9100           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),\r
9101      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))\r
9102 cd          if (lprn) then\r
9103 cd            write (2,*) 'lll=',lll\r
9104 cd            write (2,*) 'iii=2'\r
9105 cd            do jjj=1,2\r
9106 cd              write (2,'(3(2f10.5),5x)') \r
9107 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)\r
9108 cd            enddo\r
9109 cd          endif\r
9110         enddo\r
9111       enddo\r
9112       return\r
9113       end\r
9114 \r
9115 \r
9116 C--------------------------------------------------------------------\r
9117 \r
9118 \r
9119       double precision function eello4(i,j,k,l,jj,kk)\r
9120       implicit real*8 (a-h,o-z)\r
9121       include 'DIMENSIONS'\r
9122       include 'COMMON.IOUNITS'\r
9123       include 'COMMON.CHAIN'\r
9124       include 'COMMON.DERIV'\r
9125       include 'COMMON.INTERACT'\r
9126       include 'COMMON.CONTACTS'\r
9127       include 'COMMON.TORSION'\r
9128       include 'COMMON.VAR'\r
9129       include 'COMMON.GEO'\r
9130       double precision pizda(2,2),ggg1(3),ggg2(3)\r
9131 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then\r
9132 cd        eello4=0.0d0\r
9133 cd        return\r
9134 cd      endif\r
9135 cd      print *,'eello4:',i,j,k,l,jj,kk\r
9136 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l\r
9137 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)\r
9138 cold      eij=facont_hb(jj,i)\r
9139 cold      ekl=facont_hb(kk,k)\r
9140 cold      ekont=eij*ekl\r
9141       eel4=-EAEA(1,1,1)-EAEA(2,2,1)\r
9142 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)\r
9143       gcorr_loc(k-1)=gcorr_loc(k-1)\r
9144      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))\r
9145       if (l.eq.j+1) then\r
9146         gcorr_loc(l-1)=gcorr_loc(l-1)\r
9147      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))\r
9148       else\r
9149         gcorr_loc(j-1)=gcorr_loc(j-1)\r
9150      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))\r
9151       endif\r
9152       do iii=1,2\r
9153         do kkk=1,5\r
9154           do lll=1,3\r
9155             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)\r
9156      &                        -EAEAderx(2,2,lll,kkk,iii,1)\r
9157 cd            derx(lll,kkk,iii)=0.0d0\r
9158           enddo\r
9159         enddo\r
9160       enddo\r
9161 cd      gcorr_loc(l-1)=0.0d0\r
9162 cd      gcorr_loc(j-1)=0.0d0\r
9163 cd      gcorr_loc(k-1)=0.0d0\r
9164 cd      eel4=1.0d0\r
9165 cd      write (iout,*)'Contacts have occurred for peptide groups',\r
9166 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,\r
9167 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num\r
9168       if (j.lt.nres-1) then\r
9169         j1=j+1\r
9170         j2=j-1\r
9171       else\r
9172         j1=j-1\r
9173         j2=j-2\r
9174       endif\r
9175       if (l.lt.nres-1) then\r
9176         l1=l+1\r
9177         l2=l-1\r
9178       else\r
9179         l1=l-1\r
9180         l2=l-2\r
9181       endif\r
9182       do ll=1,3\r
9183 cgrad        ggg1(ll)=eel4*g_contij(ll,1)\r
9184 cgrad        ggg2(ll)=eel4*g_contij(ll,2)\r
9185         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)\r
9186         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)\r
9187 cgrad        ghalf=0.5d0*ggg1(ll)\r
9188         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)\r
9189         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)\r
9190         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)\r
9191         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)\r
9192         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij\r
9193         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij\r
9194 cgrad        ghalf=0.5d0*ggg2(ll)\r
9195         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)\r
9196         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)\r
9197         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)\r
9198         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)\r
9199         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl\r
9200         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl\r
9201       enddo\r
9202 cgrad      do m=i+1,j-1\r
9203 cgrad        do ll=1,3\r
9204 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)\r
9205 cgrad        enddo\r
9206 cgrad      enddo\r
9207 cgrad      do m=k+1,l-1\r
9208 cgrad        do ll=1,3\r
9209 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)\r
9210 cgrad        enddo\r
9211 cgrad      enddo\r
9212 cgrad      do m=i+2,j2\r
9213 cgrad        do ll=1,3\r
9214 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)\r
9215 cgrad        enddo\r
9216 cgrad      enddo\r
9217 cgrad      do m=k+2,l2\r
9218 cgrad        do ll=1,3\r
9219 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)\r
9220 cgrad        enddo\r
9221 cgrad      enddo \r
9222 cd      do iii=1,nres-3\r
9223 cd        write (2,*) iii,gcorr_loc(iii)\r
9224 cd      enddo\r
9225       eello4=ekont*eel4\r
9226 cd      write (2,*) 'ekont',ekont\r
9227 cd      write (iout,*) 'eello4',ekont*eel4\r
9228       return\r
9229       end\r
9230 \r
9231 \r
9232 C--------------------------------------------------------------------\r
9233 \r
9234 \r
9235       double precision function eello5(i,j,k,l,jj,kk)\r
9236       implicit real*8 (a-h,o-z)\r
9237       include 'DIMENSIONS'\r
9238       include 'COMMON.IOUNITS'\r
9239       include 'COMMON.CHAIN'\r
9240       include 'COMMON.DERIV'\r
9241       include 'COMMON.INTERACT'\r
9242       include 'COMMON.CONTACTS'\r
9243       include 'COMMON.TORSION'\r
9244       include 'COMMON.VAR'\r
9245       include 'COMMON.GEO'\r
9246       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)\r
9247       double precision ggg1(3),ggg2(3)\r
9248 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC\r
9249 C                                                                              C\r
9250 C                            Parallel chains                                   C\r
9251 C                                                                              C\r
9252 C          o             o                   o             o                   C\r
9253 C         /l\           / \             \   / \           / \   /              C\r
9254 C        /   \         /   \             \ /   \         /   \ /               C\r
9255 C       j| o |l1       | o |              o| o |         | o |o                C\r
9256 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C\r
9257 C      \i/   \         /   \ /             /   \         /   \                 C\r
9258 C       o    k1             o                                                  C\r
9259 C         (I)          (II)                (III)          (IV)                 C\r
9260 C                                                                              C\r
9261 C      eello5_1        eello5_2            eello5_3       eello5_4             C\r
9262 C                                                                              C\r
9263 C                            Antiparallel chains                               C\r
9264 C                                                                              C\r
9265 C          o             o                   o             o                   C\r
9266 C         /j\           / \             \   / \           / \   /              C\r
9267 C        /   \         /   \             \ /   \         /   \ /               C\r
9268 C      j1| o |l        | o |              o| o |         | o |o                C\r
9269 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C\r
9270 C      \i/   \         /   \ /             /   \         /   \                 C\r
9271 C       o     k1            o                                                  C\r
9272 C         (I)          (II)                (III)          (IV)                 C\r
9273 C                                                                              C\r
9274 C      eello5_1        eello5_2            eello5_3       eello5_4             C\r
9275 C                                                                              C\r
9276 C o denotes a local interaction, vertical lines an electrostatic interaction.  C\r
9277 C                                                                              C\r
9278 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC\r
9279 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then\r
9280 cd        eello5=0.0d0\r
9281 cd        return\r
9282 cd      endif\r
9283 cd      write (iout,*)\r
9284 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,\r
9285 cd     &   ' and',k,l\r
9286       itk=itortyp(itype(k))\r
9287       itl=itortyp(itype(l))\r
9288       itj=itortyp(itype(j))\r
9289       eello5_1=0.0d0\r
9290       eello5_2=0.0d0\r
9291       eello5_3=0.0d0\r
9292       eello5_4=0.0d0\r
9293 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,\r
9294 cd     &   eel5_3_num,eel5_4_num)\r
9295       do iii=1,2\r
9296         do kkk=1,5\r
9297           do lll=1,3\r
9298             derx(lll,kkk,iii)=0.0d0\r
9299           enddo\r
9300         enddo\r
9301       enddo\r
9302 cd      eij=facont_hb(jj,i)\r
9303 cd      ekl=facont_hb(kk,k)\r
9304 cd      ekont=eij*ekl\r
9305 cd      write (iout,*)'Contacts have occurred for peptide groups',\r
9306 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l\r
9307 cd      goto 1111\r
9308 C Contribution from the graph I.\r
9309 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)\r
9310 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)\r
9311       call transpose2(EUg(1,1,k),auxmat(1,1))\r
9312       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))\r
9313       vv(1)=pizda(1,1)-pizda(2,2)\r
9314       vv(2)=pizda(1,2)+pizda(2,1)\r
9315       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))\r
9316      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))\r
9317 C Explicit gradient in virtual-dihedral angles.\r
9318       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)\r
9319      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))\r
9320      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))\r
9321       call transpose2(EUgder(1,1,k),auxmat1(1,1))\r
9322       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))\r
9323       vv(1)=pizda(1,1)-pizda(2,2)\r
9324       vv(2)=pizda(1,2)+pizda(2,1)\r
9325       g_corr5_loc(k-1)=g_corr5_loc(k-1)\r
9326      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))\r
9327      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))\r
9328       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))\r
9329       vv(1)=pizda(1,1)-pizda(2,2)\r
9330       vv(2)=pizda(1,2)+pizda(2,1)\r
9331       if (l.eq.j+1) then\r
9332         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)\r
9333      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))\r
9334      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))\r
9335       else\r
9336         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)\r
9337      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))\r
9338      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))\r
9339       endif \r
9340 C Cartesian gradient\r
9341       do iii=1,2\r
9342         do kkk=1,5\r
9343           do lll=1,3\r
9344             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),\r
9345      &        pizda(1,1))\r
9346             vv(1)=pizda(1,1)-pizda(2,2)\r
9347             vv(2)=pizda(1,2)+pizda(2,1)\r
9348             derx(lll,kkk,iii)=derx(lll,kkk,iii)\r
9349      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))\r
9350      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))\r
9351           enddo\r
9352         enddo\r
9353       enddo\r
9354 c      goto 1112\r
9355 c1111  continue\r
9356 C Contribution from graph II \r
9357       call transpose2(EE(1,1,itk),auxmat(1,1))\r
9358       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))\r
9359       vv(1)=pizda(1,1)+pizda(2,2)\r
9360       vv(2)=pizda(2,1)-pizda(1,2)\r
9361       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))\r
9362      & -0.5d0*scalar2(vv(1),Ctobr(1,k))\r
9363 C Explicit gradient in virtual-dihedral angles.\r
9364       g_corr5_loc(k-1)=g_corr5_loc(k-1)\r
9365      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))\r
9366       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))\r
9367       vv(1)=pizda(1,1)+pizda(2,2)\r
9368       vv(2)=pizda(2,1)-pizda(1,2)\r
9369       if (l.eq.j+1) then\r
9370         g_corr5_loc(l-1)=g_corr5_loc(l-1)\r
9371      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))\r
9372      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))\r
9373       else\r
9374         g_corr5_loc(j-1)=g_corr5_loc(j-1)\r
9375      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))\r
9376      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))\r
9377       endif\r
9378 C Cartesian gradient\r
9379       do iii=1,2\r
9380         do kkk=1,5\r
9381           do lll=1,3\r
9382             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),\r
9383      &        pizda(1,1))\r
9384             vv(1)=pizda(1,1)+pizda(2,2)\r
9385             vv(2)=pizda(2,1)-pizda(1,2)\r
9386             derx(lll,kkk,iii)=derx(lll,kkk,iii)\r
9387      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))\r
9388      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))\r
9389           enddo\r
9390         enddo\r
9391       enddo\r
9392 cd      goto 1112\r
9393 cd1111  continue\r
9394       if (l.eq.j+1) then\r
9395 cd        goto 1110\r
9396 C Parallel orientation\r
9397 C Contribution from graph III\r
9398         call transpose2(EUg(1,1,l),auxmat(1,1))\r
9399         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))\r
9400         vv(1)=pizda(1,1)-pizda(2,2)\r
9401         vv(2)=pizda(1,2)+pizda(2,1)\r
9402         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))\r
9403      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))\r
9404 C Explicit gradient in virtual-dihedral angles.\r
9405         g_corr5_loc(j-1)=g_corr5_loc(j-1)\r
9406      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))\r
9407      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))\r
9408         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))\r
9409         vv(1)=pizda(1,1)-pizda(2,2)\r
9410         vv(2)=pizda(1,2)+pizda(2,1)\r
9411         g_corr5_loc(k-1)=g_corr5_loc(k-1)\r
9412      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))\r
9413      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))\r
9414         call transpose2(EUgder(1,1,l),auxmat1(1,1))\r
9415         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))\r
9416         vv(1)=pizda(1,1)-pizda(2,2)\r
9417         vv(2)=pizda(1,2)+pizda(2,1)\r
9418         g_corr5_loc(l-1)=g_corr5_loc(l-1)\r
9419      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))\r
9420      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))\r
9421 C Cartesian gradient\r
9422         do iii=1,2\r
9423           do kkk=1,5\r
9424             do lll=1,3\r
9425               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),\r
9426      &          pizda(1,1))\r
9427               vv(1)=pizda(1,1)-pizda(2,2)\r
9428               vv(2)=pizda(1,2)+pizda(2,1)\r
9429               derx(lll,kkk,iii)=derx(lll,kkk,iii)\r
9430      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))\r
9431      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))\r
9432             enddo\r
9433           enddo\r
9434         enddo\r
9435 cd        goto 1112\r
9436 C Contribution from graph IV\r
9437 cd1110    continue\r
9438         call transpose2(EE(1,1,itl),auxmat(1,1))\r
9439         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))\r
9440         vv(1)=pizda(1,1)+pizda(2,2)\r
9441         vv(2)=pizda(2,1)-pizda(1,2)\r
9442         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))\r
9443      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))\r
9444 C Explicit gradient in virtual-dihedral angles.\r
9445         g_corr5_loc(l-1)=g_corr5_loc(l-1)\r
9446      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))\r
9447         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))\r
9448         vv(1)=pizda(1,1)+pizda(2,2)\r
9449         vv(2)=pizda(2,1)-pizda(1,2)\r
9450         g_corr5_loc(k-1)=g_corr5_loc(k-1)\r
9451      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))\r
9452      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))\r
9453 C Cartesian gradient\r
9454         do iii=1,2\r
9455           do kkk=1,5\r
9456             do lll=1,3\r
9457               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),\r
9458      &          pizda(1,1))\r
9459               vv(1)=pizda(1,1)+pizda(2,2)\r
9460               vv(2)=pizda(2,1)-pizda(1,2)\r
9461               derx(lll,kkk,iii)=derx(lll,kkk,iii)\r
9462      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))\r
9463      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))\r
9464             enddo\r
9465           enddo\r
9466         enddo\r
9467       else\r
9468 C Antiparallel orientation\r
9469 C Contribution from graph III\r
9470 c        goto 1110\r
9471         call transpose2(EUg(1,1,j),auxmat(1,1))\r
9472         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))\r
9473         vv(1)=pizda(1,1)-pizda(2,2)\r
9474         vv(2)=pizda(1,2)+pizda(2,1)\r
9475         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))\r
9476      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))\r
9477 C Explicit gradient in virtual-dihedral angles.\r
9478         g_corr5_loc(l-1)=g_corr5_loc(l-1)\r
9479      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))\r
9480      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))\r
9481         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))\r
9482         vv(1)=pizda(1,1)-pizda(2,2)\r
9483         vv(2)=pizda(1,2)+pizda(2,1)\r
9484         g_corr5_loc(k-1)=g_corr5_loc(k-1)\r
9485      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))\r
9486      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))\r
9487         call transpose2(EUgder(1,1,j),auxmat1(1,1))\r
9488         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))\r
9489         vv(1)=pizda(1,1)-pizda(2,2)\r
9490         vv(2)=pizda(1,2)+pizda(2,1)\r
9491         g_corr5_loc(j-1)=g_corr5_loc(j-1)\r
9492      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))\r
9493      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))\r
9494 C Cartesian gradient\r
9495         do iii=1,2\r
9496           do kkk=1,5\r
9497             do lll=1,3\r
9498               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),\r
9499      &          pizda(1,1))\r
9500               vv(1)=pizda(1,1)-pizda(2,2)\r
9501               vv(2)=pizda(1,2)+pizda(2,1)\r
9502               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)\r
9503      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))\r
9504      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))\r
9505             enddo\r
9506           enddo\r
9507         enddo\r
9508 cd        goto 1112\r
9509 C Contribution from graph IV\r
9510 1110    continue\r
9511         call transpose2(EE(1,1,itj),auxmat(1,1))\r
9512         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))\r
9513         vv(1)=pizda(1,1)+pizda(2,2)\r
9514         vv(2)=pizda(2,1)-pizda(1,2)\r
9515         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))\r
9516      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))\r
9517 C Explicit gradient in virtual-dihedral angles.\r
9518         g_corr5_loc(j-1)=g_corr5_loc(j-1)\r
9519      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))\r
9520         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))\r
9521         vv(1)=pizda(1,1)+pizda(2,2)\r
9522         vv(2)=pizda(2,1)-pizda(1,2)\r
9523         g_corr5_loc(k-1)=g_corr5_loc(k-1)\r
9524      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))\r
9525      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))\r
9526 C Cartesian gradient\r
9527         do iii=1,2\r
9528           do kkk=1,5\r
9529             do lll=1,3\r
9530               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),\r
9531      &          pizda(1,1))\r
9532               vv(1)=pizda(1,1)+pizda(2,2)\r
9533               vv(2)=pizda(2,1)-pizda(1,2)\r
9534               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)\r
9535      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))\r
9536      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))\r
9537             enddo\r
9538           enddo\r
9539         enddo\r
9540       endif\r
9541 1112  continue\r
9542       eel5=eello5_1+eello5_2+eello5_3+eello5_4\r
9543 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then\r
9544 cd        write (2,*) 'ijkl',i,j,k,l\r
9545 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,\r
9546 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4\r
9547 cd      endif\r
9548 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num\r
9549 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num\r
9550 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num\r
9551 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num\r
9552       if (j.lt.nres-1) then\r
9553         j1=j+1\r
9554         j2=j-1\r
9555       else\r
9556         j1=j-1\r
9557         j2=j-2\r
9558       endif\r
9559       if (l.lt.nres-1) then\r
9560         l1=l+1\r
9561         l2=l-1\r
9562       else\r
9563         l1=l-1\r
9564         l2=l-2\r
9565       endif\r
9566 cd      eij=1.0d0\r
9567 cd      ekl=1.0d0\r
9568 cd      ekont=1.0d0\r
9569 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont\r
9570 C 2/11/08 AL Gradients over DC's connecting interacting sites will be\r
9571 C        summed up outside the subrouine as for the other subroutines \r
9572 C        handling long-range interactions. The old code is commented out\r
9573 C        with "cgrad" to keep track of changes.\r
9574       do ll=1,3\r
9575 cgrad        ggg1(ll)=eel5*g_contij(ll,1)\r
9576 cgrad        ggg2(ll)=eel5*g_contij(ll,2)\r
9577         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)\r
9578         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)\r
9579 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)') \r
9580 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),\r
9581 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),\r
9582 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont\r
9583 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)') \r
9584 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),\r
9585 c     &   gradcorr5ij,\r
9586 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl\r
9587 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)\r
9588 cgrad        ghalf=0.5d0*ggg1(ll)\r
9589 cd        ghalf=0.0d0\r
9590         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)\r
9591         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)\r
9592         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)\r
9593         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)\r
9594         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij\r
9595         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij\r
9596 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)\r
9597 cgrad        ghalf=0.5d0*ggg2(ll)\r
9598 cd        ghalf=0.0d0\r
9599         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)\r
9600         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)\r
9601         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)\r
9602         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)\r
9603         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl\r
9604         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl\r
9605       enddo\r
9606 cd      goto 1112\r
9607 cgrad      do m=i+1,j-1\r
9608 cgrad        do ll=1,3\r
9609 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)\r
9610 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)\r
9611 cgrad        enddo\r
9612 cgrad      enddo\r
9613 cgrad      do m=k+1,l-1\r
9614 cgrad        do ll=1,3\r
9615 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)\r
9616 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)\r
9617 cgrad        enddo\r
9618 cgrad      enddo\r
9619 c1112  continue\r
9620 cgrad      do m=i+2,j2\r
9621 cgrad        do ll=1,3\r
9622 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)\r
9623 cgrad        enddo\r
9624 cgrad      enddo\r
9625 cgrad      do m=k+2,l2\r
9626 cgrad        do ll=1,3\r
9627 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)\r
9628 cgrad        enddo\r
9629 cgrad      enddo \r
9630 cd      do iii=1,nres-3\r
9631 cd        write (2,*) iii,g_corr5_loc(iii)\r
9632 cd      enddo\r
9633       eello5=ekont*eel5\r
9634 cd      write (2,*) 'ekont',ekont\r
9635 cd      write (iout,*) 'eello5',ekont*eel5\r
9636       return\r
9637       end\r
9638 \r
9639 \r
9640 c--------------------------------------------------------------------\r
9641 \r
9642 \r
9643       double precision function eello6(i,j,k,l,jj,kk)\r
9644       implicit real*8 (a-h,o-z)\r
9645       include 'DIMENSIONS'\r
9646       include 'COMMON.IOUNITS'\r
9647       include 'COMMON.CHAIN'\r
9648       include 'COMMON.DERIV'\r
9649       include 'COMMON.INTERACT'\r
9650       include 'COMMON.CONTACTS'\r
9651       include 'COMMON.TORSION'\r
9652       include 'COMMON.VAR'\r
9653       include 'COMMON.GEO'\r
9654       include 'COMMON.FFIELD'\r
9655       double precision ggg1(3),ggg2(3)\r
9656 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then\r
9657 cd        eello6=0.0d0\r
9658 cd        return\r
9659 cd      endif\r
9660 cd      write (iout,*)\r
9661 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,\r
9662 cd     &   ' and',k,l\r
9663       eello6_1=0.0d0\r
9664       eello6_2=0.0d0\r
9665       eello6_3=0.0d0\r
9666       eello6_4=0.0d0\r
9667       eello6_5=0.0d0\r
9668       eello6_6=0.0d0\r
9669 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,\r
9670 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)\r
9671       do iii=1,2\r
9672         do kkk=1,5\r
9673           do lll=1,3\r
9674             derx(lll,kkk,iii)=0.0d0\r
9675           enddo\r
9676         enddo\r
9677       enddo\r
9678 cd      eij=facont_hb(jj,i)\r
9679 cd      ekl=facont_hb(kk,k)\r
9680 cd      ekont=eij*ekl\r
9681 cd      eij=1.0d0\r
9682 cd      ekl=1.0d0\r
9683 cd      ekont=1.0d0\r
9684       if (l.eq.j+1) then\r
9685         eello6_1=eello6_graph1(i,j,k,l,1,.false.)\r
9686         eello6_2=eello6_graph1(j,i,l,k,2,.false.)\r
9687         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)\r
9688         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)\r
9689         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)\r
9690         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)\r
9691       else\r
9692         eello6_1=eello6_graph1(i,j,k,l,1,.false.)\r
9693         eello6_2=eello6_graph1(l,k,j,i,2,.true.)\r
9694         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)\r
9695         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)\r
9696         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then\r
9697           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)\r
9698         else\r
9699           eello6_5=0.0d0\r
9700         endif\r
9701         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)\r
9702       endif\r
9703 C If turn contributions are considered, they will be handled separately.\r
9704       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6\r
9705 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num\r
9706 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num\r
9707 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num\r
9708 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num\r
9709 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num\r
9710 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num\r
9711 cd      goto 1112\r
9712       if (j.lt.nres-1) then\r
9713         j1=j+1\r
9714         j2=j-1\r
9715       else\r
9716         j1=j-1\r
9717         j2=j-2\r
9718       endif\r
9719       if (l.lt.nres-1) then\r
9720         l1=l+1\r
9721         l2=l-1\r
9722       else\r
9723         l1=l-1\r
9724         l2=l-2\r
9725       endif\r
9726       do ll=1,3\r
9727 cgrad        ggg1(ll)=eel6*g_contij(ll,1)\r
9728 cgrad        ggg2(ll)=eel6*g_contij(ll,2)\r
9729 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)\r
9730 cgrad        ghalf=0.5d0*ggg1(ll)\r
9731 cd        ghalf=0.0d0\r
9732         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)\r
9733         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)\r
9734         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)\r
9735         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)\r
9736         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)\r
9737         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)\r
9738         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij\r
9739         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij\r
9740 cgrad        ghalf=0.5d0*ggg2(ll)\r
9741 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)\r
9742 cd        ghalf=0.0d0\r
9743         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)\r
9744         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)\r
9745         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)\r
9746         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)\r
9747         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl\r
9748         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl\r
9749       enddo\r
9750 cd      goto 1112\r
9751 cgrad      do m=i+1,j-1\r
9752 cgrad        do ll=1,3\r
9753 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)\r
9754 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)\r
9755 cgrad        enddo\r
9756 cgrad      enddo\r
9757 cgrad      do m=k+1,l-1\r
9758 cgrad        do ll=1,3\r
9759 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)\r
9760 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)\r
9761 cgrad        enddo\r
9762 cgrad      enddo\r
9763 cgrad1112  continue\r
9764 cgrad      do m=i+2,j2\r
9765 cgrad        do ll=1,3\r
9766 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)\r
9767 cgrad        enddo\r
9768 cgrad      enddo\r
9769 cgrad      do m=k+2,l2\r
9770 cgrad        do ll=1,3\r
9771 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)\r
9772 cgrad        enddo\r
9773 cgrad      enddo \r
9774 cd      do iii=1,nres-3\r
9775 cd        write (2,*) iii,g_corr6_loc(iii)\r
9776 cd      enddo\r
9777       eello6=ekont*eel6\r
9778 cd      write (2,*) 'ekont',ekont\r
9779 cd      write (iout,*) 'eello6',ekont*eel6\r
9780       return\r
9781       end\r
9782 \r
9783 \r
9784 c--------------------------------------------------------------------\r
9785 \r
9786 \r
9787       double precision function eello6_graph1(i,j,k,l,imat,swap)\r
9788       implicit real*8 (a-h,o-z)\r
9789       include 'DIMENSIONS'\r
9790       include 'COMMON.IOUNITS'\r
9791       include 'COMMON.CHAIN'\r
9792       include 'COMMON.DERIV'\r
9793       include 'COMMON.INTERACT'\r
9794       include 'COMMON.CONTACTS'\r
9795       include 'COMMON.TORSION'\r
9796       include 'COMMON.VAR'\r
9797       include 'COMMON.GEO'\r
9798       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)\r
9799       logical swap\r
9800       logical lprn\r
9801       common /kutas/ lprn\r
9802 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC\r
9803 C                                              \r
9804 C      Parallel       Antiparallel\r
9805 C                                             \r
9806 C          o             o         \r
9807 C         /l\           /j\       \r
9808 C        /   \         /   \      \r
9809 C       /| o |         | o |\     \r
9810 C     \ j|/k\|  /   \  |/k\|l /   \r
9811 C      \ /   \ /     \ /   \ /    \r
9812 C       o     o       o     o                \r
9813 C       i             i                     \r
9814 C\r
9815 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC\r
9816       itk=itortyp(itype(k))\r
9817       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))\r
9818       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))\r
9819       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))\r
9820       call transpose2(EUgC(1,1,k),auxmat(1,1))\r
9821       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))\r
9822       vv1(1)=pizda1(1,1)-pizda1(2,2)\r
9823       vv1(2)=pizda1(1,2)+pizda1(2,1)\r
9824       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))\r
9825       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)\r
9826       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)\r
9827       s5=scalar2(vv(1),Dtobr2(1,i))\r
9828 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5\r
9829       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)\r
9830       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)\r
9831      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))\r
9832      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))\r
9833      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))\r
9834      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))\r
9835      & +scalar2(vv(1),Dtobr2der(1,i)))\r
9836       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))\r
9837       vv1(1)=pizda1(1,1)-pizda1(2,2)\r
9838       vv1(2)=pizda1(1,2)+pizda1(2,1)\r
9839       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)\r
9840       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)\r
9841       if (l.eq.j+1) then\r
9842         g_corr6_loc(l-1)=g_corr6_loc(l-1)\r
9843      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))\r
9844      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))\r
9845      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))\r
9846      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))\r
9847       else\r
9848         g_corr6_loc(j-1)=g_corr6_loc(j-1)\r
9849      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))\r
9850      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))\r
9851      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))\r
9852      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))\r
9853       endif\r
9854       call transpose2(EUgCder(1,1,k),auxmat(1,1))\r
9855       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))\r
9856       vv1(1)=pizda1(1,1)-pizda1(2,2)\r
9857       vv1(2)=pizda1(1,2)+pizda1(2,1)\r
9858       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)\r
9859      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))\r
9860      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))\r
9861      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))\r
9862       do iii=1,2\r
9863         if (swap) then\r
9864           ind=3-iii\r
9865         else\r
9866           ind=iii\r
9867         endif\r
9868         do kkk=1,5\r
9869           do lll=1,3\r
9870             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))\r
9871             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))\r
9872             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))\r
9873             call transpose2(EUgC(1,1,k),auxmat(1,1))\r
9874             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),\r
9875      &        pizda1(1,1))\r
9876             vv1(1)=pizda1(1,1)-pizda1(2,2)\r
9877             vv1(2)=pizda1(1,2)+pizda1(2,1)\r
9878             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))\r
9879             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)\r
9880      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)\r
9881             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)\r
9882      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)\r
9883             s5=scalar2(vv(1),Dtobr2(1,i))\r
9884             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)\r
9885           enddo\r
9886         enddo\r
9887       enddo\r
9888       return\r
9889       end\r
9890 \r
9891 \r
9892 c--------------------------------------------------------------------\r
9893 \r
9894 \r
9895       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)\r
9896       implicit real*8 (a-h,o-z)\r
9897       include 'DIMENSIONS'\r
9898       include 'COMMON.IOUNITS'\r
9899       include 'COMMON.CHAIN'\r
9900       include 'COMMON.DERIV'\r
9901       include 'COMMON.INTERACT'\r
9902       include 'COMMON.CONTACTS'\r
9903       include 'COMMON.TORSION'\r
9904       include 'COMMON.VAR'\r
9905       include 'COMMON.GEO'\r
9906       logical swap\r
9907       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),\r
9908      & auxvec1(2),auxvec2(1),auxmat1(2,2)\r
9909       logical lprn\r
9910       common /kutas/ lprn\r
9911 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC\r
9912 C                                              \r
9913 C      Parallel       Antiparallel\r
9914 C                                             \r
9915 C          o             o         \r
9916 C     \   /l\           /j\   /   \r
9917 C      \ /   \         /   \ /    \r
9918 C       o| o |         | o |o     \r
9919 C     \ j|/k\|      \  |/k\|l     \r
9920 C      \ /   \       \ /   \      \r
9921 C       o             o                      \r
9922 C       i             i                     \r
9923 C\r
9924 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC\r
9925 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l\r
9926 C AL 7/4/01 s1 would occur in the sixth-order moment, \r
9927 C           but not in a cluster cumulant\r
9928 #ifdef MOMENT\r
9929       s1=dip(1,jj,i)*dip(1,kk,k)\r
9930 #endif\r
9931       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))\r
9932       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))\r
9933       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))\r
9934       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))\r
9935       call transpose2(EUg(1,1,k),auxmat(1,1))\r
9936       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))\r
9937       vv(1)=pizda(1,1)-pizda(2,2)\r
9938       vv(2)=pizda(1,2)+pizda(2,1)\r
9939       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))\r
9940 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4\r
9941 #ifdef MOMENT\r
9942       eello6_graph2=-(s1+s2+s3+s4)\r
9943 #else\r
9944       eello6_graph2=-(s2+s3+s4)\r
9945 #endif\r
9946 c      eello6_graph2=-s3\r
9947 C Derivatives in gamma(i-1)\r
9948       if (i.gt.1) then\r
9949 #ifdef MOMENT\r
9950         s1=dipderg(1,jj,i)*dip(1,kk,k)\r
9951 #endif\r
9952         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))\r
9953         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))\r
9954         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))\r
9955         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))\r
9956 #ifdef MOMENT\r
9957         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)\r
9958 #else\r
9959         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)\r
9960 #endif\r
9961 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3\r
9962       endif\r
9963 C Derivatives in gamma(k-1)\r
9964 #ifdef MOMENT\r
9965       s1=dip(1,jj,i)*dipderg(1,kk,k)\r
9966 #endif\r
9967       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))\r
9968       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))\r
9969       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))\r
9970       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))\r
9971       call transpose2(EUgder(1,1,k),auxmat1(1,1))\r
9972       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))\r
9973       vv(1)=pizda(1,1)-pizda(2,2)\r
9974       vv(2)=pizda(1,2)+pizda(2,1)\r
9975       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))\r
9976 #ifdef MOMENT\r
9977       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)\r
9978 #else\r
9979       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)\r
9980 #endif\r
9981 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3\r
9982 C Derivatives in gamma(j-1) or gamma(l-1)\r
9983       if (j.gt.1) then\r
9984 #ifdef MOMENT\r
9985         s1=dipderg(3,jj,i)*dip(1,kk,k) \r
9986 #endif\r
9987         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))\r
9988         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))\r
9989         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))\r
9990         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))\r
9991         vv(1)=pizda(1,1)-pizda(2,2)\r
9992         vv(2)=pizda(1,2)+pizda(2,1)\r
9993         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))\r
9994 #ifdef MOMENT\r
9995         if (swap) then\r
9996           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1\r
9997         else\r
9998           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1\r
9999         endif\r
10000 #endif\r
10001         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)\r
10002 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3\r
10003       endif\r
10004 C Derivatives in gamma(l-1) or gamma(j-1)\r
10005       if (l.gt.1) then \r
10006 #ifdef MOMENT\r
10007         s1=dip(1,jj,i)*dipderg(3,kk,k)\r
10008 #endif\r
10009         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))\r
10010         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))\r
10011         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))\r
10012         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))\r
10013         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))\r
10014         vv(1)=pizda(1,1)-pizda(2,2)\r
10015         vv(2)=pizda(1,2)+pizda(2,1)\r
10016         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))\r
10017 #ifdef MOMENT\r
10018         if (swap) then\r
10019           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1\r
10020         else\r
10021           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1\r
10022         endif\r
10023 #endif\r
10024         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)\r
10025 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3\r
10026       endif\r
10027 C Cartesian derivatives.\r
10028       if (lprn) then\r
10029         write (2,*) 'In eello6_graph2'\r
10030         do iii=1,2\r
10031           write (2,*) 'iii=',iii\r
10032           do kkk=1,5\r
10033             write (2,*) 'kkk=',kkk\r
10034             do jjj=1,2\r
10035               write (2,'(3(2f10.5),5x)') \r
10036      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)\r
10037             enddo\r
10038           enddo\r
10039         enddo\r
10040       endif\r
10041       do iii=1,2\r
10042         do kkk=1,5\r
10043           do lll=1,3\r
10044 #ifdef MOMENT\r
10045             if (iii.eq.1) then\r
10046               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)\r
10047             else\r
10048               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)\r
10049             endif\r
10050 #endif\r
10051             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),\r
10052      &        auxvec(1))\r
10053             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))\r
10054             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),\r
10055      &        auxvec(1))\r
10056             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))\r
10057             call transpose2(EUg(1,1,k),auxmat(1,1))\r
10058             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),\r
10059      &        pizda(1,1))\r
10060             vv(1)=pizda(1,1)-pizda(2,2)\r
10061             vv(2)=pizda(1,2)+pizda(2,1)\r
10062             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))\r
10063 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4\r
10064 #ifdef MOMENT\r
10065             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)\r
10066 #else\r
10067             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)\r
10068 #endif\r
10069             if (swap) then\r
10070               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3\r
10071             else\r
10072               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3\r
10073             endif\r
10074           enddo\r
10075         enddo\r
10076       enddo\r
10077       return\r
10078       end\r
10079 \r
10080 \r
10081 c--------------------------------------------------------------------\r
10082 \r
10083 \r
10084       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)\r
10085       implicit real*8 (a-h,o-z)\r
10086       include 'DIMENSIONS'\r
10087       include 'COMMON.IOUNITS'\r
10088       include 'COMMON.CHAIN'\r
10089       include 'COMMON.DERIV'\r
10090       include 'COMMON.INTERACT'\r
10091       include 'COMMON.CONTACTS'\r
10092       include 'COMMON.TORSION'\r
10093       include 'COMMON.VAR'\r
10094       include 'COMMON.GEO'\r
10095       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)\r
10096       logical swap\r
10097 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC\r
10098 C                                              \r
10099 C      Parallel       Antiparallel\r
10100 C                                             \r
10101 C          o             o         \r
10102 C         /l\   /   \   /j\       \r
10103 C        /   \ /     \ /   \      \r
10104 C       /| o |o       o| o |\     \r
10105 C       j|/k\|  /      |/k\|l /   \r
10106 C        /   \ /       /   \ /    \r
10107 C       /     o       /     o                \r
10108 C       i             i                     \r
10109 C\r
10110 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC\r
10111 C\r
10112 C 4/7/01 AL Component s1 was removed, because it pertains to the respective \r
10113 C           energy moment and not to the cluster cumulant.\r
10114       iti=itortyp(itype(i))\r
10115       if (j.lt.nres-1) then\r
10116         itj1=itortyp(itype(j+1))\r
10117       else\r
10118         itj1=ntortyp+1\r
10119       endif\r
10120       itk=itortyp(itype(k))\r
10121       itk1=itortyp(itype(k+1))\r
10122       if (l.lt.nres-1) then\r
10123         itl1=itortyp(itype(l+1))\r
10124       else\r
10125         itl1=ntortyp+1\r
10126       endif\r
10127 #ifdef MOMENT\r
10128       s1=dip(4,jj,i)*dip(4,kk,k)\r
10129 #endif\r
10130       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))\r
10131       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))\r
10132       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))\r
10133       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))\r
10134       call transpose2(EE(1,1,itk),auxmat(1,1))\r
10135       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))\r
10136       vv(1)=pizda(1,1)+pizda(2,2)\r
10137       vv(2)=pizda(2,1)-pizda(1,2)\r
10138       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))\r
10139 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,\r
10140 cd     & "sum",-(s2+s3+s4)\r
10141 #ifdef MOMENT\r
10142       eello6_graph3=-(s1+s2+s3+s4)\r
10143 #else\r
10144       eello6_graph3=-(s2+s3+s4)\r
10145 #endif\r
10146 c      eello6_graph3=-s4\r
10147 C Derivatives in gamma(k-1)\r
10148       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))\r
10149       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))\r
10150       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))\r
10151       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)\r
10152 C Derivatives in gamma(l-1)\r
10153       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))\r
10154       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))\r
10155       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))\r
10156       vv(1)=pizda(1,1)+pizda(2,2)\r
10157       vv(2)=pizda(2,1)-pizda(1,2)\r
10158       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))\r
10159       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4) \r
10160 C Cartesian derivatives.\r
10161       do iii=1,2\r
10162         do kkk=1,5\r
10163           do lll=1,3\r
10164 #ifdef MOMENT\r
10165             if (iii.eq.1) then\r
10166               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)\r
10167             else\r
10168               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)\r
10169             endif\r
10170 #endif\r
10171             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),\r
10172      &        auxvec(1))\r
10173             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))\r
10174             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),\r
10175      &        auxvec(1))\r
10176             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))\r
10177             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),\r
10178      &        pizda(1,1))\r
10179             vv(1)=pizda(1,1)+pizda(2,2)\r
10180             vv(2)=pizda(2,1)-pizda(1,2)\r
10181             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))\r
10182 #ifdef MOMENT\r
10183             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)\r
10184 #else\r
10185             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)\r
10186 #endif\r
10187             if (swap) then\r
10188               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3\r
10189             else\r
10190               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3\r
10191             endif\r
10192 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4\r
10193           enddo\r
10194         enddo\r
10195       enddo\r
10196       return\r
10197       end\r
10198 \r
10199 \r
10200 c--------------------------------------------------------------------\r
10201 \r
10202 \r
10203       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)\r
10204       implicit real*8 (a-h,o-z)\r
10205       include 'DIMENSIONS'\r
10206       include 'COMMON.IOUNITS'\r
10207       include 'COMMON.CHAIN'\r
10208       include 'COMMON.DERIV'\r
10209       include 'COMMON.INTERACT'\r
10210       include 'COMMON.CONTACTS'\r
10211       include 'COMMON.TORSION'\r
10212       include 'COMMON.VAR'\r
10213       include 'COMMON.GEO'\r
10214       include 'COMMON.FFIELD'\r
10215       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),\r
10216      & auxvec1(2),auxmat1(2,2)\r
10217       logical swap\r
10218 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC\r
10219 C                                              \r
10220 C      Parallel       Antiparallel\r
10221 C                                             \r
10222 C          o             o         \r
10223 C         /l\   /   \   /j\       \r
10224 C        /   \ /     \ /   \      \r
10225 C       /| o |o       o| o |\     \r
10226 C     \ j|/k\|      \  |/k\|l     \r
10227 C      \ /   \       \ /   \      \r
10228 C       o     \       o     \                \r
10229 C       i             i                     \r
10230 C\r
10231 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC\r
10232 C\r
10233 C 4/7/01 AL Component s1 was removed, because it pertains to the respective \r
10234 C           energy moment and not to the cluster cumulant.\r
10235 cd      write (2,*) 'eello_graph4: wturn6',wturn6\r
10236       iti=itortyp(itype(i))\r
10237       itj=itortyp(itype(j))\r
10238       if (j.lt.nres-1) then\r
10239         itj1=itortyp(itype(j+1))\r
10240       else\r
10241         itj1=ntortyp+1\r
10242       endif\r
10243       itk=itortyp(itype(k))\r
10244       if (k.lt.nres-1) then\r
10245         itk1=itortyp(itype(k+1))\r
10246       else\r
10247         itk1=ntortyp+1\r
10248       endif\r
10249       itl=itortyp(itype(l))\r
10250       if (l.lt.nres-1) then\r
10251         itl1=itortyp(itype(l+1))\r
10252       else\r
10253         itl1=ntortyp+1\r
10254       endif\r
10255 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l\r
10256 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,\r
10257 cd     & ' itl',itl,' itl1',itl1\r
10258 #ifdef MOMENT\r
10259       if (imat.eq.1) then\r
10260         s1=dip(3,jj,i)*dip(3,kk,k)\r
10261       else\r
10262         s1=dip(2,jj,j)*dip(2,kk,l)\r
10263       endif\r
10264 #endif\r
10265       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))\r
10266       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))\r
10267       if (j.eq.l+1) then\r
10268         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))\r
10269         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))\r
10270       else\r
10271         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))\r
10272         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))\r
10273       endif\r
10274       call transpose2(EUg(1,1,k),auxmat(1,1))\r
10275       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))\r
10276       vv(1)=pizda(1,1)-pizda(2,2)\r
10277       vv(2)=pizda(2,1)+pizda(1,2)\r
10278       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))\r
10279 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4\r
10280 #ifdef MOMENT\r
10281       eello6_graph4=-(s1+s2+s3+s4)\r
10282 #else\r
10283       eello6_graph4=-(s2+s3+s4)\r
10284 #endif\r
10285 C Derivatives in gamma(i-1)\r
10286       if (i.gt.1) then\r
10287 #ifdef MOMENT\r
10288         if (imat.eq.1) then\r
10289           s1=dipderg(2,jj,i)*dip(3,kk,k)\r
10290         else\r
10291           s1=dipderg(4,jj,j)*dip(2,kk,l)\r
10292         endif\r
10293 #endif\r
10294         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))\r
10295         if (j.eq.l+1) then\r
10296           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))\r
10297           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))\r
10298         else\r
10299           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))\r
10300           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))\r
10301         endif\r
10302         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))\r
10303         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then\r
10304 cd          write (2,*) 'turn6 derivatives'\r
10305 #ifdef MOMENT\r
10306           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)\r
10307 #else\r
10308           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)\r
10309 #endif\r
10310         else\r
10311 #ifdef MOMENT\r
10312           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)\r
10313 #else\r
10314           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)\r
10315 #endif\r
10316         endif\r
10317       endif\r
10318 C Derivatives in gamma(k-1)\r
10319 #ifdef MOMENT\r
10320       if (imat.eq.1) then\r
10321         s1=dip(3,jj,i)*dipderg(2,kk,k)\r
10322       else\r
10323         s1=dip(2,jj,j)*dipderg(4,kk,l)\r
10324       endif\r
10325 #endif\r
10326       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))\r
10327       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))\r
10328       if (j.eq.l+1) then\r
10329         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))\r
10330         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))\r
10331       else\r
10332         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))\r
10333         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))\r
10334       endif\r
10335       call transpose2(EUgder(1,1,k),auxmat1(1,1))\r
10336       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))\r
10337       vv(1)=pizda(1,1)-pizda(2,2)\r
10338       vv(2)=pizda(2,1)+pizda(1,2)\r
10339       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))\r
10340       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then\r
10341 #ifdef MOMENT\r
10342         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)\r
10343 #else\r
10344         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)\r
10345 #endif\r
10346       else\r
10347 #ifdef MOMENT\r
10348         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)\r
10349 #else\r
10350         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)\r
10351 #endif\r
10352       endif\r
10353 C Derivatives in gamma(j-1) or gamma(l-1)\r
10354       if (l.eq.j+1 .and. l.gt.1) then\r
10355         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))\r
10356         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))\r
10357         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))\r
10358         vv(1)=pizda(1,1)-pizda(2,2)\r
10359         vv(2)=pizda(2,1)+pizda(1,2)\r
10360         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))\r
10361         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)\r
10362       else if (j.gt.1) then\r
10363         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))\r
10364         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))\r
10365         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))\r
10366         vv(1)=pizda(1,1)-pizda(2,2)\r
10367         vv(2)=pizda(2,1)+pizda(1,2)\r
10368         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))\r
10369         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then\r
10370           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)\r
10371         else\r
10372           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)\r
10373         endif\r
10374       endif\r
10375 C Cartesian derivatives.\r
10376       do iii=1,2\r
10377         do kkk=1,5\r
10378           do lll=1,3\r
10379 #ifdef MOMENT\r
10380             if (iii.eq.1) then\r
10381               if (imat.eq.1) then\r
10382                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)\r
10383               else\r
10384                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)\r
10385               endif\r
10386             else\r
10387               if (imat.eq.1) then\r
10388                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)\r
10389               else\r
10390                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)\r
10391               endif\r
10392             endif\r
10393 #endif\r
10394             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),\r
10395      &        auxvec(1))\r
10396             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))\r
10397             if (j.eq.l+1) then\r
10398               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),\r
10399      &          b1(1,itj1),auxvec(1))\r
10400               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))\r
10401             else\r
10402               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),\r
10403      &          b1(1,itl1),auxvec(1))\r
10404               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))\r
10405             endif\r
10406             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),\r
10407      &        pizda(1,1))\r
10408             vv(1)=pizda(1,1)-pizda(2,2)\r
10409             vv(2)=pizda(2,1)+pizda(1,2)\r
10410             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))\r
10411             if (swap) then\r
10412               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then\r
10413 #ifdef MOMENT\r
10414                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)\r
10415      &             -(s1+s2+s4)\r
10416 #else\r
10417                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)\r
10418      &             -(s2+s4)\r
10419 #endif\r
10420                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3\r
10421               else\r
10422 #ifdef MOMENT\r
10423                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)\r
10424 #else\r
10425                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)\r
10426 #endif\r
10427                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3\r
10428               endif\r
10429             else\r
10430 #ifdef MOMENT\r
10431               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)\r
10432 #else\r
10433               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)\r
10434 #endif\r
10435               if (l.eq.j+1) then\r
10436                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3\r
10437               else \r
10438                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3\r
10439               endif\r
10440             endif \r
10441           enddo\r
10442         enddo\r
10443       enddo\r
10444       return\r
10445       end\r
10446 \r
10447 \r
10448 c--------------------------------------------------------------------\r
10449 \r
10450 \r
10451       double precision function eello_turn6(i,jj,kk)\r
10452       implicit real*8 (a-h,o-z)\r
10453       include 'DIMENSIONS'\r
10454       include 'COMMON.IOUNITS'\r
10455       include 'COMMON.CHAIN'\r
10456       include 'COMMON.DERIV'\r
10457       include 'COMMON.INTERACT'\r
10458       include 'COMMON.CONTACTS'\r
10459       include 'COMMON.TORSION'\r
10460       include 'COMMON.VAR'\r
10461       include 'COMMON.GEO'\r
10462       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),\r
10463      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),\r
10464      &  ggg1(3),ggg2(3)\r
10465       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),\r
10466      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)\r
10467 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to\r
10468 C           the respective energy moment and not to the cluster cumulant.\r
10469       s1=0.0d0\r
10470       s8=0.0d0\r
10471       s13=0.0d0\r
10472 c\r
10473       eello_turn6=0.0d0\r
10474       j=i+4\r
10475       k=i+1\r
10476       l=i+3\r
10477       iti=itortyp(itype(i))\r
10478       itk=itortyp(itype(k))\r
10479       itk1=itortyp(itype(k+1))\r
10480       itl=itortyp(itype(l))\r
10481       itj=itortyp(itype(j))\r
10482 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj\r
10483 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l\r
10484 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then\r
10485 cd        eello6=0.0d0\r
10486 cd        return\r
10487 cd      endif\r
10488 cd      write (iout,*)\r
10489 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,\r
10490 cd     &   ' and',k,l\r
10491 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)\r
10492       do iii=1,2\r
10493         do kkk=1,5\r
10494           do lll=1,3\r
10495             derx_turn(lll,kkk,iii)=0.0d0\r
10496           enddo\r
10497         enddo\r
10498       enddo\r
10499 cd      eij=1.0d0\r
10500 cd      ekl=1.0d0\r
10501 cd      ekont=1.0d0\r
10502       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)\r
10503 cd      eello6_5=0.0d0\r
10504 cd      write (2,*) 'eello6_5',eello6_5\r
10505 #ifdef MOMENT\r
10506       call transpose2(AEA(1,1,1),auxmat(1,1))\r
10507       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))\r
10508       ss1=scalar2(Ub2(1,i+2),b1(1,itl))\r
10509       s1 = (auxmat(1,1)+auxmat(2,2))*ss1\r
10510 #endif\r
10511       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))\r
10512       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))\r
10513       s2 = scalar2(b1(1,itk),vtemp1(1))\r
10514 #ifdef MOMENT\r
10515       call transpose2(AEA(1,1,2),atemp(1,1))\r
10516       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))\r
10517       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))\r
10518       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))\r
10519 #endif\r
10520       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))\r
10521       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))\r
10522       s12 = scalar2(Ub2(1,i+2),vtemp3(1))\r
10523 #ifdef MOMENT\r
10524       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))\r
10525       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))\r
10526       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1)) \r
10527       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1)) \r
10528       ss13 = scalar2(b1(1,itk),vtemp4(1))\r
10529       s13 = (gtemp(1,1)+gtemp(2,2))*ss13\r
10530 #endif\r
10531 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13\r
10532 c      s1=0.0d0\r
10533 c      s2=0.0d0\r
10534 c      s8=0.0d0\r
10535 c      s12=0.0d0\r
10536 c      s13=0.0d0\r
10537       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)\r
10538 C Derivatives in gamma(i+2)\r
10539       s1d =0.0d0\r
10540       s8d =0.0d0\r
10541 #ifdef MOMENT\r
10542       call transpose2(AEA(1,1,1),auxmatd(1,1))\r
10543       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))\r
10544       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1\r
10545       call transpose2(AEAderg(1,1,2),atempd(1,1))\r
10546       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))\r
10547       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))\r
10548 #endif\r
10549       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))\r
10550       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))\r
10551       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))\r
10552 c      s1d=0.0d0\r
10553 c      s2d=0.0d0\r
10554 c      s8d=0.0d0\r
10555 c      s12d=0.0d0\r
10556 c      s13d=0.0d0\r
10557       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)\r
10558 C Derivatives in gamma(i+3)\r
10559 #ifdef MOMENT\r
10560       call transpose2(AEA(1,1,1),auxmatd(1,1))\r
10561       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))\r
10562       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))\r
10563       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d\r
10564 #endif\r
10565       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))\r
10566       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))\r
10567       s2d = scalar2(b1(1,itk),vtemp1d(1))\r
10568 #ifdef MOMENT\r
10569       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))\r
10570       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))\r
10571 #endif\r
10572       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))\r
10573 #ifdef MOMENT\r
10574       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))\r
10575       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1)) \r
10576       s13d = (gtempd(1,1)+gtempd(2,2))*ss13\r
10577 #endif\r
10578 c      s1d=0.0d0\r
10579 c      s2d=0.0d0\r
10580 c      s8d=0.0d0\r
10581 c      s12d=0.0d0\r
10582 c      s13d=0.0d0\r
10583 #ifdef MOMENT\r
10584       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)\r
10585      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)\r
10586 #else\r
10587       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)\r
10588      &               -0.5d0*ekont*(s2d+s12d)\r
10589 #endif\r
10590 C Derivatives in gamma(i+4)\r
10591       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))\r
10592       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))\r
10593       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))\r
10594 #ifdef MOMENT\r
10595       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))\r
10596       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1)) \r
10597       s13d = (gtempd(1,1)+gtempd(2,2))*ss13\r
10598 #endif\r
10599 c      s1d=0.0d0\r
10600 c      s2d=0.0d0\r
10601 c      s8d=0.0d0\r
10602 C      s12d=0.0d0\r
10603 c      s13d=0.0d0\r
10604 #ifdef MOMENT\r
10605       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)\r
10606 #else\r
10607       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)\r
10608 #endif\r
10609 C Derivatives in gamma(i+5)\r
10610 #ifdef MOMENT\r
10611       call transpose2(AEAderg(1,1,1),auxmatd(1,1))\r
10612       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))\r
10613       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1\r
10614 #endif\r
10615       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))\r
10616       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))\r
10617       s2d = scalar2(b1(1,itk),vtemp1d(1))\r
10618 #ifdef MOMENT\r
10619       call transpose2(AEA(1,1,2),atempd(1,1))\r
10620       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))\r
10621       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))\r
10622 #endif\r
10623       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))\r
10624       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))\r
10625 #ifdef MOMENT\r
10626       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1)) \r
10627       ss13d = scalar2(b1(1,itk),vtemp4d(1))\r
10628       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d\r
10629 #endif\r
10630 c      s1d=0.0d0\r
10631 c      s2d=0.0d0\r
10632 c      s8d=0.0d0\r
10633 c      s12d=0.0d0\r
10634 c      s13d=0.0d0\r
10635 #ifdef MOMENT\r
10636       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)\r
10637      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)\r
10638 #else\r
10639       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)\r
10640      &               -0.5d0*ekont*(s2d+s12d)\r
10641 #endif\r
10642 C Cartesian derivatives\r
10643       do iii=1,2\r
10644         do kkk=1,5\r
10645           do lll=1,3\r
10646 #ifdef MOMENT\r
10647             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))\r
10648             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))\r
10649             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1\r
10650 #endif\r
10651             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))\r
10652             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),\r
10653      &          vtemp1d(1))\r
10654             s2d = scalar2(b1(1,itk),vtemp1d(1))\r
10655 #ifdef MOMENT\r
10656             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))\r
10657             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))\r
10658             s8d = -(atempd(1,1)+atempd(2,2))*\r
10659      &           scalar2(cc(1,1,itl),vtemp2(1))\r
10660 #endif\r
10661             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),\r
10662      &           auxmatd(1,1))\r
10663             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))\r
10664             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))\r
10665 c      s1d=0.0d0\r
10666 c      s2d=0.0d0\r
10667 c      s8d=0.0d0\r
10668 c      s12d=0.0d0\r
10669 c      s13d=0.0d0\r
10670 #ifdef MOMENT\r
10671             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) \r
10672      &        - 0.5d0*(s1d+s2d)\r
10673 #else\r
10674             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) \r
10675      &        - 0.5d0*s2d\r
10676 #endif\r
10677 #ifdef MOMENT\r
10678             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) \r
10679      &        - 0.5d0*(s8d+s12d)\r
10680 #else\r
10681             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) \r
10682      &        - 0.5d0*s12d\r
10683 #endif\r
10684           enddo\r
10685         enddo\r
10686       enddo\r
10687 #ifdef MOMENT\r
10688       do kkk=1,5\r
10689         do lll=1,3\r
10690           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),\r
10691      &      achuj_tempd(1,1))\r
10692           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))\r
10693           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1)) \r
10694           s13d=(gtempd(1,1)+gtempd(2,2))*ss13\r
10695           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d\r
10696           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),\r
10697      &      vtemp4d(1)) \r
10698           ss13d = scalar2(b1(1,itk),vtemp4d(1))\r
10699           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d\r
10700           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d\r
10701         enddo\r
10702       enddo\r
10703 #endif\r
10704 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',\r
10705 cd     &  16*eel_turn6_num\r
10706 cd      goto 1112\r
10707       if (j.lt.nres-1) then\r
10708         j1=j+1\r
10709         j2=j-1\r
10710       else\r
10711         j1=j-1\r
10712         j2=j-2\r
10713       endif\r
10714       if (l.lt.nres-1) then\r
10715         l1=l+1\r
10716         l2=l-1\r
10717       else\r
10718         l1=l-1\r
10719         l2=l-2\r
10720       endif\r
10721       do ll=1,3\r
10722 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)\r
10723 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)\r
10724 cgrad        ghalf=0.5d0*ggg1(ll)\r
10725 cd        ghalf=0.0d0\r
10726         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)\r
10727         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)\r
10728         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf\r
10729      &    +ekont*derx_turn(ll,2,1)\r
10730         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)\r
10731         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf\r
10732      &    +ekont*derx_turn(ll,4,1)\r
10733         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)\r
10734         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij\r
10735         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij\r
10736 cgrad        ghalf=0.5d0*ggg2(ll)\r
10737 cd        ghalf=0.0d0\r
10738         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf\r
10739      &    +ekont*derx_turn(ll,2,2)\r
10740         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)\r
10741         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf\r
10742      &    +ekont*derx_turn(ll,4,2)\r
10743         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)\r
10744         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl\r
10745         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl\r
10746       enddo\r
10747 cd      goto 1112\r
10748 cgrad      do m=i+1,j-1\r
10749 cgrad        do ll=1,3\r
10750 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)\r
10751 cgrad        enddo\r
10752 cgrad      enddo\r
10753 cgrad      do m=k+1,l-1\r
10754 cgrad        do ll=1,3\r
10755 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)\r
10756 cgrad        enddo\r
10757 cgrad      enddo\r
10758 cgrad1112  continue\r
10759 cgrad      do m=i+2,j2\r
10760 cgrad        do ll=1,3\r
10761 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)\r
10762 cgrad        enddo\r
10763 cgrad      enddo\r
10764 cgrad      do m=k+2,l2\r
10765 cgrad        do ll=1,3\r
10766 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)\r
10767 cgrad        enddo\r
10768 cgrad      enddo \r
10769 cd      do iii=1,nres-3\r
10770 cd        write (2,*) iii,g_corr6_loc(iii)\r
10771 cd      enddo\r
10772       eello_turn6=ekont*eel_turn6\r
10773 cd      write (2,*) 'ekont',ekont\r
10774 cd      write (2,*) 'eel_turn6',ekont*eel_turn6\r
10775       return\r
10776       end\r
10777 \r
10778 \r
10779 C--------------------------------------------------------------------\r
10780 \r
10781 \r
10782       double precision function scalar(u,v)\r
10783 !DIR$ INLINEALWAYS scalar\r
10784 #ifndef OSF\r
10785 cDEC$ ATTRIBUTES FORCEINLINE::scalar\r
10786 #endif\r
10787       implicit none\r
10788       double precision u(3),v(3)\r
10789 cd      double precision sc\r
10790 cd      integer i\r
10791 cd      sc=0.0d0\r
10792 cd      do i=1,3\r
10793 cd        sc=sc+u(i)*v(i)\r
10794 cd      enddo\r
10795 cd      scalar=sc\r
10796 \r
10797       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)\r
10798       return\r
10799       end\r
10800 \r
10801 \r
10802 crc-----------------------------------------------------------------\r
10803 \r
10804 \r
10805       SUBROUTINE MATVEC2(A1,V1,V2)\r
10806 !DIR$ INLINEALWAYS MATVEC2\r
10807 #ifndef OSF\r
10808 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2\r
10809 #endif\r
10810       implicit real*8 (a-h,o-z)\r
10811       include 'DIMENSIONS'\r
10812       DIMENSION A1(2,2),V1(2),V2(2)\r
10813 c      DO 1 I=1,2\r
10814 c        VI=0.0\r
10815 c        DO 3 K=1,2\r
10816 c    3     VI=VI+A1(I,K)*V1(K)\r
10817 c        Vaux(I)=VI\r
10818 c    1 CONTINUE\r
10819 \r
10820       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)\r
10821       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)\r
10822 \r
10823       v2(1)=vaux1\r
10824       v2(2)=vaux2\r
10825       END\r
10826 \r
10827 \r
10828 C--------------------------------------------------------------------\r
10829 \r
10830 \r
10831       SUBROUTINE MATMAT2(A1,A2,A3)\r
10832 #ifndef OSF\r
10833 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2  \r
10834 #endif\r
10835       implicit real*8 (a-h,o-z)\r
10836       include 'DIMENSIONS'\r
10837       DIMENSION A1(2,2),A2(2,2),A3(2,2)\r
10838 c      DIMENSION AI3(2,2)\r
10839 c        DO  J=1,2\r
10840 c          A3IJ=0.0\r
10841 c          DO K=1,2\r
10842 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)\r
10843 c          enddo\r
10844 c          A3(I,J)=A3IJ\r
10845 c       enddo\r
10846 c      enddo\r
10847 \r
10848       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)\r
10849       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)\r
10850       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)\r
10851       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)\r
10852 \r
10853       A3(1,1)=AI3_11\r
10854       A3(2,1)=AI3_21\r
10855       A3(1,2)=AI3_12\r
10856       A3(2,2)=AI3_22\r
10857       END\r
10858 \r
10859 \r
10860 c--------------------------------------------------------------------\r
10861 \r
10862 \r
10863       double precision function scalar2(u,v)\r
10864 !DIR$ INLINEALWAYS scalar2\r
10865       implicit none\r
10866       double precision u(2),v(2)\r
10867       double precision sc\r
10868       integer i\r
10869       scalar2=u(1)*v(1)+u(2)*v(2)\r
10870       return\r
10871       end\r
10872 \r
10873 \r
10874 C--------------------------------------------------------------------\r
10875 \r
10876 \r
10877       subroutine transpose2(a,at)\r
10878 !DIR$ INLINEALWAYS transpose2\r
10879 #ifndef OSF\r
10880 cDEC$ ATTRIBUTES FORCEINLINE::transpose2\r
10881 #endif\r
10882       implicit none\r
10883       double precision a(2,2),at(2,2)\r
10884       at(1,1)=a(1,1)\r
10885       at(1,2)=a(2,1)\r
10886       at(2,1)=a(1,2)\r
10887       at(2,2)=a(2,2)\r
10888       return\r
10889       end\r
10890 \r
10891 \r
10892 c--------------------------------------------------------------------\r
10893 \r
10894 \r
10895       subroutine transpose(n,a,at)\r
10896       implicit none\r
10897       integer n,i,j\r
10898       double precision a(n,n),at(n,n)\r
10899       do i=1,n\r
10900         do j=1,n\r
10901           at(j,i)=a(i,j)\r
10902         enddo\r
10903       enddo\r
10904       return\r
10905       end\r
10906 \r
10907 \r
10908 C--------------------------------------------------------------------\r
10909 \r
10910 \r
10911       subroutine prodmat3(a1,a2,kk,transp,prod)\r
10912 !DIR$ INLINEALWAYS prodmat3\r
10913 #ifndef OSF\r
10914 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3\r
10915 #endif\r
10916       implicit none\r
10917       integer i,j\r
10918       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)\r
10919       logical transp\r
10920 crc      double precision auxmat(2,2),prod_(2,2)\r
10921 \r
10922       if (transp) then\r
10923 crc        call transpose2(kk(1,1),auxmat(1,1))\r
10924 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))\r
10925 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1)) \r
10926         \r
10927            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)\r
10928      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)\r
10929            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)\r
10930      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)\r
10931            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)\r
10932      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)\r
10933            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)\r
10934      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)\r
10935 \r
10936       else\r
10937 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))\r
10938 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))\r
10939 \r
10940            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)\r
10941      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)\r
10942            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)\r
10943      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)\r
10944            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)\r
10945      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)\r
10946            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)\r
10947      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)\r
10948 \r
10949       endif\r
10950 c      call transpose2(a2(1,1),a2t(1,1))\r
10951 \r
10952 crc      print *,transp\r
10953 crc      print *,((prod_(i,j),i=1,2),j=1,2)\r
10954 crc      print *,((prod(i,j),i=1,2),j=1,2)\r
10955 \r
10956       return\r
10957       end\r
10958 \r