source/unres/src_MD-restraints-PM/energy_p_new_barrier.F

   1       subroutine etotal(energia)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4 #ifndef ISNAN
   5       external proc_proc
   6 #ifdef WINPGI
   7 cMS$ATTRIBUTES C ::  proc_proc
   8 #endif
   9 #endif
  10 #ifdef MPI
  11       include "mpif.h"
  12       double precision weights_(n_ene)
  13 #endif
  14       include 'COMMON.SETUP'
  15       include 'COMMON.IOUNITS'
  16       double precision energia(0:n_ene)
  17       include 'COMMON.LOCAL'
  18       include 'COMMON.FFIELD'
  19       include 'COMMON.DERIV'
  20       include 'COMMON.INTERACT'
  21       include 'COMMON.SBRIDGE'
  22       include 'COMMON.CHAIN'
  23       include 'COMMON.VAR'
  24       include 'COMMON.MD'
  25       include 'COMMON.CONTROL'
  26       include 'COMMON.TIME1'
  27 #ifdef MPI
  28 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  29 c     & " nfgtasks",nfgtasks
  30       if (nfgtasks.gt.1) then
  31 #ifdef MPI
  32         time00=MPI_Wtime()
  33 #else
  34         time00=tcpu()
  35 #endif
  36 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  37         if (fg_rank.eq.0) then
  38           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  39 c          print *,"Processor",myrank," BROADCAST iorder"
  40 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  41 C FG slaves as WEIGHTS array.
  42           weights_(1)=wsc
  43           weights_(2)=wscp
  44           weights_(3)=welec
  45           weights_(4)=wcorr
  46           weights_(5)=wcorr5
  47           weights_(6)=wcorr6
  48           weights_(7)=wel_loc
  49           weights_(8)=wturn3
  50           weights_(9)=wturn4
  51           weights_(10)=wturn6
  52           weights_(11)=wang
  53           weights_(12)=wscloc
  54           weights_(13)=wtor
  55           weights_(14)=wtor_d
  56           weights_(15)=wstrain
  57           weights_(16)=wvdwpp
  58           weights_(17)=wbond
  59           weights_(18)=scal14
  60           weights_(21)=wsccor
  61           weights_(22)=wsct
  62 C FG Master broadcasts the WEIGHTS_ array
  63           call MPI_Bcast(weights_(1),n_ene,
  64      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  65         else
  66 C FG slaves receive the WEIGHTS array
  67           call MPI_Bcast(weights(1),n_ene,
  68      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  69           wsc=weights(1)
  70           wscp=weights(2)
  71           welec=weights(3)
  72           wcorr=weights(4)
  73           wcorr5=weights(5)
  74           wcorr6=weights(6)
  75           wel_loc=weights(7)
  76           wturn3=weights(8)
  77           wturn4=weights(9)
  78           wturn6=weights(10)
  79           wang=weights(11)
  80           wscloc=weights(12)
  81           wtor=weights(13)
  82           wtor_d=weights(14)
  83           wstrain=weights(15)
  84           wvdwpp=weights(16)
  85           wbond=weights(17)
  86           scal14=weights(18)
  87           wsccor=weights(21)
  88           wsct=weights(22)
  89         endif
  90         time_Bcast=time_Bcast+MPI_Wtime()-time00
  91         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  92 c        call chainbuild_cart
  93       endif
  94 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
  95 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  96 #else
  97 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  98 c        call int_from_cart1(.false.)
  99 c      endif
 100 #endif
 101 #ifdef TIMING
 102 #ifdef MPI
 103       time00=MPI_Wtime()
 104 #else
 105       time00=tcpu()
 106 #endif
 107 #endif
 108 C
 109 C Compute the side-chain and electrostatic interaction energy
 110 C
 111       goto (101,102,103,104,105,106) ipot
 112 C Lennard-Jones potential.
 113   101 call elj(evdw,evdw_p,evdw_m)
 114 cd    print '(a)','Exit ELJ'
 115       goto 107
 116 C Lennard-Jones-Kihara potential (shifted).
 117   102 call eljk(evdw,evdw_p,evdw_m)
 118       goto 107
 119 C Berne-Pechukas potential (dilated LJ, angular dependence).
 120   103 call ebp(evdw,evdw_p,evdw_m)
 121       goto 107
 122 C Gay-Berne potential (shifted LJ, angular dependence).
 123   104 call egb(evdw,evdw_p,evdw_m)
 124       goto 107
 125 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 126   105 call egbv(evdw,evdw_p,evdw_m)
 127       goto 107
 128 C Soft-sphere potential
 129   106 call e_softsphere(evdw)
 130 C
 131 C Calculate electrostatic (H-bonding) energy of the main chain.
 132 C
 133   107 continue
 134 cmc
 135 cmc Sep-06: egb takes care of dynamic ss bonds too
 136 cmc
 137 c      if (dyn_ss) call dyn_set_nss
 138
 139 c      print *,"Processor",myrank," computed USCSC"
 140 #ifdef TIMING
 141 #ifdef MPI
 142       time01=MPI_Wtime()
 143 #else
 144       time00=tcpu()
 145 #endif
 146 #endif
 147       call vec_and_deriv
 148 #ifdef TIMING
 149 #ifdef MPI
 150       time_vec=time_vec+MPI_Wtime()-time01
 151 #else
 152       time_vec=time_vec+tcpu()-time01
 153 #endif
 154 #endif
 155 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 156       if (ipot.lt.6) then
 157 #ifdef SPLITELE
 158          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 159      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 160      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 161      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 162 #else
 163          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 164      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 165      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 166      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 167 #endif
 168             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 169          else
 170             ees=0.0d0
 171             evdw1=0.0d0
 172             eel_loc=0.0d0
 173             eello_turn3=0.0d0
 174             eello_turn4=0.0d0
 175          endif
 176       else
 177 c        write (iout,*) "Soft-spheer ELEC potential"
 178         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 179      &   eello_turn4)
 180       endif
 181 c      print *,"Processor",myrank," computed UELEC"
 182 C
 183 C Calculate excluded-volume interaction energy between peptide groups
 184 C and side chains.
 185 C
 186       if (ipot.lt.6) then
 187        if(wscp.gt.0d0) then
 188         call escp(evdw2,evdw2_14)
 189        else
 190         evdw2=0
 191         evdw2_14=0
 192        endif
 193       else
 194 c        write (iout,*) "Soft-sphere SCP potential"
 195         call escp_soft_sphere(evdw2,evdw2_14)
 196       endif
 197 c
 198 c Calculate the bond-stretching energy
 199 c
 200       call ebond(estr)
 201 C
 202 C Calculate the disulfide-bridge and other energy and the contributions
 203 C from other distance constraints.
 204 cd    print *,'Calling EHPB'
 205       call edis(ehpb)
 206 cd    print *,'EHPB exitted succesfully.'
 207 C
 208 C Calculate the virtual-bond-angle energy.
 209 C
 210       if (wang.gt.0d0) then
 211         call ebend(ebe)
 212       else
 213         ebe=0
 214       endif
 215 c      print *,"Processor",myrank," computed UB"
 216 C
 217 C Calculate the SC local energy.
 218 C
 219       call esc(escloc)
 220 c      print *,"Processor",myrank," computed USC"
 221 C
 222 C Calculate the virtual-bond torsional energy.
 223 C
 224 cd    print *,'nterm=',nterm
 225       if (wtor.gt.0) then
 226        call etor(etors,edihcnstr)
 227       else
 228        etors=0
 229        edihcnstr=0
 230       endif
 231
 232       if (constr_homology.ge.1) then
 233         call e_modeller(ehomology_constr)
 234       else
 235         ehomology_constr=0
 236       endif
 237
 238
 239 c      write(iout,*) ehomology_constr
 240 c      print *,"Processor",myrank," computed Utor"
 241 C
 242 C 6/23/01 Calculate double-torsional energy
 243 C
 244       if (wtor_d.gt.0) then
 245        call etor_d(etors_d)
 246       else
 247        etors_d=0
 248       endif
 249 c      print *,"Processor",myrank," computed Utord"
 250 C
 251 C 21/5/07 Calculate local sicdechain correlation energy
 252 C
 253       if (wsccor.gt.0.0d0) then
 254         call eback_sc_corr(esccor)
 255       else
 256         esccor=0.0d0
 257       endif
 258 c      print *,"Processor",myrank," computed Usccorr"
 259 C
 260 C 12/1/95 Multi-body terms
 261 C
 262       n_corr=0
 263       n_corr1=0
 264       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 265      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 266          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 267 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 268 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 269       else
 270          ecorr=0.0d0
 271          ecorr5=0.0d0
 272          ecorr6=0.0d0
 273          eturn6=0.0d0
 274       endif
 275       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 276          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 277 cd         write (iout,*) "multibody_hb ecorr",ecorr
 278       endif
 279 c      print *,"Processor",myrank," computed Ucorr"
 280 C
 281 C If performing constraint dynamics, call the constraint energy
 282 C  after the equilibration time
 283       if(usampl.and.totT.gt.eq_time) then
 284          call EconstrQ
 285          call Econstr_back
 286       else
 287          Uconst=0.0d0
 288          Uconst_back=0.0d0
 289       endif
 290 #ifdef TIMING
 291 #ifdef MPI
 292       time_enecalc=time_enecalc+MPI_Wtime()-time00
 293 #else
 294       time_enecalc=time_enecalc+tcpu()-time00
 295 #endif
 296 #endif
 297 c      print *,"Processor",myrank," computed Uconstr"
 298 #ifdef TIMING
 299 #ifdef MPI
 300       time00=MPI_Wtime()
 301 #else
 302       time00=tcpu()
 303 #endif
 304 #endif
 305 c
 306 C Sum the energies
 307 C
 308       energia(1)=evdw
 309 #ifdef SCP14
 310       energia(2)=evdw2-evdw2_14
 311       energia(18)=evdw2_14
 312 #else
 313       energia(2)=evdw2
 314       energia(18)=0.0d0
 315 #endif
 316 #ifdef SPLITELE
 317       energia(3)=ees
 318       energia(16)=evdw1
 319 #else
 320       energia(3)=ees+evdw1
 321       energia(16)=0.0d0
 322 #endif
 323       energia(4)=ecorr
 324       energia(5)=ecorr5
 325       energia(6)=ecorr6
 326       energia(7)=eel_loc
 327       energia(8)=eello_turn3
 328       energia(9)=eello_turn4
 329       energia(10)=eturn6
 330       energia(11)=ebe
 331       energia(12)=escloc
 332       energia(13)=etors
 333       energia(14)=etors_d
 334       energia(15)=ehpb
 335       energia(19)=edihcnstr
 336       energia(17)=estr
 337       energia(20)=Uconst+Uconst_back
 338       energia(21)=esccor
 339       energia(22)=evdw_p
 340       energia(23)=evdw_m
 341       energia(24)=ehomology_constr
 342 c      print *," Processor",myrank," calls SUM_ENERGY"
 343       call sum_energy(energia,.true.)
 344       if (dyn_ss) call dyn_set_nss
 345 c      print *," Processor",myrank," left SUM_ENERGY"
 346 #ifdef TIMING
 347 #ifdef MPI
 348       time_sumene=time_sumene+MPI_Wtime()-time00
 349 #else
 350       time_sumene=time_sumene+tcpu()-time00
 351 #endif
 352 #endif
 353       return
 354       end
 355 c-------------------------------------------------------------------------------
 356       subroutine sum_energy(energia,reduce)
 357       implicit real*8 (a-h,o-z)
 358       include 'DIMENSIONS'
 359 #ifndef ISNAN
 360       external proc_proc
 361 #ifdef WINPGI
 362 cMS$ATTRIBUTES C ::  proc_proc
 363 #endif
 364 #endif
 365 #ifdef MPI
 366       include "mpif.h"
 367 #endif
 368       include 'COMMON.SETUP'
 369       include 'COMMON.IOUNITS'
 370       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 371       include 'COMMON.FFIELD'
 372       include 'COMMON.DERIV'
 373       include 'COMMON.INTERACT'
 374       include 'COMMON.SBRIDGE'
 375       include 'COMMON.CHAIN'
 376       include 'COMMON.VAR'
 377       include 'COMMON.CONTROL'
 378       include 'COMMON.TIME1'
 379       logical reduce
 380 #ifdef MPI
 381       if (nfgtasks.gt.1 .and. reduce) then
 382 #ifdef DEBUG
 383         write (iout,*) "energies before REDUCE"
 384         call enerprint(energia)
 385         call flush(iout)
 386 #endif
 387         do i=0,n_ene
 388           enebuff(i)=energia(i)
 389         enddo
 390         time00=MPI_Wtime()
 391         call MPI_Barrier(FG_COMM,IERR)
 392         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 393         time00=MPI_Wtime()
 394         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 395      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 396 #ifdef DEBUG
 397         write (iout,*) "energies after REDUCE"
 398         call enerprint(energia)
 399         call flush(iout)
 400 #endif
 401         time_Reduce=time_Reduce+MPI_Wtime()-time00
 402       endif
 403       if (fg_rank.eq.0) then
 404 #endif
 405 #ifdef TSCSC
 406       evdw=energia(22)+wsct*energia(23)
 407 #else
 408       evdw=energia(1)
 409 #endif
 410 #ifdef SCP14
 411       evdw2=energia(2)+energia(18)
 412       evdw2_14=energia(18)
 413 #else
 414       evdw2=energia(2)
 415 #endif
 416 #ifdef SPLITELE
 417       ees=energia(3)
 418       evdw1=energia(16)
 419 #else
 420       ees=energia(3)
 421       evdw1=0.0d0
 422 #endif
 423       ecorr=energia(4)
 424       ecorr5=energia(5)
 425       ecorr6=energia(6)
 426       eel_loc=energia(7)
 427       eello_turn3=energia(8)
 428       eello_turn4=energia(9)
 429       eturn6=energia(10)
 430       ebe=energia(11)
 431       escloc=energia(12)
 432       etors=energia(13)
 433       etors_d=energia(14)
 434       ehpb=energia(15)
 435       edihcnstr=energia(19)
 436       estr=energia(17)
 437       Uconst=energia(20)
 438       esccor=energia(21)
 439       ehomology_constr=energia(24)
 440 #ifdef SPLITELE
 441       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 442      & +wang*ebe+wtor*etors+wscloc*escloc
 443      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 444      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 445      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 446      & +wbond*estr+Uconst+wsccor*esccor+ehomology_constr
 447 #else
 448       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 449      & +wang*ebe+wtor*etors+wscloc*escloc
 450      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 451      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 452      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 453      & +wbond*estr+Uconst+wsccor*esccor+ehomology_constr
 454 #endif
 455       energia(0)=etot
 456 c detecting NaNQ
 457 #ifdef ISNAN
 458 #ifdef AIX
 459       if (isnan(etot).ne.0) energia(0)=1.0d+99
 460 #else
 461       if (isnan(etot)) energia(0)=1.0d+99
 462 #endif
 463 #else
 464       i=0
 465 #ifdef WINPGI
 466       idumm=proc_proc(etot,i)
 467 #else
 468       call proc_proc(etot,i)
 469 #endif
 470       if(i.eq.1)energia(0)=1.0d+99
 471 #endif
 472 #ifdef MPI
 473       endif
 474 #endif
 475       return
 476       end
 477 c-------------------------------------------------------------------------------
 478       subroutine sum_gradient
 479       implicit real*8 (a-h,o-z)
 480       include 'DIMENSIONS'
 481 #ifndef ISNAN
 482       external proc_proc
 483 #ifdef WINPGI
 484 cMS$ATTRIBUTES C ::  proc_proc
 485 #endif
 486 #endif
 487 #ifdef MPI
 488       include 'mpif.h'
 489 #endif
 490       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 491      &  glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres)
 492       include 'COMMON.SETUP'
 493       include 'COMMON.IOUNITS'
 494       include 'COMMON.FFIELD'
 495       include 'COMMON.DERIV'
 496       include 'COMMON.INTERACT'
 497       include 'COMMON.SBRIDGE'
 498       include 'COMMON.CHAIN'
 499       include 'COMMON.VAR'
 500       include 'COMMON.CONTROL'
 501       include 'COMMON.TIME1'
 502       include 'COMMON.MAXGRAD'
 503       include 'COMMON.SCCOR'
 504 #ifdef TIMING
 505 #ifdef MPI
 506       time01=MPI_Wtime()
 507 #else
 508       time01=tcpu()
 509 #endif
 510 #endif
 511 #ifdef DEBUG
 512       write (iout,*) "sum_gradient gvdwc, gvdwx"
 513       do i=1,nres
 514         write (iout,'(i3,3f10.5,5x,3f10.5,5x,3f10.5,5x,3f10.5)')
 515      &   i,(gvdwx(j,i),j=1,3),(gvdwcT(j,i),j=1,3),(gvdwc(j,i),j=1,3),
 516      &   (gvdwcT(j,i),j=1,3)
 517       enddo
 518       call flush(iout)
 519 #endif
 520 #ifdef MPI
 521 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 522         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 523      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 524 #endif
 525 C
 526 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 527 C            in virtual-bond-vector coordinates
 528 C
 529 #ifdef DEBUG
 530 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 531 c      do i=1,nres-1
 532 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 533 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 534 c      enddo
 535 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 536 c      do i=1,nres-1
 537 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 538 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 539 c      enddo
 540       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 541       do i=1,nres
 542         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 543      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 544      &   g_corr5_loc(i)
 545       enddo
 546       call flush(iout)
 547 #endif
 548 #ifdef SPLITELE
 549 #ifdef TSCSC
 550       do i=1,nct
 551         do j=1,3
 552           gradbufc(j,i)=wsc*gvdwc(j,i)+wsc*wscT*gvdwcT(j,i)+
 553      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 554      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 555      &                wel_loc*gel_loc_long(j,i)+
 556      &                wcorr*gradcorr_long(j,i)+
 557      &                wcorr5*gradcorr5_long(j,i)+
 558      &                wcorr6*gradcorr6_long(j,i)+
 559      &                wturn6*gcorr6_turn_long(j,i)+
 560      &                wstrain*ghpbc(j,i)
 561         enddo
 562       enddo
 563 #else
 564       do i=1,nct
 565         do j=1,3
 566           gradbufc(j,i)=wsc*gvdwc(j,i)+
 567      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 568      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 569      &                wel_loc*gel_loc_long(j,i)+
 570      &                wcorr*gradcorr_long(j,i)+
 571      &                wcorr5*gradcorr5_long(j,i)+
 572      &                wcorr6*gradcorr6_long(j,i)+
 573      &                wturn6*gcorr6_turn_long(j,i)+
 574      &                wstrain*ghpbc(j,i)
 575         enddo
 576       enddo
 577 #endif
 578 #else
 579       do i=1,nct
 580         do j=1,3
 581           gradbufc(j,i)=wsc*gvdwc(j,i)+
 582      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 583      &                welec*gelc_long(j,i)+
 584      &                wbond*gradb(j,i)+
 585      &                wel_loc*gel_loc_long(j,i)+
 586      &                wcorr*gradcorr_long(j,i)+
 587      &                wcorr5*gradcorr5_long(j,i)+
 588      &                wcorr6*gradcorr6_long(j,i)+
 589      &                wturn6*gcorr6_turn_long(j,i)+
 590      &                wstrain*ghpbc(j,i)
 591         enddo
 592       enddo
 593 #endif
 594 #ifdef MPI
 595       if (nfgtasks.gt.1) then
 596       time00=MPI_Wtime()
 597 #ifdef DEBUG
 598       write (iout,*) "gradbufc before allreduce"
 599       do i=1,nres
 600         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 601       enddo
 602       call flush(iout)
 603 #endif
 604       do i=1,nres
 605         do j=1,3
 606           gradbufc_sum(j,i)=gradbufc(j,i)
 607         enddo
 608       enddo
 609 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 610 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 611 c      time_reduce=time_reduce+MPI_Wtime()-time00
 612 #ifdef DEBUG
 613 c      write (iout,*) "gradbufc_sum after allreduce"
 614 c      do i=1,nres
 615 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 616 c      enddo
 617 c      call flush(iout)
 618 #endif
 619 #ifdef TIMING
 620 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 621 #endif
 622       do i=nnt,nres
 623         do k=1,3
 624           gradbufc(k,i)=0.0d0
 625         enddo
 626       enddo
 627 #ifdef DEBUG
 628       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 629       write (iout,*) (i," jgrad_start",jgrad_start(i),
 630      &                  " jgrad_end  ",jgrad_end(i),
 631      &                  i=igrad_start,igrad_end)
 632 #endif
 633 c
 634 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 635 c do not parallelize this part.
 636 c
 637 c      do i=igrad_start,igrad_end
 638 c        do j=jgrad_start(i),jgrad_end(i)
 639 c          do k=1,3
 640 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 641 c          enddo
 642 c        enddo
 643 c      enddo
 644       do j=1,3
 645         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 646       enddo
 647       do i=nres-2,nnt,-1
 648         do j=1,3
 649           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 650         enddo
 651       enddo
 652 #ifdef DEBUG
 653       write (iout,*) "gradbufc after summing"
 654       do i=1,nres
 655         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 656       enddo
 657       call flush(iout)
 658 #endif
 659       else
 660 #endif
 661 #ifdef DEBUG
 662       write (iout,*) "gradbufc"
 663       do i=1,nres
 664         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 665       enddo
 666       call flush(iout)
 667 #endif
 668       do i=1,nres
 669         do j=1,3
 670           gradbufc_sum(j,i)=gradbufc(j,i)
 671           gradbufc(j,i)=0.0d0
 672         enddo
 673       enddo
 674       do j=1,3
 675         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 676       enddo
 677       do i=nres-2,nnt,-1
 678         do j=1,3
 679           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 680         enddo
 681       enddo
 682 c      do i=nnt,nres-1
 683 c        do k=1,3
 684 c          gradbufc(k,i)=0.0d0
 685 c        enddo
 686 c        do j=i+1,nres
 687 c          do k=1,3
 688 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 689 c          enddo
 690 c        enddo
 691 c      enddo
 692 #ifdef DEBUG
 693       write (iout,*) "gradbufc after summing"
 694       do i=1,nres
 695         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 696       enddo
 697       call flush(iout)
 698 #endif
 699 #ifdef MPI
 700       endif
 701 #endif
 702       do k=1,3
 703         gradbufc(k,nres)=0.0d0
 704       enddo
 705       do i=1,nct
 706         do j=1,3
 707 #ifdef SPLITELE
 708           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 709      &                wel_loc*gel_loc(j,i)+
 710      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 711      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 712      &                wel_loc*gel_loc_long(j,i)+
 713      &                wcorr*gradcorr_long(j,i)+
 714      &                wcorr5*gradcorr5_long(j,i)+
 715      &                wcorr6*gradcorr6_long(j,i)+
 716      &                wturn6*gcorr6_turn_long(j,i))+
 717      &                wbond*gradb(j,i)+
 718      &                wcorr*gradcorr(j,i)+
 719      &                wturn3*gcorr3_turn(j,i)+
 720      &                wturn4*gcorr4_turn(j,i)+
 721      &                wcorr5*gradcorr5(j,i)+
 722      &                wcorr6*gradcorr6(j,i)+
 723      &                wturn6*gcorr6_turn(j,i)+
 724      &                wsccor*gsccorc(j,i)
 725      &               +wscloc*gscloc(j,i)
 726 #else
 727           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 728      &                wel_loc*gel_loc(j,i)+
 729      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 730      &                welec*gelc_long(j,i)+
 731      &                wel_loc*gel_loc_long(j,i)+
 732      &                wcorr*gcorr_long(j,i)+
 733      &                wcorr5*gradcorr5_long(j,i)+
 734      &                wcorr6*gradcorr6_long(j,i)+
 735      &                wturn6*gcorr6_turn_long(j,i))+
 736      &                wbond*gradb(j,i)+
 737      &                wcorr*gradcorr(j,i)+
 738      &                wturn3*gcorr3_turn(j,i)+
 739      &                wturn4*gcorr4_turn(j,i)+
 740      &                wcorr5*gradcorr5(j,i)+
 741      &                wcorr6*gradcorr6(j,i)+
 742      &                wturn6*gcorr6_turn(j,i)+
 743      &                wsccor*gsccorc(j,i)
 744      &               +wscloc*gscloc(j,i)
 745 #endif
 746 #ifdef TSCSC
 747           gradx(j,i,icg)=wsc*gvdwx(j,i)+wsc*wscT*gvdwxT(j,i)+
 748      &                  wscp*gradx_scp(j,i)+
 749      &                  wbond*gradbx(j,i)+
 750      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 751      &                  wsccor*gsccorx(j,i)
 752      &                 +wscloc*gsclocx(j,i)
 753 #else
 754           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 755      &                  wbond*gradbx(j,i)+
 756      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 757      &                  wsccor*gsccorx(j,i)
 758      &                 +wscloc*gsclocx(j,i)
 759 #endif
 760         enddo
 761       enddo
 762 #ifdef DEBUG
 763       write (iout,*) "gloc before adding corr"
 764       do i=1,4*nres
 765         write (iout,*) i,gloc(i,icg)
 766       enddo
 767 #endif
 768       do i=1,nres-3
 769         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 770      &   +wcorr5*g_corr5_loc(i)
 771      &   +wcorr6*g_corr6_loc(i)
 772      &   +wturn4*gel_loc_turn4(i)
 773      &   +wturn3*gel_loc_turn3(i)
 774      &   +wturn6*gel_loc_turn6(i)
 775      &   +wel_loc*gel_loc_loc(i)
 776       enddo
 777 #ifdef DEBUG
 778       write (iout,*) "gloc after adding corr"
 779       do i=1,4*nres
 780         write (iout,*) i,gloc(i,icg)
 781       enddo
 782 #endif
 783 #ifdef MPI
 784       if (nfgtasks.gt.1) then
 785         do j=1,3
 786           do i=1,nres
 787             gradbufc(j,i)=gradc(j,i,icg)
 788             gradbufx(j,i)=gradx(j,i,icg)
 789           enddo
 790         enddo
 791         do i=1,4*nres
 792           glocbuf(i)=gloc(i,icg)
 793         enddo
 794 #ifdef DEBUG
 795       write (iout,*) "gloc_sc before reduce"
 796       do i=1,nres
 797        do j=1,3
 798         write (iout,*) i,j,gloc_sc(j,i,icg)
 799        enddo
 800       enddo
 801 #endif
 802         do i=1,nres
 803          do j=1,3
 804           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 805          enddo
 806         enddo
 807         time00=MPI_Wtime()
 808         call MPI_Barrier(FG_COMM,IERR)
 809         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 810         time00=MPI_Wtime()
 811         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 812      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 813         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 814      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 815         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 816      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 817         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 818      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 819         time_reduce=time_reduce+MPI_Wtime()-time00
 820 #ifdef DEBUG
 821       write (iout,*) "gloc_sc after reduce"
 822       do i=1,nres
 823        do j=1,3
 824         write (iout,*) i,j,gloc_sc(j,i,icg)
 825        enddo
 826       enddo
 827 #endif
 828 #ifdef DEBUG
 829       write (iout,*) "gloc after reduce"
 830       do i=1,4*nres
 831         write (iout,*) i,gloc(i,icg)
 832       enddo
 833 #endif
 834       endif
 835 #endif
 836       if (gnorm_check) then
 837 c
 838 c Compute the maximum elements of the gradient
 839 c
 840       gvdwc_max=0.0d0
 841       gvdwc_scp_max=0.0d0
 842       gelc_max=0.0d0
 843       gvdwpp_max=0.0d0
 844       gradb_max=0.0d0
 845       ghpbc_max=0.0d0
 846       gradcorr_max=0.0d0
 847       gel_loc_max=0.0d0
 848       gcorr3_turn_max=0.0d0
 849       gcorr4_turn_max=0.0d0
 850       gradcorr5_max=0.0d0
 851       gradcorr6_max=0.0d0
 852       gcorr6_turn_max=0.0d0
 853       gsccorc_max=0.0d0
 854       gscloc_max=0.0d0
 855       gvdwx_max=0.0d0
 856       gradx_scp_max=0.0d0
 857       ghpbx_max=0.0d0
 858       gradxorr_max=0.0d0
 859       gsccorx_max=0.0d0
 860       gsclocx_max=0.0d0
 861       do i=1,nct
 862         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 863         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 864 #ifdef TSCSC
 865         gvdwc_norm=dsqrt(scalar(gvdwcT(1,i),gvdwcT(1,i)))
 866         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 867 #endif
 868         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 869         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 870      &   gvdwc_scp_max=gvdwc_scp_norm
 871         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 872         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 873         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 874         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 875         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 876         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 877         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 878         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 879         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 880         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 881         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 882         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 883         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 884      &    gcorr3_turn(1,i)))
 885         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 886      &    gcorr3_turn_max=gcorr3_turn_norm
 887         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 888      &    gcorr4_turn(1,i)))
 889         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 890      &    gcorr4_turn_max=gcorr4_turn_norm
 891         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 892         if (gradcorr5_norm.gt.gradcorr5_max)
 893      &    gradcorr5_max=gradcorr5_norm
 894         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 895         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 896         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 897      &    gcorr6_turn(1,i)))
 898         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 899      &    gcorr6_turn_max=gcorr6_turn_norm
 900         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 901         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 902         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 903         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 904         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 905         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 906 #ifdef TSCSC
 907         gvdwx_norm=dsqrt(scalar(gvdwxT(1,i),gvdwxT(1,i)))
 908         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 909 #endif
 910         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 911         if (gradx_scp_norm.gt.gradx_scp_max)
 912      &    gradx_scp_max=gradx_scp_norm
 913         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 914         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 915         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 916         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 917         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 918         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 919         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 920         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 921       enddo
 922       if (gradout) then
 923 #ifdef AIX
 924         open(istat,file=statname,position="append")
 925 #else
 926         open(istat,file=statname,access="append")
 927 #endif
 928         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 929      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 930      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 931      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 932      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 933      &     gsccorx_max,gsclocx_max
 934         close(istat)
 935         if (gvdwc_max.gt.1.0d4) then
 936           write (iout,*) "gvdwc gvdwx gradb gradbx"
 937           do i=nnt,nct
 938             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 939      &        gradb(j,i),gradbx(j,i),j=1,3)
 940           enddo
 941           call pdbout(0.0d0,'cipiszcze',iout)
 942           call flush(iout)
 943         endif
 944       endif
 945       endif
 946 #ifdef DEBUG
 947       write (iout,*) "gradc gradx gloc"
 948       do i=1,nres
 949         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 950      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 951       enddo
 952 #endif
 953 #ifdef TIMING
 954 #ifdef MPI
 955       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 956 #else
 957       time_sumgradient=time_sumgradient+tcpu()-time01
 958 #endif
 959 #endif
 960       return
 961       end
 962 c-------------------------------------------------------------------------------
 963       subroutine rescale_weights(t_bath)
 964       implicit real*8 (a-h,o-z)
 965       include 'DIMENSIONS'
 966       include 'COMMON.IOUNITS'
 967       include 'COMMON.FFIELD'
 968       include 'COMMON.SBRIDGE'
 969       double precision kfac /2.4d0/
 970       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 971 c      facT=temp0/t_bath
 972 c      facT=2*temp0/(t_bath+temp0)
 973       if (rescale_mode.eq.0) then
 974         facT=1.0d0
 975         facT2=1.0d0
 976         facT3=1.0d0
 977         facT4=1.0d0
 978         facT5=1.0d0
 979       else if (rescale_mode.eq.1) then
 980         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 981         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 982         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 983         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 984         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 985       else if (rescale_mode.eq.2) then
 986         x=t_bath/temp0
 987         x2=x*x
 988         x3=x2*x
 989         x4=x3*x
 990         x5=x4*x
 991         facT=licznik/dlog(dexp(x)+dexp(-x))
 992         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 993         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 994         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 995         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 996       else
 997         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 998         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 999 #ifdef MPI
1000        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1001 #endif
1002        stop 555
1003       endif
1004       welec=weights(3)*fact
1005       wcorr=weights(4)*fact3
1006       wcorr5=weights(5)*fact4
1007       wcorr6=weights(6)*fact5
1008       wel_loc=weights(7)*fact2
1009       wturn3=weights(8)*fact2
1010       wturn4=weights(9)*fact3
1011       wturn6=weights(10)*fact5
1012       wtor=weights(13)*fact
1013       wtor_d=weights(14)*fact2
1014       wsccor=weights(21)*fact
1015 #ifdef TSCSC
1016 c      wsct=t_bath/temp0
1017       wsct=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
1018 #endif
1019       return
1020       end
1021 C------------------------------------------------------------------------
1022       subroutine enerprint(energia)
1023       implicit real*8 (a-h,o-z)
1024       include 'DIMENSIONS'
1025       include 'COMMON.IOUNITS'
1026       include 'COMMON.FFIELD'
1027       include 'COMMON.SBRIDGE'
1028       include 'COMMON.MD'
1029       double precision energia(0:n_ene)
1030       etot=energia(0)
1031 #ifdef TSCSC
1032       evdw=energia(22)+wsct*energia(23)
1033 #else
1034       evdw=energia(1)
1035 #endif
1036       evdw2=energia(2)
1037 #ifdef SCP14
1038       evdw2=energia(2)+energia(18)
1039 #else
1040       evdw2=energia(2)
1041 #endif
1042       ees=energia(3)
1043 #ifdef SPLITELE
1044       evdw1=energia(16)
1045 #endif
1046       ecorr=energia(4)
1047       ecorr5=energia(5)
1048       ecorr6=energia(6)
1049       eel_loc=energia(7)
1050       eello_turn3=energia(8)
1051       eello_turn4=energia(9)
1052       eello_turn6=energia(10)
1053       ebe=energia(11)
1054       escloc=energia(12)
1055       etors=energia(13)
1056       etors_d=energia(14)
1057       ehpb=energia(15)
1058       edihcnstr=energia(19)
1059       estr=energia(17)
1060       Uconst=energia(20)
1061       esccor=energia(21)
1062       ehomology_constr=energia(24)
1063
1064 #ifdef SPLITELE
1065       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1066      &  estr,wbond,ebe,wang,
1067      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1068      &  ecorr,wcorr,
1069      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1070      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
1071      &  edihcnstr,ehomology_constr, ebr*nss,
1072      &  Uconst,etot
1073    10 format (/'Virtual-chain energies:'//
1074      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
1075      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
1076      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
1077      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pE16.6,' (p-p VDW)'/
1078      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
1079      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
1080      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
1081      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
1082      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
1083      & 'EHPB=  ',1pE16.6,' WEIGHT=',1pE16.6,
1084      & ' (SS bridges & dist. cnstr.)'/
1085      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1086      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1087      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1088      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
1089      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
1090      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
1091      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
1092      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
1093      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1094      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1095      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1096      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1097      & 'ETOT=  ',1pE16.6,' (total)')
1098 #else
1099       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1100      &  estr,wbond,ebe,wang,
1101      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1102      &  ecorr,wcorr,
1103      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1104      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1105      &  ehomology_constr,ebr*nss,Uconst,etot
1106    10 format (/'Virtual-chain energies:'//
1107      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1108      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1109      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1110      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1111      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1112      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1113      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1114      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1115      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1116      & ' (SS bridges & dist. cnstr.)'/
1117      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1118      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1119      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1120      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1121      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1122      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1123      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1124      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1125      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1126      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1127      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1128      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1129      & 'ETOT=  ',1pE16.6,' (total)')
1130 #endif
1131       return
1132       end
1133 C-----------------------------------------------------------------------
1134       subroutine elj(evdw,evdw_p,evdw_m)
1135 C
1136 C This subroutine calculates the interaction energy of nonbonded side chains
1137 C assuming the LJ potential of interaction.
1138 C
1139       implicit real*8 (a-h,o-z)
1140       include 'DIMENSIONS'
1141       parameter (accur=1.0d-10)
1142       include 'COMMON.GEO'
1143       include 'COMMON.VAR'
1144       include 'COMMON.LOCAL'
1145       include 'COMMON.CHAIN'
1146       include 'COMMON.DERIV'
1147       include 'COMMON.INTERACT'
1148       include 'COMMON.TORSION'
1149       include 'COMMON.SBRIDGE'
1150       include 'COMMON.NAMES'
1151       include 'COMMON.IOUNITS'
1152       include 'COMMON.CONTACTS'
1153       dimension gg(3)
1154 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1155       evdw=0.0D0
1156       do i=iatsc_s,iatsc_e
1157         itypi=itype(i)
1158         itypi1=itype(i+1)
1159         xi=c(1,nres+i)
1160         yi=c(2,nres+i)
1161         zi=c(3,nres+i)
1162 C Change 12/1/95
1163         num_conti=0
1164 C
1165 C Calculate SC interaction energy.
1166 C
1167         do iint=1,nint_gr(i)
1168 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1169 cd   &                  'iend=',iend(i,iint)
1170           do j=istart(i,iint),iend(i,iint)
1171             itypj=itype(j)
1172             xj=c(1,nres+j)-xi
1173             yj=c(2,nres+j)-yi
1174             zj=c(3,nres+j)-zi
1175 C Change 12/1/95 to calculate four-body interactions
1176             rij=xj*xj+yj*yj+zj*zj
1177             rrij=1.0D0/rij
1178 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1179             eps0ij=eps(itypi,itypj)
1180             fac=rrij**expon2
1181             e1=fac*fac*aa(itypi,itypj)
1182             e2=fac*bb(itypi,itypj)
1183             evdwij=e1+e2
1184 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1185 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1186 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1187 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1188 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1189 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1190 #ifdef TSCSC
1191             if (bb(itypi,itypj).gt.0) then
1192                evdw_p=evdw_p+evdwij
1193             else
1194                evdw_m=evdw_m+evdwij
1195             endif
1196 #else
1197             evdw=evdw+evdwij
1198 #endif
1199 C
1200 C Calculate the components of the gradient in DC and X
1201 C
1202             fac=-rrij*(e1+evdwij)
1203             gg(1)=xj*fac
1204             gg(2)=yj*fac
1205             gg(3)=zj*fac
1206 #ifdef TSCSC
1207             if (bb(itypi,itypj).gt.0.0d0) then
1208               do k=1,3
1209                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1210                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1211                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1212                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1213               enddo
1214             else
1215               do k=1,3
1216                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1217                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1218                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1219                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1220               enddo
1221             endif
1222 #else
1223             do k=1,3
1224               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1225               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1226               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1227               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1228             enddo
1229 #endif
1230 cgrad            do k=i,j-1
1231 cgrad              do l=1,3
1232 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1233 cgrad              enddo
1234 cgrad            enddo
1235 C
1236 C 12/1/95, revised on 5/20/97
1237 C
1238 C Calculate the contact function. The ith column of the array JCONT will
1239 C contain the numbers of atoms that make contacts with the atom I (of numbers
1240 C greater than I). The arrays FACONT and GACONT will contain the values of
1241 C the contact function and its derivative.
1242 C
1243 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1244 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1245 C Uncomment next line, if the correlation interactions are contact function only
1246             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1247               rij=dsqrt(rij)
1248               sigij=sigma(itypi,itypj)
1249               r0ij=rs0(itypi,itypj)
1250 C
1251 C Check whether the SC's are not too far to make a contact.
1252 C
1253               rcut=1.5d0*r0ij
1254               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1255 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1256 C
1257               if (fcont.gt.0.0D0) then
1258 C If the SC-SC distance if close to sigma, apply spline.
1259 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1260 cAdam &             fcont1,fprimcont1)
1261 cAdam           fcont1=1.0d0-fcont1
1262 cAdam           if (fcont1.gt.0.0d0) then
1263 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1264 cAdam             fcont=fcont*fcont1
1265 cAdam           endif
1266 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1267 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1268 cga             do k=1,3
1269 cga               gg(k)=gg(k)*eps0ij
1270 cga             enddo
1271 cga             eps0ij=-evdwij*eps0ij
1272 C Uncomment for AL's type of SC correlation interactions.
1273 cadam           eps0ij=-evdwij
1274                 num_conti=num_conti+1
1275                 jcont(num_conti,i)=j
1276                 facont(num_conti,i)=fcont*eps0ij
1277                 fprimcont=eps0ij*fprimcont/rij
1278                 fcont=expon*fcont
1279 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1280 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1281 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1282 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1283                 gacont(1,num_conti,i)=-fprimcont*xj
1284                 gacont(2,num_conti,i)=-fprimcont*yj
1285                 gacont(3,num_conti,i)=-fprimcont*zj
1286 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1287 cd              write (iout,'(2i3,3f10.5)')
1288 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1289               endif
1290             endif
1291           enddo      ! j
1292         enddo        ! iint
1293 C Change 12/1/95
1294         num_cont(i)=num_conti
1295       enddo          ! i
1296       do i=1,nct
1297         do j=1,3
1298           gvdwc(j,i)=expon*gvdwc(j,i)
1299           gvdwx(j,i)=expon*gvdwx(j,i)
1300         enddo
1301       enddo
1302 C******************************************************************************
1303 C
1304 C                              N O T E !!!
1305 C
1306 C To save time, the factor of EXPON has been extracted from ALL components
1307 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1308 C use!
1309 C
1310 C******************************************************************************
1311       return
1312       end
1313 C-----------------------------------------------------------------------------
1314       subroutine eljk(evdw,evdw_p,evdw_m)
1315 C
1316 C This subroutine calculates the interaction energy of nonbonded side chains
1317 C assuming the LJK potential of interaction.
1318 C
1319       implicit real*8 (a-h,o-z)
1320       include 'DIMENSIONS'
1321       include 'COMMON.GEO'
1322       include 'COMMON.VAR'
1323       include 'COMMON.LOCAL'
1324       include 'COMMON.CHAIN'
1325       include 'COMMON.DERIV'
1326       include 'COMMON.INTERACT'
1327       include 'COMMON.IOUNITS'
1328       include 'COMMON.NAMES'
1329       dimension gg(3)
1330       logical scheck
1331 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1332       evdw=0.0D0
1333       do i=iatsc_s,iatsc_e
1334         itypi=itype(i)
1335         itypi1=itype(i+1)
1336         xi=c(1,nres+i)
1337         yi=c(2,nres+i)
1338         zi=c(3,nres+i)
1339 C
1340 C Calculate SC interaction energy.
1341 C
1342         do iint=1,nint_gr(i)
1343           do j=istart(i,iint),iend(i,iint)
1344             itypj=itype(j)
1345             xj=c(1,nres+j)-xi
1346             yj=c(2,nres+j)-yi
1347             zj=c(3,nres+j)-zi
1348             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1349             fac_augm=rrij**expon
1350             e_augm=augm(itypi,itypj)*fac_augm
1351             r_inv_ij=dsqrt(rrij)
1352             rij=1.0D0/r_inv_ij
1353             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1354             fac=r_shift_inv**expon
1355             e1=fac*fac*aa(itypi,itypj)
1356             e2=fac*bb(itypi,itypj)
1357             evdwij=e_augm+e1+e2
1358 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1359 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1360 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1361 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1362 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1363 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1364 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1365 #ifdef TSCSC
1366             if (bb(itypi,itypj).gt.0) then
1367                evdw_p=evdw_p+evdwij
1368             else
1369                evdw_m=evdw_m+evdwij
1370             endif
1371 #else
1372             evdw=evdw+evdwij
1373 #endif
1374 C
1375 C Calculate the components of the gradient in DC and X
1376 C
1377             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1378             gg(1)=xj*fac
1379             gg(2)=yj*fac
1380             gg(3)=zj*fac
1381 #ifdef TSCSC
1382             if (bb(itypi,itypj).gt.0.0d0) then
1383               do k=1,3
1384                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1385                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1386                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1387                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1388               enddo
1389             else
1390               do k=1,3
1391                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1392                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1393                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1394                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1395               enddo
1396             endif
1397 #else
1398             do k=1,3
1399               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1400               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1401               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1402               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1403             enddo
1404 #endif
1405 cgrad            do k=i,j-1
1406 cgrad              do l=1,3
1407 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1408 cgrad              enddo
1409 cgrad            enddo
1410           enddo      ! j
1411         enddo        ! iint
1412       enddo          ! i
1413       do i=1,nct
1414         do j=1,3
1415           gvdwc(j,i)=expon*gvdwc(j,i)
1416           gvdwx(j,i)=expon*gvdwx(j,i)
1417         enddo
1418       enddo
1419       return
1420       end
1421 C-----------------------------------------------------------------------------
1422       subroutine ebp(evdw,evdw_p,evdw_m)
1423 C
1424 C This subroutine calculates the interaction energy of nonbonded side chains
1425 C assuming the Berne-Pechukas potential of interaction.
1426 C
1427       implicit real*8 (a-h,o-z)
1428       include 'DIMENSIONS'
1429       include 'COMMON.GEO'
1430       include 'COMMON.VAR'
1431       include 'COMMON.LOCAL'
1432       include 'COMMON.CHAIN'
1433       include 'COMMON.DERIV'
1434       include 'COMMON.NAMES'
1435       include 'COMMON.INTERACT'
1436       include 'COMMON.IOUNITS'
1437       include 'COMMON.CALC'
1438       common /srutu/ icall
1439 c     double precision rrsave(maxdim)
1440       logical lprn
1441       evdw=0.0D0
1442 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1443       evdw=0.0D0
1444 c     if (icall.eq.0) then
1445 c       lprn=.true.
1446 c     else
1447         lprn=.false.
1448 c     endif
1449       ind=0
1450       do i=iatsc_s,iatsc_e
1451         itypi=itype(i)
1452         itypi1=itype(i+1)
1453         xi=c(1,nres+i)
1454         yi=c(2,nres+i)
1455         zi=c(3,nres+i)
1456         dxi=dc_norm(1,nres+i)
1457         dyi=dc_norm(2,nres+i)
1458         dzi=dc_norm(3,nres+i)
1459 c        dsci_inv=dsc_inv(itypi)
1460         dsci_inv=vbld_inv(i+nres)
1461 C
1462 C Calculate SC interaction energy.
1463 C
1464         do iint=1,nint_gr(i)
1465           do j=istart(i,iint),iend(i,iint)
1466             ind=ind+1
1467             itypj=itype(j)
1468 c            dscj_inv=dsc_inv(itypj)
1469             dscj_inv=vbld_inv(j+nres)
1470             chi1=chi(itypi,itypj)
1471             chi2=chi(itypj,itypi)
1472             chi12=chi1*chi2
1473             chip1=chip(itypi)
1474             chip2=chip(itypj)
1475             chip12=chip1*chip2
1476             alf1=alp(itypi)
1477             alf2=alp(itypj)
1478             alf12=0.5D0*(alf1+alf2)
1479 C For diagnostics only!!!
1480 c           chi1=0.0D0
1481 c           chi2=0.0D0
1482 c           chi12=0.0D0
1483 c           chip1=0.0D0
1484 c           chip2=0.0D0
1485 c           chip12=0.0D0
1486 c           alf1=0.0D0
1487 c           alf2=0.0D0
1488 c           alf12=0.0D0
1489             xj=c(1,nres+j)-xi
1490             yj=c(2,nres+j)-yi
1491             zj=c(3,nres+j)-zi
1492             dxj=dc_norm(1,nres+j)
1493             dyj=dc_norm(2,nres+j)
1494             dzj=dc_norm(3,nres+j)
1495             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1496 cd          if (icall.eq.0) then
1497 cd            rrsave(ind)=rrij
1498 cd          else
1499 cd            rrij=rrsave(ind)
1500 cd          endif
1501             rij=dsqrt(rrij)
1502 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1503             call sc_angular
1504 C Calculate whole angle-dependent part of epsilon and contributions
1505 C to its derivatives
1506             fac=(rrij*sigsq)**expon2
1507             e1=fac*fac*aa(itypi,itypj)
1508             e2=fac*bb(itypi,itypj)
1509             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1510             eps2der=evdwij*eps3rt
1511             eps3der=evdwij*eps2rt
1512             evdwij=evdwij*eps2rt*eps3rt
1513 #ifdef TSCSC
1514             if (bb(itypi,itypj).gt.0) then
1515                evdw_p=evdw_p+evdwij
1516             else
1517                evdw_m=evdw_m+evdwij
1518             endif
1519 #else
1520             evdw=evdw+evdwij
1521 #endif
1522             if (lprn) then
1523             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1524             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1525 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1526 cd     &        restyp(itypi),i,restyp(itypj),j,
1527 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1528 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1529 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1530 cd     &        evdwij
1531             endif
1532 C Calculate gradient components.
1533             e1=e1*eps1*eps2rt**2*eps3rt**2
1534             fac=-expon*(e1+evdwij)
1535             sigder=fac/sigsq
1536             fac=rrij*fac
1537 C Calculate radial part of the gradient
1538             gg(1)=xj*fac
1539             gg(2)=yj*fac
1540             gg(3)=zj*fac
1541 C Calculate the angular part of the gradient and sum add the contributions
1542 C to the appropriate components of the Cartesian gradient.
1543 #ifdef TSCSC
1544             if (bb(itypi,itypj).gt.0) then
1545                call sc_grad
1546             else
1547                call sc_grad_T
1548             endif
1549 #else
1550             call sc_grad
1551 #endif
1552           enddo      ! j
1553         enddo        ! iint
1554       enddo          ! i
1555 c     stop
1556       return
1557       end
1558 C-----------------------------------------------------------------------------
1559       subroutine egb(evdw,evdw_p,evdw_m)
1560 C
1561 C This subroutine calculates the interaction energy of nonbonded side chains
1562 C assuming the Gay-Berne potential of interaction.
1563 C
1564       implicit real*8 (a-h,o-z)
1565       include 'DIMENSIONS'
1566       include 'COMMON.GEO'
1567       include 'COMMON.VAR'
1568       include 'COMMON.LOCAL'
1569       include 'COMMON.CHAIN'
1570       include 'COMMON.DERIV'
1571       include 'COMMON.NAMES'
1572       include 'COMMON.INTERACT'
1573       include 'COMMON.IOUNITS'
1574       include 'COMMON.CALC'
1575       include 'COMMON.CONTROL'
1576       include 'COMMON.SBRIDGE'
1577       logical lprn
1578       evdw=0.0D0
1579 ccccc      energy_dec=.false.
1580 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1581       evdw=0.0D0
1582       evdw_p=0.0D0
1583       evdw_m=0.0D0
1584       lprn=.false.
1585 c     if (icall.eq.0) lprn=.false.
1586       ind=0
1587       do i=iatsc_s,iatsc_e
1588         itypi=itype(i)
1589         itypi1=itype(i+1)
1590         xi=c(1,nres+i)
1591         yi=c(2,nres+i)
1592         zi=c(3,nres+i)
1593         dxi=dc_norm(1,nres+i)
1594         dyi=dc_norm(2,nres+i)
1595         dzi=dc_norm(3,nres+i)
1596 c        dsci_inv=dsc_inv(itypi)
1597         dsci_inv=vbld_inv(i+nres)
1598 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1599 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1600 C
1601 C Calculate SC interaction energy.
1602 C
1603         do iint=1,nint_gr(i)
1604           do j=istart(i,iint),iend(i,iint)
1605             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1606               call dyn_ssbond_ene(i,j,evdwij)
1607               evdw=evdw+evdwij
1608               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1609      &                        'evdw',i,j,evdwij,' ss'
1610             ELSE
1611             ind=ind+1
1612             itypj=itype(j)
1613 c            dscj_inv=dsc_inv(itypj)
1614             dscj_inv=vbld_inv(j+nres)
1615 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1616 c     &       1.0d0/vbld(j+nres)
1617 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1618             sig0ij=sigma(itypi,itypj)
1619             chi1=chi(itypi,itypj)
1620             chi2=chi(itypj,itypi)
1621             chi12=chi1*chi2
1622             chip1=chip(itypi)
1623             chip2=chip(itypj)
1624             chip12=chip1*chip2
1625             alf1=alp(itypi)
1626             alf2=alp(itypj)
1627             alf12=0.5D0*(alf1+alf2)
1628 C For diagnostics only!!!
1629 c           chi1=0.0D0
1630 c           chi2=0.0D0
1631 c           chi12=0.0D0
1632 c           chip1=0.0D0
1633 c           chip2=0.0D0
1634 c           chip12=0.0D0
1635 c           alf1=0.0D0
1636 c           alf2=0.0D0
1637 c           alf12=0.0D0
1638             xj=c(1,nres+j)-xi
1639             yj=c(2,nres+j)-yi
1640             zj=c(3,nres+j)-zi
1641             dxj=dc_norm(1,nres+j)
1642             dyj=dc_norm(2,nres+j)
1643             dzj=dc_norm(3,nres+j)
1644 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1645 c            write (iout,*) "j",j," dc_norm",
1646 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1647             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1648             rij=dsqrt(rrij)
1649 C Calculate angle-dependent terms of energy and contributions to their
1650 C derivatives.
1651             call sc_angular
1652             sigsq=1.0D0/sigsq
1653             sig=sig0ij*dsqrt(sigsq)
1654             rij_shift=1.0D0/rij-sig+sig0ij
1655 c for diagnostics; uncomment
1656 c            rij_shift=1.2*sig0ij
1657 C I hate to put IF's in the loops, but here don't have another choice!!!!
1658             if (rij_shift.le.0.0D0) then
1659               evdw=1.0D20
1660 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1661 cd     &        restyp(itypi),i,restyp(itypj),j,
1662 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1663               return
1664             endif
1665             sigder=-sig*sigsq
1666 c---------------------------------------------------------------
1667             rij_shift=1.0D0/rij_shift
1668             fac=rij_shift**expon
1669             e1=fac*fac*aa(itypi,itypj)
1670             e2=fac*bb(itypi,itypj)
1671             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1672             eps2der=evdwij*eps3rt
1673             eps3der=evdwij*eps2rt
1674 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1675 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1676             evdwij=evdwij*eps2rt*eps3rt
1677 #ifdef TSCSC
1678             if (bb(itypi,itypj).gt.0) then
1679                evdw_p=evdw_p+evdwij
1680             else
1681                evdw_m=evdw_m+evdwij
1682             endif
1683 #else
1684             evdw=evdw+evdwij
1685 #endif
1686             if (lprn) then
1687             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1688             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1689             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1690      &        restyp(itypi),i,restyp(itypj),j,
1691      &        epsi,sigm,chi1,chi2,chip1,chip2,
1692      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1693      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1694      &        evdwij
1695             endif
1696
1697             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1698      &                        'evdw',i,j,evdwij
1699
1700 C Calculate gradient components.
1701             e1=e1*eps1*eps2rt**2*eps3rt**2
1702             fac=-expon*(e1+evdwij)*rij_shift
1703             sigder=fac*sigder
1704             fac=rij*fac
1705 c            fac=0.0d0
1706 C Calculate the radial part of the gradient
1707             gg(1)=xj*fac
1708             gg(2)=yj*fac
1709             gg(3)=zj*fac
1710 C Calculate angular part of the gradient.
1711 #ifdef TSCSC
1712             if (bb(itypi,itypj).gt.0) then
1713                call sc_grad
1714             else
1715                call sc_grad_T
1716             endif
1717 #else
1718             call sc_grad
1719 #endif
1720             ENDIF    ! dyn_ss
1721           enddo      ! j
1722         enddo        ! iint
1723       enddo          ! i
1724 c      write (iout,*) "Number of loop steps in EGB:",ind
1725 cccc      energy_dec=.false.
1726       return
1727       end
1728 C-----------------------------------------------------------------------------
1729       subroutine egbv(evdw,evdw_p,evdw_m)
1730 C
1731 C This subroutine calculates the interaction energy of nonbonded side chains
1732 C assuming the Gay-Berne-Vorobjev potential of interaction.
1733 C
1734       implicit real*8 (a-h,o-z)
1735       include 'DIMENSIONS'
1736       include 'COMMON.GEO'
1737       include 'COMMON.VAR'
1738       include 'COMMON.LOCAL'
1739       include 'COMMON.CHAIN'
1740       include 'COMMON.DERIV'
1741       include 'COMMON.NAMES'
1742       include 'COMMON.INTERACT'
1743       include 'COMMON.IOUNITS'
1744       include 'COMMON.CALC'
1745       common /srutu/ icall
1746       logical lprn
1747       evdw=0.0D0
1748 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1749       evdw=0.0D0
1750       lprn=.false.
1751 c     if (icall.eq.0) lprn=.true.
1752       ind=0
1753       do i=iatsc_s,iatsc_e
1754         itypi=itype(i)
1755         itypi1=itype(i+1)
1756         xi=c(1,nres+i)
1757         yi=c(2,nres+i)
1758         zi=c(3,nres+i)
1759         dxi=dc_norm(1,nres+i)
1760         dyi=dc_norm(2,nres+i)
1761         dzi=dc_norm(3,nres+i)
1762 c        dsci_inv=dsc_inv(itypi)
1763         dsci_inv=vbld_inv(i+nres)
1764 C
1765 C Calculate SC interaction energy.
1766 C
1767         do iint=1,nint_gr(i)
1768           do j=istart(i,iint),iend(i,iint)
1769             ind=ind+1
1770             itypj=itype(j)
1771 c            dscj_inv=dsc_inv(itypj)
1772             dscj_inv=vbld_inv(j+nres)
1773             sig0ij=sigma(itypi,itypj)
1774             r0ij=r0(itypi,itypj)
1775             chi1=chi(itypi,itypj)
1776             chi2=chi(itypj,itypi)
1777             chi12=chi1*chi2
1778             chip1=chip(itypi)
1779             chip2=chip(itypj)
1780             chip12=chip1*chip2
1781             alf1=alp(itypi)
1782             alf2=alp(itypj)
1783             alf12=0.5D0*(alf1+alf2)
1784 C For diagnostics only!!!
1785 c           chi1=0.0D0
1786 c           chi2=0.0D0
1787 c           chi12=0.0D0
1788 c           chip1=0.0D0
1789 c           chip2=0.0D0
1790 c           chip12=0.0D0
1791 c           alf1=0.0D0
1792 c           alf2=0.0D0
1793 c           alf12=0.0D0
1794             xj=c(1,nres+j)-xi
1795             yj=c(2,nres+j)-yi
1796             zj=c(3,nres+j)-zi
1797             dxj=dc_norm(1,nres+j)
1798             dyj=dc_norm(2,nres+j)
1799             dzj=dc_norm(3,nres+j)
1800             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1801             rij=dsqrt(rrij)
1802 C Calculate angle-dependent terms of energy and contributions to their
1803 C derivatives.
1804             call sc_angular
1805             sigsq=1.0D0/sigsq
1806             sig=sig0ij*dsqrt(sigsq)
1807             rij_shift=1.0D0/rij-sig+r0ij
1808 C I hate to put IF's in the loops, but here don't have another choice!!!!
1809             if (rij_shift.le.0.0D0) then
1810               evdw=1.0D20
1811               return
1812             endif
1813             sigder=-sig*sigsq
1814 c---------------------------------------------------------------
1815             rij_shift=1.0D0/rij_shift
1816             fac=rij_shift**expon
1817             e1=fac*fac*aa(itypi,itypj)
1818             e2=fac*bb(itypi,itypj)
1819             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1820             eps2der=evdwij*eps3rt
1821             eps3der=evdwij*eps2rt
1822             fac_augm=rrij**expon
1823             e_augm=augm(itypi,itypj)*fac_augm
1824             evdwij=evdwij*eps2rt*eps3rt
1825 #ifdef TSCSC
1826             if (bb(itypi,itypj).gt.0) then
1827                evdw_p=evdw_p+evdwij+e_augm
1828             else
1829                evdw_m=evdw_m+evdwij+e_augm
1830             endif
1831 #else
1832             evdw=evdw+evdwij+e_augm
1833 #endif
1834             if (lprn) then
1835             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1836             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1837             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1838      &        restyp(itypi),i,restyp(itypj),j,
1839      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1840      &        chi1,chi2,chip1,chip2,
1841      &        eps1,eps2rt**2,eps3rt**2,
1842      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1843      &        evdwij+e_augm
1844             endif
1845 C Calculate gradient components.
1846             e1=e1*eps1*eps2rt**2*eps3rt**2
1847             fac=-expon*(e1+evdwij)*rij_shift
1848             sigder=fac*sigder
1849             fac=rij*fac-2*expon*rrij*e_augm
1850 C Calculate the radial part of the gradient
1851             gg(1)=xj*fac
1852             gg(2)=yj*fac
1853             gg(3)=zj*fac
1854 C Calculate angular part of the gradient.
1855 #ifdef TSCSC
1856             if (bb(itypi,itypj).gt.0) then
1857                call sc_grad
1858             else
1859                call sc_grad_T
1860             endif
1861 #else
1862             call sc_grad
1863 #endif
1864           enddo      ! j
1865         enddo        ! iint
1866       enddo          ! i
1867       end
1868 C-----------------------------------------------------------------------------
1869       subroutine sc_angular
1870 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1871 C om12. Called by ebp, egb, and egbv.
1872       implicit none
1873       include 'COMMON.CALC'
1874       include 'COMMON.IOUNITS'
1875       erij(1)=xj*rij
1876       erij(2)=yj*rij
1877       erij(3)=zj*rij
1878       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1879       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1880       om12=dxi*dxj+dyi*dyj+dzi*dzj
1881       chiom12=chi12*om12
1882 C Calculate eps1(om12) and its derivative in om12
1883       faceps1=1.0D0-om12*chiom12
1884       faceps1_inv=1.0D0/faceps1
1885       eps1=dsqrt(faceps1_inv)
1886 C Following variable is eps1*deps1/dom12
1887       eps1_om12=faceps1_inv*chiom12
1888 c diagnostics only
1889 c      faceps1_inv=om12
1890 c      eps1=om12
1891 c      eps1_om12=1.0d0
1892 c      write (iout,*) "om12",om12," eps1",eps1
1893 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1894 C and om12.
1895       om1om2=om1*om2
1896       chiom1=chi1*om1
1897       chiom2=chi2*om2
1898       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1899       sigsq=1.0D0-facsig*faceps1_inv
1900       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1901       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1902       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1903 c diagnostics only
1904 c      sigsq=1.0d0
1905 c      sigsq_om1=0.0d0
1906 c      sigsq_om2=0.0d0
1907 c      sigsq_om12=0.0d0
1908 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1909 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1910 c     &    " eps1",eps1
1911 C Calculate eps2 and its derivatives in om1, om2, and om12.
1912       chipom1=chip1*om1
1913       chipom2=chip2*om2
1914       chipom12=chip12*om12
1915       facp=1.0D0-om12*chipom12
1916       facp_inv=1.0D0/facp
1917       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1918 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1919 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1920 C Following variable is the square root of eps2
1921       eps2rt=1.0D0-facp1*facp_inv
1922 C Following three variables are the derivatives of the square root of eps
1923 C in om1, om2, and om12.
1924       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1925       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1926       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1927 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1928       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1929 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1930 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1931 c     &  " eps2rt_om12",eps2rt_om12
1932 C Calculate whole angle-dependent part of epsilon and contributions
1933 C to its derivatives
1934       return
1935       end
1936
1937 C----------------------------------------------------------------------------
1938       subroutine sc_grad_T
1939       implicit real*8 (a-h,o-z)
1940       include 'DIMENSIONS'
1941       include 'COMMON.CHAIN'
1942       include 'COMMON.DERIV'
1943       include 'COMMON.CALC'
1944       include 'COMMON.IOUNITS'
1945       double precision dcosom1(3),dcosom2(3)
1946       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1947       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1948       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1949      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1950 c diagnostics only
1951 c      eom1=0.0d0
1952 c      eom2=0.0d0
1953 c      eom12=evdwij*eps1_om12
1954 c end diagnostics
1955 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1956 c     &  " sigder",sigder
1957 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1958 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1959       do k=1,3
1960         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1961         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1962       enddo
1963       do k=1,3
1964         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1965       enddo
1966 c      write (iout,*) "gg",(gg(k),k=1,3)
1967       do k=1,3
1968         gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1969      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1970      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1971         gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1972      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1973      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1974 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1975 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1976 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1977 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1978       enddo
1979 C
1980 C Calculate the components of the gradient in DC and X
1981 C
1982 cgrad      do k=i,j-1
1983 cgrad        do l=1,3
1984 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1985 cgrad        enddo
1986 cgrad      enddo
1987       do l=1,3
1988         gvdwcT(l,i)=gvdwcT(l,i)-gg(l)
1989         gvdwcT(l,j)=gvdwcT(l,j)+gg(l)
1990       enddo
1991       return
1992       end
1993
1994 C----------------------------------------------------------------------------
1995       subroutine sc_grad
1996       implicit real*8 (a-h,o-z)
1997       include 'DIMENSIONS'
1998       include 'COMMON.CHAIN'
1999       include 'COMMON.DERIV'
2000       include 'COMMON.CALC'
2001       include 'COMMON.IOUNITS'
2002       double precision dcosom1(3),dcosom2(3)
2003       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2004       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2005       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2006      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2007 c diagnostics only
2008 c      eom1=0.0d0
2009 c      eom2=0.0d0
2010 c      eom12=evdwij*eps1_om12
2011 c end diagnostics
2012 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2013 c     &  " sigder",sigder
2014 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2015 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2016       do k=1,3
2017         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2018         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2019       enddo
2020       do k=1,3
2021         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
2022       enddo
2023 c      write (iout,*) "gg",(gg(k),k=1,3)
2024       do k=1,3
2025         gvdwx(k,i)=gvdwx(k,i)-gg(k)
2026      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2027      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2028         gvdwx(k,j)=gvdwx(k,j)+gg(k)
2029      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2030      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2031 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2032 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2033 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2034 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2035       enddo
2036 C
2037 C Calculate the components of the gradient in DC and X
2038 C
2039 cgrad      do k=i,j-1
2040 cgrad        do l=1,3
2041 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2042 cgrad        enddo
2043 cgrad      enddo
2044       do l=1,3
2045         gvdwc(l,i)=gvdwc(l,i)-gg(l)
2046         gvdwc(l,j)=gvdwc(l,j)+gg(l)
2047       enddo
2048       return
2049       end
2050 C-----------------------------------------------------------------------
2051       subroutine e_softsphere(evdw)
2052 C
2053 C This subroutine calculates the interaction energy of nonbonded side chains
2054 C assuming the LJ potential of interaction.
2055 C
2056       implicit real*8 (a-h,o-z)
2057       include 'DIMENSIONS'
2058       parameter (accur=1.0d-10)
2059       include 'COMMON.GEO'
2060       include 'COMMON.VAR'
2061       include 'COMMON.LOCAL'
2062       include 'COMMON.CHAIN'
2063       include 'COMMON.DERIV'
2064       include 'COMMON.INTERACT'
2065       include 'COMMON.TORSION'
2066       include 'COMMON.SBRIDGE'
2067       include 'COMMON.NAMES'
2068       include 'COMMON.IOUNITS'
2069       include 'COMMON.CONTACTS'
2070       dimension gg(3)
2071 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2072       evdw=0.0D0
2073       do i=iatsc_s,iatsc_e
2074         itypi=itype(i)
2075         itypi1=itype(i+1)
2076         xi=c(1,nres+i)
2077         yi=c(2,nres+i)
2078         zi=c(3,nres+i)
2079 C
2080 C Calculate SC interaction energy.
2081 C
2082         do iint=1,nint_gr(i)
2083 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2084 cd   &                  'iend=',iend(i,iint)
2085           do j=istart(i,iint),iend(i,iint)
2086             itypj=itype(j)
2087             xj=c(1,nres+j)-xi
2088             yj=c(2,nres+j)-yi
2089             zj=c(3,nres+j)-zi
2090             rij=xj*xj+yj*yj+zj*zj
2091 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2092             r0ij=r0(itypi,itypj)
2093             r0ijsq=r0ij*r0ij
2094 c            print *,i,j,r0ij,dsqrt(rij)
2095             if (rij.lt.r0ijsq) then
2096               evdwij=0.25d0*(rij-r0ijsq)**2
2097               fac=rij-r0ijsq
2098             else
2099               evdwij=0.0d0
2100               fac=0.0d0
2101             endif
2102             evdw=evdw+evdwij
2103 C
2104 C Calculate the components of the gradient in DC and X
2105 C
2106             gg(1)=xj*fac
2107             gg(2)=yj*fac
2108             gg(3)=zj*fac
2109             do k=1,3
2110               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2111               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2112               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2113               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2114             enddo
2115 cgrad            do k=i,j-1
2116 cgrad              do l=1,3
2117 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2118 cgrad              enddo
2119 cgrad            enddo
2120           enddo ! j
2121         enddo ! iint
2122       enddo ! i
2123       return
2124       end
2125 C--------------------------------------------------------------------------
2126       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2127      &              eello_turn4)
2128 C
2129 C Soft-sphere potential of p-p interaction
2130 C
2131       implicit real*8 (a-h,o-z)
2132       include 'DIMENSIONS'
2133       include 'COMMON.CONTROL'
2134       include 'COMMON.IOUNITS'
2135       include 'COMMON.GEO'
2136       include 'COMMON.VAR'
2137       include 'COMMON.LOCAL'
2138       include 'COMMON.CHAIN'
2139       include 'COMMON.DERIV'
2140       include 'COMMON.INTERACT'
2141       include 'COMMON.CONTACTS'
2142       include 'COMMON.TORSION'
2143       include 'COMMON.VECTORS'
2144       include 'COMMON.FFIELD'
2145       dimension ggg(3)
2146 cd      write(iout,*) 'In EELEC_soft_sphere'
2147       ees=0.0D0
2148       evdw1=0.0D0
2149       eel_loc=0.0d0
2150       eello_turn3=0.0d0
2151       eello_turn4=0.0d0
2152       ind=0
2153       do i=iatel_s,iatel_e
2154         dxi=dc(1,i)
2155         dyi=dc(2,i)
2156         dzi=dc(3,i)
2157         xmedi=c(1,i)+0.5d0*dxi
2158         ymedi=c(2,i)+0.5d0*dyi
2159         zmedi=c(3,i)+0.5d0*dzi
2160         num_conti=0
2161 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2162         do j=ielstart(i),ielend(i)
2163           ind=ind+1
2164           iteli=itel(i)
2165           itelj=itel(j)
2166           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2167           r0ij=rpp(iteli,itelj)
2168           r0ijsq=r0ij*r0ij
2169           dxj=dc(1,j)
2170           dyj=dc(2,j)
2171           dzj=dc(3,j)
2172           xj=c(1,j)+0.5D0*dxj-xmedi
2173           yj=c(2,j)+0.5D0*dyj-ymedi
2174           zj=c(3,j)+0.5D0*dzj-zmedi
2175           rij=xj*xj+yj*yj+zj*zj
2176           if (rij.lt.r0ijsq) then
2177             evdw1ij=0.25d0*(rij-r0ijsq)**2
2178             fac=rij-r0ijsq
2179           else
2180             evdw1ij=0.0d0
2181             fac=0.0d0
2182           endif
2183           evdw1=evdw1+evdw1ij
2184 C
2185 C Calculate contributions to the Cartesian gradient.
2186 C
2187           ggg(1)=fac*xj
2188           ggg(2)=fac*yj
2189           ggg(3)=fac*zj
2190           do k=1,3
2191             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2192             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2193           enddo
2194 *
2195 * Loop over residues i+1 thru j-1.
2196 *
2197 cgrad          do k=i+1,j-1
2198 cgrad            do l=1,3
2199 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2200 cgrad            enddo
2201 cgrad          enddo
2202         enddo ! j
2203       enddo   ! i
2204 cgrad      do i=nnt,nct-1
2205 cgrad        do k=1,3
2206 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2207 cgrad        enddo
2208 cgrad        do j=i+1,nct-1
2209 cgrad          do k=1,3
2210 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2211 cgrad          enddo
2212 cgrad        enddo
2213 cgrad      enddo
2214       return
2215       end
2216 c------------------------------------------------------------------------------
2217       subroutine vec_and_deriv
2218       implicit real*8 (a-h,o-z)
2219       include 'DIMENSIONS'
2220 #ifdef MPI
2221       include 'mpif.h'
2222 #endif
2223       include 'COMMON.IOUNITS'
2224       include 'COMMON.GEO'
2225       include 'COMMON.VAR'
2226       include 'COMMON.LOCAL'
2227       include 'COMMON.CHAIN'
2228       include 'COMMON.VECTORS'
2229       include 'COMMON.SETUP'
2230       include 'COMMON.TIME1'
2231       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2232 C Compute the local reference systems. For reference system (i), the
2233 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2234 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2235 #ifdef PARVEC
2236       do i=ivec_start,ivec_end
2237 #else
2238       do i=1,nres-1
2239 #endif
2240           if (i.eq.nres-1) then
2241 C Case of the last full residue
2242 C Compute the Z-axis
2243             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2244             costh=dcos(pi-theta(nres))
2245             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2246             do k=1,3
2247               uz(k,i)=fac*uz(k,i)
2248             enddo
2249 C Compute the derivatives of uz
2250             uzder(1,1,1)= 0.0d0
2251             uzder(2,1,1)=-dc_norm(3,i-1)
2252             uzder(3,1,1)= dc_norm(2,i-1)
2253             uzder(1,2,1)= dc_norm(3,i-1)
2254             uzder(2,2,1)= 0.0d0
2255             uzder(3,2,1)=-dc_norm(1,i-1)
2256             uzder(1,3,1)=-dc_norm(2,i-1)
2257             uzder(2,3,1)= dc_norm(1,i-1)
2258             uzder(3,3,1)= 0.0d0
2259             uzder(1,1,2)= 0.0d0
2260             uzder(2,1,2)= dc_norm(3,i)
2261             uzder(3,1,2)=-dc_norm(2,i)
2262             uzder(1,2,2)=-dc_norm(3,i)
2263             uzder(2,2,2)= 0.0d0
2264             uzder(3,2,2)= dc_norm(1,i)
2265             uzder(1,3,2)= dc_norm(2,i)
2266             uzder(2,3,2)=-dc_norm(1,i)
2267             uzder(3,3,2)= 0.0d0
2268 C Compute the Y-axis
2269             facy=fac
2270             do k=1,3
2271               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2272             enddo
2273 C Compute the derivatives of uy
2274             do j=1,3
2275               do k=1,3
2276                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2277      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2278                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2279               enddo
2280               uyder(j,j,1)=uyder(j,j,1)-costh
2281               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2282             enddo
2283             do j=1,2
2284               do k=1,3
2285                 do l=1,3
2286                   uygrad(l,k,j,i)=uyder(l,k,j)
2287                   uzgrad(l,k,j,i)=uzder(l,k,j)
2288                 enddo
2289               enddo
2290             enddo
2291             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2292             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2293             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2294             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2295           else
2296 C Other residues
2297 C Compute the Z-axis
2298             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2299             costh=dcos(pi-theta(i+2))
2300             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2301             do k=1,3
2302               uz(k,i)=fac*uz(k,i)
2303             enddo
2304 C Compute the derivatives of uz
2305             uzder(1,1,1)= 0.0d0
2306             uzder(2,1,1)=-dc_norm(3,i+1)
2307             uzder(3,1,1)= dc_norm(2,i+1)
2308             uzder(1,2,1)= dc_norm(3,i+1)
2309             uzder(2,2,1)= 0.0d0
2310             uzder(3,2,1)=-dc_norm(1,i+1)
2311             uzder(1,3,1)=-dc_norm(2,i+1)
2312             uzder(2,3,1)= dc_norm(1,i+1)
2313             uzder(3,3,1)= 0.0d0
2314             uzder(1,1,2)= 0.0d0
2315             uzder(2,1,2)= dc_norm(3,i)
2316             uzder(3,1,2)=-dc_norm(2,i)
2317             uzder(1,2,2)=-dc_norm(3,i)
2318             uzder(2,2,2)= 0.0d0
2319             uzder(3,2,2)= dc_norm(1,i)
2320             uzder(1,3,2)= dc_norm(2,i)
2321             uzder(2,3,2)=-dc_norm(1,i)
2322             uzder(3,3,2)= 0.0d0
2323 C Compute the Y-axis
2324             facy=fac
2325             do k=1,3
2326               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2327             enddo
2328 C Compute the derivatives of uy
2329             do j=1,3
2330               do k=1,3
2331                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2332      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2333                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2334               enddo
2335               uyder(j,j,1)=uyder(j,j,1)-costh
2336               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2337             enddo
2338             do j=1,2
2339               do k=1,3
2340                 do l=1,3
2341                   uygrad(l,k,j,i)=uyder(l,k,j)
2342                   uzgrad(l,k,j,i)=uzder(l,k,j)
2343                 enddo
2344               enddo
2345             enddo
2346             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2347             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2348             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2349             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2350           endif
2351       enddo
2352       do i=1,nres-1
2353         vbld_inv_temp(1)=vbld_inv(i+1)
2354         if (i.lt.nres-1) then
2355           vbld_inv_temp(2)=vbld_inv(i+2)
2356           else
2357           vbld_inv_temp(2)=vbld_inv(i)
2358           endif
2359         do j=1,2
2360           do k=1,3
2361             do l=1,3
2362               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2363               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2364             enddo
2365           enddo
2366         enddo
2367       enddo
2368 #if defined(PARVEC) && defined(MPI)
2369       if (nfgtasks1.gt.1) then
2370         time00=MPI_Wtime()
2371 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2372 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2373 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2374         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2375      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2376      &   FG_COMM1,IERR)
2377         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2378      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2379      &   FG_COMM1,IERR)
2380         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2381      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2382      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2383         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2384      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2385      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2386         time_gather=time_gather+MPI_Wtime()-time00
2387       endif
2388 c      if (fg_rank.eq.0) then
2389 c        write (iout,*) "Arrays UY and UZ"
2390 c        do i=1,nres-1
2391 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2392 c     &     (uz(k,i),k=1,3)
2393 c        enddo
2394 c      endif
2395 #endif
2396       return
2397       end
2398 C-----------------------------------------------------------------------------
2399       subroutine check_vecgrad
2400       implicit real*8 (a-h,o-z)
2401       include 'DIMENSIONS'
2402       include 'COMMON.IOUNITS'
2403       include 'COMMON.GEO'
2404       include 'COMMON.VAR'
2405       include 'COMMON.LOCAL'
2406       include 'COMMON.CHAIN'
2407       include 'COMMON.VECTORS'
2408       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2409       dimension uyt(3,maxres),uzt(3,maxres)
2410       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2411       double precision delta /1.0d-7/
2412       call vec_and_deriv
2413 cd      do i=1,nres
2414 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2415 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2416 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2417 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2418 cd     &     (dc_norm(if90,i),if90=1,3)
2419 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2420 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2421 cd          write(iout,'(a)')
2422 cd      enddo
2423       do i=1,nres
2424         do j=1,2
2425           do k=1,3
2426             do l=1,3
2427               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2428               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2429             enddo
2430           enddo
2431         enddo
2432       enddo
2433       call vec_and_deriv
2434       do i=1,nres
2435         do j=1,3
2436           uyt(j,i)=uy(j,i)
2437           uzt(j,i)=uz(j,i)
2438         enddo
2439       enddo
2440       do i=1,nres
2441 cd        write (iout,*) 'i=',i
2442         do k=1,3
2443           erij(k)=dc_norm(k,i)
2444         enddo
2445         do j=1,3
2446           do k=1,3
2447             dc_norm(k,i)=erij(k)
2448           enddo
2449           dc_norm(j,i)=dc_norm(j,i)+delta
2450 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2451 c          do k=1,3
2452 c            dc_norm(k,i)=dc_norm(k,i)/fac
2453 c          enddo
2454 c          write (iout,*) (dc_norm(k,i),k=1,3)
2455 c          write (iout,*) (erij(k),k=1,3)
2456           call vec_and_deriv
2457           do k=1,3
2458             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2459             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2460             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2461             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2462           enddo
2463 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2464 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2465 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2466         enddo
2467         do k=1,3
2468           dc_norm(k,i)=erij(k)
2469         enddo
2470 cd        do k=1,3
2471 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2472 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2473 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2474 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2475 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2476 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2477 cd          write (iout,'(a)')
2478 cd        enddo
2479       enddo
2480       return
2481       end
2482 C--------------------------------------------------------------------------
2483       subroutine set_matrices
2484       implicit real*8 (a-h,o-z)
2485       include 'DIMENSIONS'
2486 #ifdef MPI
2487       include "mpif.h"
2488       include "COMMON.SETUP"
2489       integer IERR
2490       integer status(MPI_STATUS_SIZE)
2491 #endif
2492       include 'COMMON.IOUNITS'
2493       include 'COMMON.GEO'
2494       include 'COMMON.VAR'
2495       include 'COMMON.LOCAL'
2496       include 'COMMON.CHAIN'
2497       include 'COMMON.DERIV'
2498       include 'COMMON.INTERACT'
2499       include 'COMMON.CONTACTS'
2500       include 'COMMON.TORSION'
2501       include 'COMMON.VECTORS'
2502       include 'COMMON.FFIELD'
2503       double precision auxvec(2),auxmat(2,2)
2504 C
2505 C Compute the virtual-bond-torsional-angle dependent quantities needed
2506 C to calculate the el-loc multibody terms of various order.
2507 C
2508 #ifdef PARMAT
2509       do i=ivec_start+2,ivec_end+2
2510 #else
2511       do i=3,nres+1
2512 #endif
2513         if (i .lt. nres+1) then
2514           sin1=dsin(phi(i))
2515           cos1=dcos(phi(i))
2516           sintab(i-2)=sin1
2517           costab(i-2)=cos1
2518           obrot(1,i-2)=cos1
2519           obrot(2,i-2)=sin1
2520           sin2=dsin(2*phi(i))
2521           cos2=dcos(2*phi(i))
2522           sintab2(i-2)=sin2
2523           costab2(i-2)=cos2
2524           obrot2(1,i-2)=cos2
2525           obrot2(2,i-2)=sin2
2526           Ug(1,1,i-2)=-cos1
2527           Ug(1,2,i-2)=-sin1
2528           Ug(2,1,i-2)=-sin1
2529           Ug(2,2,i-2)= cos1
2530           Ug2(1,1,i-2)=-cos2
2531           Ug2(1,2,i-2)=-sin2
2532           Ug2(2,1,i-2)=-sin2
2533           Ug2(2,2,i-2)= cos2
2534         else
2535           costab(i-2)=1.0d0
2536           sintab(i-2)=0.0d0
2537           obrot(1,i-2)=1.0d0
2538           obrot(2,i-2)=0.0d0
2539           obrot2(1,i-2)=0.0d0
2540           obrot2(2,i-2)=0.0d0
2541           Ug(1,1,i-2)=1.0d0
2542           Ug(1,2,i-2)=0.0d0
2543           Ug(2,1,i-2)=0.0d0
2544           Ug(2,2,i-2)=1.0d0
2545           Ug2(1,1,i-2)=0.0d0
2546           Ug2(1,2,i-2)=0.0d0
2547           Ug2(2,1,i-2)=0.0d0
2548           Ug2(2,2,i-2)=0.0d0
2549         endif
2550         if (i .gt. 3 .and. i .lt. nres+1) then
2551           obrot_der(1,i-2)=-sin1
2552           obrot_der(2,i-2)= cos1
2553           Ugder(1,1,i-2)= sin1
2554           Ugder(1,2,i-2)=-cos1
2555           Ugder(2,1,i-2)=-cos1
2556           Ugder(2,2,i-2)=-sin1
2557           dwacos2=cos2+cos2
2558           dwasin2=sin2+sin2
2559           obrot2_der(1,i-2)=-dwasin2
2560           obrot2_der(2,i-2)= dwacos2
2561           Ug2der(1,1,i-2)= dwasin2
2562           Ug2der(1,2,i-2)=-dwacos2
2563           Ug2der(2,1,i-2)=-dwacos2
2564           Ug2der(2,2,i-2)=-dwasin2
2565         else
2566           obrot_der(1,i-2)=0.0d0
2567           obrot_der(2,i-2)=0.0d0
2568           Ugder(1,1,i-2)=0.0d0
2569           Ugder(1,2,i-2)=0.0d0
2570           Ugder(2,1,i-2)=0.0d0
2571           Ugder(2,2,i-2)=0.0d0
2572           obrot2_der(1,i-2)=0.0d0
2573           obrot2_der(2,i-2)=0.0d0
2574           Ug2der(1,1,i-2)=0.0d0
2575           Ug2der(1,2,i-2)=0.0d0
2576           Ug2der(2,1,i-2)=0.0d0
2577           Ug2der(2,2,i-2)=0.0d0
2578         endif
2579 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2580         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2581           iti = itortyp(itype(i-2))
2582         else
2583           iti=ntortyp+1
2584         endif
2585 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2586         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2587           iti1 = itortyp(itype(i-1))
2588         else
2589           iti1=ntortyp+1
2590         endif
2591 cd        write (iout,*) '*******i',i,' iti1',iti
2592 cd        write (iout,*) 'b1',b1(:,iti)
2593 cd        write (iout,*) 'b2',b2(:,iti)
2594 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2595 c        if (i .gt. iatel_s+2) then
2596         if (i .gt. nnt+2) then
2597           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2598           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2599           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2600      &    then
2601           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2602           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2603           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2604           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2605           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2606           endif
2607         else
2608           do k=1,2
2609             Ub2(k,i-2)=0.0d0
2610             Ctobr(k,i-2)=0.0d0
2611             Dtobr2(k,i-2)=0.0d0
2612             do l=1,2
2613               EUg(l,k,i-2)=0.0d0
2614               CUg(l,k,i-2)=0.0d0
2615               DUg(l,k,i-2)=0.0d0
2616               DtUg2(l,k,i-2)=0.0d0
2617             enddo
2618           enddo
2619         endif
2620         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2621         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2622         do k=1,2
2623           muder(k,i-2)=Ub2der(k,i-2)
2624         enddo
2625 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2626         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2627           iti1 = itortyp(itype(i-1))
2628         else
2629           iti1=ntortyp+1
2630         endif
2631         do k=1,2
2632           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2633         enddo
2634 cd        write (iout,*) 'mu ',mu(:,i-2)
2635 cd        write (iout,*) 'mu1',mu1(:,i-2)
2636 cd        write (iout,*) 'mu2',mu2(:,i-2)
2637         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2638      &  then
2639         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2640         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2641         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2642         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2643         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2644 C Vectors and matrices dependent on a single virtual-bond dihedral.
2645         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2646         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2647         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2648         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2649         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2650         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2651         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2652         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2653         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2654         endif
2655       enddo
2656 C Matrices dependent on two consecutive virtual-bond dihedrals.
2657 C The order of matrices is from left to right.
2658       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2659      &then
2660 c      do i=max0(ivec_start,2),ivec_end
2661       do i=2,nres-1
2662         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2663         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2664         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2665         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2666         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2667         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2668         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2669         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2670       enddo
2671       endif
2672 #if defined(MPI) && defined(PARMAT)
2673 #ifdef DEBUG
2674 c      if (fg_rank.eq.0) then
2675         write (iout,*) "Arrays UG and UGDER before GATHER"
2676         do i=1,nres-1
2677           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2678      &     ((ug(l,k,i),l=1,2),k=1,2),
2679      &     ((ugder(l,k,i),l=1,2),k=1,2)
2680         enddo
2681         write (iout,*) "Arrays UG2 and UG2DER"
2682         do i=1,nres-1
2683           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2684      &     ((ug2(l,k,i),l=1,2),k=1,2),
2685      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2686         enddo
2687         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2688         do i=1,nres-1
2689           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2690      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2691      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2692         enddo
2693         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2694         do i=1,nres-1
2695           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2696      &     costab(i),sintab(i),costab2(i),sintab2(i)
2697         enddo
2698         write (iout,*) "Array MUDER"
2699         do i=1,nres-1
2700           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2701         enddo
2702 c      endif
2703 #endif
2704       if (nfgtasks.gt.1) then
2705         time00=MPI_Wtime()
2706 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2707 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2708 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2709 #ifdef MATGATHER
2710         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2711      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2712      &   FG_COMM1,IERR)
2713         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2714      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2715      &   FG_COMM1,IERR)
2716         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2717      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2718      &   FG_COMM1,IERR)
2719         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2720      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2721      &   FG_COMM1,IERR)
2722         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2723      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2724      &   FG_COMM1,IERR)
2725         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2726      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2727      &   FG_COMM1,IERR)
2728         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2729      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2730      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2731         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2732      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2733      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2734         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2735      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2736      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2737         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2738      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2739      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2740         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2741      &  then
2742         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2743      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2744      &   FG_COMM1,IERR)
2745         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2746      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2747      &   FG_COMM1,IERR)
2748         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2749      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2750      &   FG_COMM1,IERR)
2751        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2752      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2753      &   FG_COMM1,IERR)
2754         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2755      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2756      &   FG_COMM1,IERR)
2757         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2758      &   ivec_count(fg_rank1),
2759      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2760      &   FG_COMM1,IERR)
2761         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2762      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2763      &   FG_COMM1,IERR)
2764         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2765      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2766      &   FG_COMM1,IERR)
2767         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2768      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2769      &   FG_COMM1,IERR)
2770         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2771      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2772      &   FG_COMM1,IERR)
2773         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2774      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2775      &   FG_COMM1,IERR)
2776         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2777      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2778      &   FG_COMM1,IERR)
2779         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2780      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2781      &   FG_COMM1,IERR)
2782         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2783      &   ivec_count(fg_rank1),
2784      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2785      &   FG_COMM1,IERR)
2786         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2787      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2788      &   FG_COMM1,IERR)
2789        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2790      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2791      &   FG_COMM1,IERR)
2792         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2793      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2794      &   FG_COMM1,IERR)
2795        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2796      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2797      &   FG_COMM1,IERR)
2798         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2799      &   ivec_count(fg_rank1),
2800      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2801      &   FG_COMM1,IERR)
2802         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2803      &   ivec_count(fg_rank1),
2804      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2805      &   FG_COMM1,IERR)
2806         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2807      &   ivec_count(fg_rank1),
2808      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2809      &   MPI_MAT2,FG_COMM1,IERR)
2810         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2811      &   ivec_count(fg_rank1),
2812      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2813      &   MPI_MAT2,FG_COMM1,IERR)
2814         endif
2815 #else
2816 c Passes matrix info through the ring
2817       isend=fg_rank1
2818       irecv=fg_rank1-1
2819       if (irecv.lt.0) irecv=nfgtasks1-1
2820       iprev=irecv
2821       inext=fg_rank1+1
2822       if (inext.ge.nfgtasks1) inext=0
2823       do i=1,nfgtasks1-1
2824 c        write (iout,*) "isend",isend," irecv",irecv
2825 c        call flush(iout)
2826         lensend=lentyp(isend)
2827         lenrecv=lentyp(irecv)
2828 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2829 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2830 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2831 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2832 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2833 c        write (iout,*) "Gather ROTAT1"
2834 c        call flush(iout)
2835 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2836 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2837 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2838 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2839 c        write (iout,*) "Gather ROTAT2"
2840 c        call flush(iout)
2841         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2842      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2843      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2844      &   iprev,4400+irecv,FG_COMM,status,IERR)
2845 c        write (iout,*) "Gather ROTAT_OLD"
2846 c        call flush(iout)
2847         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2848      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2849      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2850      &   iprev,5500+irecv,FG_COMM,status,IERR)
2851 c        write (iout,*) "Gather PRECOMP11"
2852 c        call flush(iout)
2853         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2854      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2855      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2856      &   iprev,6600+irecv,FG_COMM,status,IERR)
2857 c        write (iout,*) "Gather PRECOMP12"
2858 c        call flush(iout)
2859         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2860      &  then
2861         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2862      &   MPI_ROTAT2(lensend),inext,7700+isend,
2863      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2864      &   iprev,7700+irecv,FG_COMM,status,IERR)
2865 c        write (iout,*) "Gather PRECOMP21"
2866 c        call flush(iout)
2867         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2868      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2869      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2870      &   iprev,8800+irecv,FG_COMM,status,IERR)
2871 c        write (iout,*) "Gather PRECOMP22"
2872 c        call flush(iout)
2873         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2874      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2875      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2876      &   MPI_PRECOMP23(lenrecv),
2877      &   iprev,9900+irecv,FG_COMM,status,IERR)
2878 c        write (iout,*) "Gather PRECOMP23"
2879 c        call flush(iout)
2880         endif
2881         isend=irecv
2882         irecv=irecv-1
2883         if (irecv.lt.0) irecv=nfgtasks1-1
2884       enddo
2885 #endif
2886         time_gather=time_gather+MPI_Wtime()-time00
2887       endif
2888 #ifdef DEBUG
2889 c      if (fg_rank.eq.0) then
2890         write (iout,*) "Arrays UG and UGDER"
2891         do i=1,nres-1
2892           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2893      &     ((ug(l,k,i),l=1,2),k=1,2),
2894      &     ((ugder(l,k,i),l=1,2),k=1,2)
2895         enddo
2896         write (iout,*) "Arrays UG2 and UG2DER"
2897         do i=1,nres-1
2898           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2899      &     ((ug2(l,k,i),l=1,2),k=1,2),
2900      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2901         enddo
2902         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2903         do i=1,nres-1
2904           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2905      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2906      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2907         enddo
2908         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2909         do i=1,nres-1
2910           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2911      &     costab(i),sintab(i),costab2(i),sintab2(i)
2912         enddo
2913         write (iout,*) "Array MUDER"
2914         do i=1,nres-1
2915           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2916         enddo
2917 c      endif
2918 #endif
2919 #endif
2920 cd      do i=1,nres
2921 cd        iti = itortyp(itype(i))
2922 cd        write (iout,*) i
2923 cd        do j=1,2
2924 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2925 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2926 cd        enddo
2927 cd      enddo
2928       return
2929       end
2930 C--------------------------------------------------------------------------
2931       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2932 C
2933 C This subroutine calculates the average interaction energy and its gradient
2934 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2935 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2936 C The potential depends both on the distance of peptide-group centers and on
2937 C the orientation of the CA-CA virtual bonds.
2938 C
2939       implicit real*8 (a-h,o-z)
2940 #ifdef MPI
2941       include 'mpif.h'
2942 #endif
2943       include 'DIMENSIONS'
2944       include 'COMMON.CONTROL'
2945       include 'COMMON.SETUP'
2946       include 'COMMON.IOUNITS'
2947       include 'COMMON.GEO'
2948       include 'COMMON.VAR'
2949       include 'COMMON.LOCAL'
2950       include 'COMMON.CHAIN'
2951       include 'COMMON.DERIV'
2952       include 'COMMON.INTERACT'
2953       include 'COMMON.CONTACTS'
2954       include 'COMMON.TORSION'
2955       include 'COMMON.VECTORS'
2956       include 'COMMON.FFIELD'
2957       include 'COMMON.TIME1'
2958       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2959      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2960       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2961      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2962       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2963      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2964      &    num_conti,j1,j2
2965 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2966 #ifdef MOMENT
2967       double precision scal_el /1.0d0/
2968 #else
2969       double precision scal_el /0.5d0/
2970 #endif
2971 C 12/13/98
2972 C 13-go grudnia roku pamietnego...
2973       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2974      &                   0.0d0,1.0d0,0.0d0,
2975      &                   0.0d0,0.0d0,1.0d0/
2976 cd      write(iout,*) 'In EELEC'
2977 cd      do i=1,nloctyp
2978 cd        write(iout,*) 'Type',i
2979 cd        write(iout,*) 'B1',B1(:,i)
2980 cd        write(iout,*) 'B2',B2(:,i)
2981 cd        write(iout,*) 'CC',CC(:,:,i)
2982 cd        write(iout,*) 'DD',DD(:,:,i)
2983 cd        write(iout,*) 'EE',EE(:,:,i)
2984 cd      enddo
2985 cd      call check_vecgrad
2986 cd      stop
2987       if (icheckgrad.eq.1) then
2988         do i=1,nres-1
2989           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2990           do k=1,3
2991             dc_norm(k,i)=dc(k,i)*fac
2992           enddo
2993 c          write (iout,*) 'i',i,' fac',fac
2994         enddo
2995       endif
2996       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2997      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2998      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2999 c        call vec_and_deriv
3000 #ifdef TIMING
3001         time01=MPI_Wtime()
3002 #endif
3003         call set_matrices
3004 #ifdef TIMING
3005         time_mat=time_mat+MPI_Wtime()-time01
3006 #endif
3007       endif
3008 cd      do i=1,nres-1
3009 cd        write (iout,*) 'i=',i
3010 cd        do k=1,3
3011 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3012 cd        enddo
3013 cd        do k=1,3
3014 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3015 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3016 cd        enddo
3017 cd      enddo
3018       t_eelecij=0.0d0
3019       ees=0.0D0
3020       evdw1=0.0D0
3021       eel_loc=0.0d0
3022       eello_turn3=0.0d0
3023       eello_turn4=0.0d0
3024       ind=0
3025       do i=1,nres
3026         num_cont_hb(i)=0
3027       enddo
3028 cd      print '(a)','Enter EELEC'
3029 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3030       do i=1,nres
3031         gel_loc_loc(i)=0.0d0
3032         gcorr_loc(i)=0.0d0
3033       enddo
3034 c
3035 c
3036 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3037 C
3038 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3039 C
3040       do i=iturn3_start,iturn3_end
3041         dxi=dc(1,i)
3042         dyi=dc(2,i)
3043         dzi=dc(3,i)
3044         dx_normi=dc_norm(1,i)
3045         dy_normi=dc_norm(2,i)
3046         dz_normi=dc_norm(3,i)
3047         xmedi=c(1,i)+0.5d0*dxi
3048         ymedi=c(2,i)+0.5d0*dyi
3049         zmedi=c(3,i)+0.5d0*dzi
3050         num_conti=0
3051         call eelecij(i,i+2,ees,evdw1,eel_loc)
3052         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3053         num_cont_hb(i)=num_conti
3054       enddo
3055       do i=iturn4_start,iturn4_end
3056         dxi=dc(1,i)
3057         dyi=dc(2,i)
3058         dzi=dc(3,i)
3059         dx_normi=dc_norm(1,i)
3060         dy_normi=dc_norm(2,i)
3061         dz_normi=dc_norm(3,i)
3062         xmedi=c(1,i)+0.5d0*dxi
3063         ymedi=c(2,i)+0.5d0*dyi
3064         zmedi=c(3,i)+0.5d0*dzi
3065         num_conti=num_cont_hb(i)
3066         call eelecij(i,i+3,ees,evdw1,eel_loc)
3067         if (wturn4.gt.0.0d0) call eturn4(i,eello_turn4)
3068         num_cont_hb(i)=num_conti
3069       enddo   ! i
3070 c
3071 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3072 c
3073       do i=iatel_s,iatel_e
3074         dxi=dc(1,i)
3075         dyi=dc(2,i)
3076         dzi=dc(3,i)
3077         dx_normi=dc_norm(1,i)
3078         dy_normi=dc_norm(2,i)
3079         dz_normi=dc_norm(3,i)
3080         xmedi=c(1,i)+0.5d0*dxi
3081         ymedi=c(2,i)+0.5d0*dyi
3082         zmedi=c(3,i)+0.5d0*dzi
3083 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3084         num_conti=num_cont_hb(i)
3085         do j=ielstart(i),ielend(i)
3086           call eelecij(i,j,ees,evdw1,eel_loc)
3087         enddo ! j
3088         num_cont_hb(i)=num_conti
3089       enddo   ! i
3090 c      write (iout,*) "Number of loop steps in EELEC:",ind
3091 cd      do i=1,nres
3092 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3093 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3094 cd      enddo
3095 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3096 ccc      eel_loc=eel_loc+eello_turn3
3097 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3098       return
3099       end
3100 C-------------------------------------------------------------------------------
3101       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3102       implicit real*8 (a-h,o-z)
3103       include 'DIMENSIONS'
3104 #ifdef MPI
3105       include "mpif.h"
3106 #endif
3107       include 'COMMON.CONTROL'
3108       include 'COMMON.IOUNITS'
3109       include 'COMMON.GEO'
3110       include 'COMMON.VAR'
3111       include 'COMMON.LOCAL'
3112       include 'COMMON.CHAIN'
3113       include 'COMMON.DERIV'
3114       include 'COMMON.INTERACT'
3115       include 'COMMON.CONTACTS'
3116       include 'COMMON.TORSION'
3117       include 'COMMON.VECTORS'
3118       include 'COMMON.FFIELD'
3119       include 'COMMON.TIME1'
3120       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3121      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3122       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3123      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3124       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3125      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3126      &    num_conti,j1,j2
3127 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3128 #ifdef MOMENT
3129       double precision scal_el /1.0d0/
3130 #else
3131       double precision scal_el /0.5d0/
3132 #endif
3133 C 12/13/98
3134 C 13-go grudnia roku pamietnego...
3135       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3136      &                   0.0d0,1.0d0,0.0d0,
3137      &                   0.0d0,0.0d0,1.0d0/
3138 c          time00=MPI_Wtime()
3139 cd      write (iout,*) "eelecij",i,j
3140 c          ind=ind+1
3141           iteli=itel(i)
3142           itelj=itel(j)
3143           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3144           aaa=app(iteli,itelj)
3145           bbb=bpp(iteli,itelj)
3146           ael6i=ael6(iteli,itelj)
3147           ael3i=ael3(iteli,itelj)
3148           dxj=dc(1,j)
3149           dyj=dc(2,j)
3150           dzj=dc(3,j)
3151           dx_normj=dc_norm(1,j)
3152           dy_normj=dc_norm(2,j)
3153           dz_normj=dc_norm(3,j)
3154           xj=c(1,j)+0.5D0*dxj-xmedi
3155           yj=c(2,j)+0.5D0*dyj-ymedi
3156           zj=c(3,j)+0.5D0*dzj-zmedi
3157           rij=xj*xj+yj*yj+zj*zj
3158           rrmij=1.0D0/rij
3159           rij=dsqrt(rij)
3160           rmij=1.0D0/rij
3161           r3ij=rrmij*rmij
3162           r6ij=r3ij*r3ij
3163           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3164           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3165           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3166           fac=cosa-3.0D0*cosb*cosg
3167           ev1=aaa*r6ij*r6ij
3168 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3169           if (j.eq.i+2) ev1=scal_el*ev1
3170           ev2=bbb*r6ij
3171           fac3=ael6i*r6ij
3172           fac4=ael3i*r3ij
3173           evdwij=ev1+ev2
3174           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3175           el2=fac4*fac
3176           eesij=el1+el2
3177 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3178           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3179           ees=ees+eesij
3180           evdw1=evdw1+evdwij
3181 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3182 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3183 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3184 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3185
3186           if (energy_dec) then
3187               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3188               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3189           endif
3190
3191 C
3192 C Calculate contributions to the Cartesian gradient.
3193 C
3194 #ifdef SPLITELE
3195           facvdw=-6*rrmij*(ev1+evdwij)
3196           facel=-3*rrmij*(el1+eesij)
3197           fac1=fac
3198           erij(1)=xj*rmij
3199           erij(2)=yj*rmij
3200           erij(3)=zj*rmij
3201 *
3202 * Radial derivatives. First process both termini of the fragment (i,j)
3203 *
3204           ggg(1)=facel*xj
3205           ggg(2)=facel*yj
3206           ggg(3)=facel*zj
3207 c          do k=1,3
3208 c            ghalf=0.5D0*ggg(k)
3209 c            gelc(k,i)=gelc(k,i)+ghalf
3210 c            gelc(k,j)=gelc(k,j)+ghalf
3211 c          enddo
3212 c 9/28/08 AL Gradient compotents will be summed only at the end
3213           do k=1,3
3214             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3215             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3216           enddo
3217 *
3218 * Loop over residues i+1 thru j-1.
3219 *
3220 cgrad          do k=i+1,j-1
3221 cgrad            do l=1,3
3222 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3223 cgrad            enddo
3224 cgrad          enddo
3225           ggg(1)=facvdw*xj
3226           ggg(2)=facvdw*yj
3227           ggg(3)=facvdw*zj
3228 c          do k=1,3
3229 c            ghalf=0.5D0*ggg(k)
3230 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3231 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3232 c          enddo
3233 c 9/28/08 AL Gradient compotents will be summed only at the end
3234           do k=1,3
3235             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3236             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3237           enddo
3238 *
3239 * Loop over residues i+1 thru j-1.
3240 *
3241 cgrad          do k=i+1,j-1
3242 cgrad            do l=1,3
3243 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3244 cgrad            enddo
3245 cgrad          enddo
3246 #else
3247           facvdw=ev1+evdwij
3248           facel=el1+eesij
3249           fac1=fac
3250           fac=-3*rrmij*(facvdw+facvdw+facel)
3251           erij(1)=xj*rmij
3252           erij(2)=yj*rmij
3253           erij(3)=zj*rmij
3254 *
3255 * Radial derivatives. First process both termini of the fragment (i,j)
3256 *
3257           ggg(1)=fac*xj
3258           ggg(2)=fac*yj
3259           ggg(3)=fac*zj
3260 c          do k=1,3
3261 c            ghalf=0.5D0*ggg(k)
3262 c            gelc(k,i)=gelc(k,i)+ghalf
3263 c            gelc(k,j)=gelc(k,j)+ghalf
3264 c          enddo
3265 c 9/28/08 AL Gradient compotents will be summed only at the end
3266           do k=1,3
3267             gelc_long(k,j)=gelc(k,j)+ggg(k)
3268             gelc_long(k,i)=gelc(k,i)-ggg(k)
3269           enddo
3270 *
3271 * Loop over residues i+1 thru j-1.
3272 *
3273 cgrad          do k=i+1,j-1
3274 cgrad            do l=1,3
3275 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3276 cgrad            enddo
3277 cgrad          enddo
3278 c 9/28/08 AL Gradient compotents will be summed only at the end
3279           ggg(1)=facvdw*xj
3280           ggg(2)=facvdw*yj
3281           ggg(3)=facvdw*zj
3282           do k=1,3
3283             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3284             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3285           enddo
3286 #endif
3287 *
3288 * Angular part
3289 *
3290           ecosa=2.0D0*fac3*fac1+fac4
3291           fac4=-3.0D0*fac4
3292           fac3=-6.0D0*fac3
3293           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3294           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3295           do k=1,3
3296             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3297             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3298           enddo
3299 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3300 cd   &          (dcosg(k),k=1,3)
3301           do k=1,3
3302             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3303           enddo
3304 c          do k=1,3
3305 c            ghalf=0.5D0*ggg(k)
3306 c            gelc(k,i)=gelc(k,i)+ghalf
3307 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3308 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3309 c            gelc(k,j)=gelc(k,j)+ghalf
3310 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3311 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3312 c          enddo
3313 cgrad          do k=i+1,j-1
3314 cgrad            do l=1,3
3315 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3316 cgrad            enddo
3317 cgrad          enddo
3318           do k=1,3
3319             gelc(k,i)=gelc(k,i)
3320      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3321      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3322             gelc(k,j)=gelc(k,j)
3323      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3324      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3325             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3326             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3327           enddo
3328           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3329      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3330      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3331 C
3332 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3333 C   energy of a peptide unit is assumed in the form of a second-order
3334 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3335 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3336 C   are computed for EVERY pair of non-contiguous peptide groups.
3337 C
3338           if (j.lt.nres-1) then
3339             j1=j+1
3340             j2=j-1
3341           else
3342             j1=j-1
3343             j2=j-2
3344           endif
3345           kkk=0
3346           do k=1,2
3347             do l=1,2
3348               kkk=kkk+1
3349               muij(kkk)=mu(k,i)*mu(l,j)
3350             enddo
3351           enddo
3352 cd         write (iout,*) 'EELEC: i',i,' j',j
3353 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3354 cd          write(iout,*) 'muij',muij
3355           ury=scalar(uy(1,i),erij)
3356           urz=scalar(uz(1,i),erij)
3357           vry=scalar(uy(1,j),erij)
3358           vrz=scalar(uz(1,j),erij)
3359           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3360           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3361           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3362           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3363           fac=dsqrt(-ael6i)*r3ij
3364           a22=a22*fac
3365           a23=a23*fac
3366           a32=a32*fac
3367           a33=a33*fac
3368 cd          write (iout,'(4i5,4f10.5)')
3369 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3370 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3371 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3372 cd     &      uy(:,j),uz(:,j)
3373 cd          write (iout,'(4f10.5)')
3374 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3375 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3376 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3377 cd           write (iout,'(9f10.5/)')
3378 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3379 C Derivatives of the elements of A in virtual-bond vectors
3380           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3381           do k=1,3
3382             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3383             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3384             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3385             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3386             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3387             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3388             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3389             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3390             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3391             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3392             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3393             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3394           enddo
3395 C Compute radial contributions to the gradient
3396           facr=-3.0d0*rrmij
3397           a22der=a22*facr
3398           a23der=a23*facr
3399           a32der=a32*facr
3400           a33der=a33*facr
3401           agg(1,1)=a22der*xj
3402           agg(2,1)=a22der*yj
3403           agg(3,1)=a22der*zj
3404           agg(1,2)=a23der*xj
3405           agg(2,2)=a23der*yj
3406           agg(3,2)=a23der*zj
3407           agg(1,3)=a32der*xj
3408           agg(2,3)=a32der*yj
3409           agg(3,3)=a32der*zj
3410           agg(1,4)=a33der*xj
3411           agg(2,4)=a33der*yj
3412           agg(3,4)=a33der*zj
3413 C Add the contributions coming from er
3414           fac3=-3.0d0*fac
3415           do k=1,3
3416             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3417             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3418             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3419             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3420           enddo
3421           do k=1,3
3422 C Derivatives in DC(i)
3423 cgrad            ghalf1=0.5d0*agg(k,1)
3424 cgrad            ghalf2=0.5d0*agg(k,2)
3425 cgrad            ghalf3=0.5d0*agg(k,3)
3426 cgrad            ghalf4=0.5d0*agg(k,4)
3427             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3428      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3429             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3430      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3431             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3432      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3433             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3434      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3435 C Derivatives in DC(i+1)
3436             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3437      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3438             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3439      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3440             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3441      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3442             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3443      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3444 C Derivatives in DC(j)
3445             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3446      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3447             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3448      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3449             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3450      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3451             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3452      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3453 C Derivatives in DC(j+1) or DC(nres-1)
3454             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3455      &      -3.0d0*vryg(k,3)*ury)
3456             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3457      &      -3.0d0*vrzg(k,3)*ury)
3458             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3459      &      -3.0d0*vryg(k,3)*urz)
3460             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3461      &      -3.0d0*vrzg(k,3)*urz)
3462 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3463 cgrad              do l=1,4
3464 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3465 cgrad              enddo
3466 cgrad            endif
3467           enddo
3468           acipa(1,1)=a22
3469           acipa(1,2)=a23
3470           acipa(2,1)=a32
3471           acipa(2,2)=a33
3472           a22=-a22
3473           a23=-a23
3474           do l=1,2
3475             do k=1,3
3476               agg(k,l)=-agg(k,l)
3477               aggi(k,l)=-aggi(k,l)
3478               aggi1(k,l)=-aggi1(k,l)
3479               aggj(k,l)=-aggj(k,l)
3480               aggj1(k,l)=-aggj1(k,l)
3481             enddo
3482           enddo
3483           if (j.lt.nres-1) then
3484             a22=-a22
3485             a32=-a32
3486             do l=1,3,2
3487               do k=1,3
3488                 agg(k,l)=-agg(k,l)
3489                 aggi(k,l)=-aggi(k,l)
3490                 aggi1(k,l)=-aggi1(k,l)
3491                 aggj(k,l)=-aggj(k,l)
3492                 aggj1(k,l)=-aggj1(k,l)
3493               enddo
3494             enddo
3495           else
3496             a22=-a22
3497             a23=-a23
3498             a32=-a32
3499             a33=-a33
3500             do l=1,4
3501               do k=1,3
3502                 agg(k,l)=-agg(k,l)
3503                 aggi(k,l)=-aggi(k,l)
3504                 aggi1(k,l)=-aggi1(k,l)
3505                 aggj(k,l)=-aggj(k,l)
3506                 aggj1(k,l)=-aggj1(k,l)
3507               enddo
3508             enddo
3509           endif
3510           ENDIF ! WCORR
3511           IF (wel_loc.gt.0.0d0) THEN
3512 C Contribution to the local-electrostatic energy coming from the i-j pair
3513           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3514      &     +a33*muij(4)
3515 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3516
3517           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3518      &            'eelloc',i,j,eel_loc_ij
3519
3520           eel_loc=eel_loc+eel_loc_ij
3521 C Partial derivatives in virtual-bond dihedral angles gamma
3522           if (i.gt.1)
3523      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3524      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3525      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3526           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3527      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3528      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3529 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3530           do l=1,3
3531             ggg(l)=agg(l,1)*muij(1)+
3532      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3533             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3534             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3535 cgrad            ghalf=0.5d0*ggg(l)
3536 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3537 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3538           enddo
3539 cgrad          do k=i+1,j2
3540 cgrad            do l=1,3
3541 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3542 cgrad            enddo
3543 cgrad          enddo
3544 C Remaining derivatives of eello
3545           do l=1,3
3546             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3547      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3548             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3549      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3550             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3551      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3552             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3553      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3554           enddo
3555           ENDIF
3556 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3557 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3558           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3559      &       .and. num_conti.le.maxconts) then
3560 c            write (iout,*) i,j," entered corr"
3561 C
3562 C Calculate the contact function. The ith column of the array JCONT will
3563 C contain the numbers of atoms that make contacts with the atom I (of numbers
3564 C greater than I). The arrays FACONT and GACONT will contain the values of
3565 C the contact function and its derivative.
3566 c           r0ij=1.02D0*rpp(iteli,itelj)
3567 c           r0ij=1.11D0*rpp(iteli,itelj)
3568             r0ij=2.20D0*rpp(iteli,itelj)
3569 c           r0ij=1.55D0*rpp(iteli,itelj)
3570             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3571             if (fcont.gt.0.0D0) then
3572               num_conti=num_conti+1
3573               if (num_conti.gt.maxconts) then
3574                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3575      &                         ' will skip next contacts for this conf.'
3576               else
3577                 jcont_hb(num_conti,i)=j
3578 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3579 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3580                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3581      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3582 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3583 C  terms.
3584                 d_cont(num_conti,i)=rij
3585 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3586 C     --- Electrostatic-interaction matrix ---
3587                 a_chuj(1,1,num_conti,i)=a22
3588                 a_chuj(1,2,num_conti,i)=a23
3589                 a_chuj(2,1,num_conti,i)=a32
3590                 a_chuj(2,2,num_conti,i)=a33
3591 C     --- Gradient of rij
3592                 do kkk=1,3
3593                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3594                 enddo
3595                 kkll=0
3596                 do k=1,2
3597                   do l=1,2
3598                     kkll=kkll+1
3599                     do m=1,3
3600                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3601                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3602                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3603                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3604                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3605                     enddo
3606                   enddo
3607                 enddo
3608                 ENDIF
3609                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3610 C Calculate contact energies
3611                 cosa4=4.0D0*cosa
3612                 wij=cosa-3.0D0*cosb*cosg
3613                 cosbg1=cosb+cosg
3614                 cosbg2=cosb-cosg
3615 c               fac3=dsqrt(-ael6i)/r0ij**3
3616                 fac3=dsqrt(-ael6i)*r3ij
3617 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3618                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3619                 if (ees0tmp.gt.0) then
3620                   ees0pij=dsqrt(ees0tmp)
3621                 else
3622                   ees0pij=0
3623                 endif
3624 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3625                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3626                 if (ees0tmp.gt.0) then
3627                   ees0mij=dsqrt(ees0tmp)
3628                 else
3629                   ees0mij=0
3630                 endif
3631 c               ees0mij=0.0D0
3632                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3633                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3634 C Diagnostics. Comment out or remove after debugging!
3635 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3636 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3637 c               ees0m(num_conti,i)=0.0D0
3638 C End diagnostics.
3639 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3640 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3641 C Angular derivatives of the contact function
3642                 ees0pij1=fac3/ees0pij
3643                 ees0mij1=fac3/ees0mij
3644                 fac3p=-3.0D0*fac3*rrmij
3645                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3646                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3647 c               ees0mij1=0.0D0
3648                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3649                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3650                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3651                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3652                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3653                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3654                 ecosap=ecosa1+ecosa2
3655                 ecosbp=ecosb1+ecosb2
3656                 ecosgp=ecosg1+ecosg2
3657                 ecosam=ecosa1-ecosa2
3658                 ecosbm=ecosb1-ecosb2
3659                 ecosgm=ecosg1-ecosg2
3660 C Diagnostics
3661 c               ecosap=ecosa1
3662 c               ecosbp=ecosb1
3663 c               ecosgp=ecosg1
3664 c               ecosam=0.0D0
3665 c               ecosbm=0.0D0
3666 c               ecosgm=0.0D0
3667 C End diagnostics
3668                 facont_hb(num_conti,i)=fcont
3669                 fprimcont=fprimcont/rij
3670 cd              facont_hb(num_conti,i)=1.0D0
3671 C Following line is for diagnostics.
3672 cd              fprimcont=0.0D0
3673                 do k=1,3
3674                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3675                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3676                 enddo
3677                 do k=1,3
3678                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3679                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3680                 enddo
3681                 gggp(1)=gggp(1)+ees0pijp*xj
3682                 gggp(2)=gggp(2)+ees0pijp*yj
3683                 gggp(3)=gggp(3)+ees0pijp*zj
3684                 gggm(1)=gggm(1)+ees0mijp*xj
3685                 gggm(2)=gggm(2)+ees0mijp*yj
3686                 gggm(3)=gggm(3)+ees0mijp*zj
3687 C Derivatives due to the contact function
3688                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3689                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3690                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3691                 do k=1,3
3692 c
3693 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3694 c          following the change of gradient-summation algorithm.
3695 c
3696 cgrad                  ghalfp=0.5D0*gggp(k)
3697 cgrad                  ghalfm=0.5D0*gggm(k)
3698                   gacontp_hb1(k,num_conti,i)=!ghalfp
3699      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3700      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3701                   gacontp_hb2(k,num_conti,i)=!ghalfp
3702      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3703      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3704                   gacontp_hb3(k,num_conti,i)=gggp(k)
3705                   gacontm_hb1(k,num_conti,i)=!ghalfm
3706      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3707      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3708                   gacontm_hb2(k,num_conti,i)=!ghalfm
3709      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3710      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3711                   gacontm_hb3(k,num_conti,i)=gggm(k)
3712                 enddo
3713 C Diagnostics. Comment out or remove after debugging!
3714 cdiag           do k=1,3
3715 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3716 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3717 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3718 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3719 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3720 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3721 cdiag           enddo
3722               ENDIF ! wcorr
3723               endif  ! num_conti.le.maxconts
3724             endif  ! fcont.gt.0
3725           endif    ! j.gt.i+1
3726           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3727             do k=1,4
3728               do l=1,3
3729                 ghalf=0.5d0*agg(l,k)
3730                 aggi(l,k)=aggi(l,k)+ghalf
3731                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3732                 aggj(l,k)=aggj(l,k)+ghalf
3733               enddo
3734             enddo
3735             if (j.eq.nres-1 .and. i.lt.j-2) then
3736               do k=1,4
3737                 do l=1,3
3738                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3739                 enddo
3740               enddo
3741             endif
3742           endif
3743 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3744       return
3745       end
3746 C-----------------------------------------------------------------------------
3747       subroutine eturn3(i,eello_turn3)
3748 C Third- and fourth-order contributions from turns
3749       implicit real*8 (a-h,o-z)
3750       include 'DIMENSIONS'
3751       include 'COMMON.IOUNITS'
3752       include 'COMMON.GEO'
3753       include 'COMMON.VAR'
3754       include 'COMMON.LOCAL'
3755       include 'COMMON.CHAIN'
3756       include 'COMMON.DERIV'
3757       include 'COMMON.INTERACT'
3758       include 'COMMON.CONTACTS'
3759       include 'COMMON.TORSION'
3760       include 'COMMON.VECTORS'
3761       include 'COMMON.FFIELD'
3762       include 'COMMON.CONTROL'
3763       dimension ggg(3)
3764       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3765      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3766      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3767       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3768      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3769       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3770      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3771      &    num_conti,j1,j2
3772       j=i+2
3773 c      write (iout,*) "eturn3",i,j,j1,j2
3774       a_temp(1,1)=a22
3775       a_temp(1,2)=a23
3776       a_temp(2,1)=a32
3777       a_temp(2,2)=a33
3778 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3779 C
3780 C               Third-order contributions
3781 C
3782 C                 (i+2)o----(i+3)
3783 C                      | |
3784 C                      | |
3785 C                 (i+1)o----i
3786 C
3787 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3788 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3789         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3790         call transpose2(auxmat(1,1),auxmat1(1,1))
3791         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3792         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3793         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3794      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3795 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3796 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3797 cd     &    ' eello_turn3_num',4*eello_turn3_num
3798 C Derivatives in gamma(i)
3799         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3800         call transpose2(auxmat2(1,1),auxmat3(1,1))
3801         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3802         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3803 C Derivatives in gamma(i+1)
3804         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3805         call transpose2(auxmat2(1,1),auxmat3(1,1))
3806         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3807         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3808      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3809 C Cartesian derivatives
3810         do l=1,3
3811 c            ghalf1=0.5d0*agg(l,1)
3812 c            ghalf2=0.5d0*agg(l,2)
3813 c            ghalf3=0.5d0*agg(l,3)
3814 c            ghalf4=0.5d0*agg(l,4)
3815           a_temp(1,1)=aggi(l,1)!+ghalf1
3816           a_temp(1,2)=aggi(l,2)!+ghalf2
3817           a_temp(2,1)=aggi(l,3)!+ghalf3
3818           a_temp(2,2)=aggi(l,4)!+ghalf4
3819           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3820           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3821      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3822           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3823           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3824           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3825           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3826           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3827           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3828      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3829           a_temp(1,1)=aggj(l,1)!+ghalf1
3830           a_temp(1,2)=aggj(l,2)!+ghalf2
3831           a_temp(2,1)=aggj(l,3)!+ghalf3
3832           a_temp(2,2)=aggj(l,4)!+ghalf4
3833           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3834           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3835      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3836           a_temp(1,1)=aggj1(l,1)
3837           a_temp(1,2)=aggj1(l,2)
3838           a_temp(2,1)=aggj1(l,3)
3839           a_temp(2,2)=aggj1(l,4)
3840           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3841           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3842      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3843         enddo
3844       return
3845       end
3846 C-------------------------------------------------------------------------------
3847       subroutine eturn4(i,eello_turn4)
3848 C Third- and fourth-order contributions from turns
3849       implicit real*8 (a-h,o-z)
3850       include 'DIMENSIONS'
3851       include 'COMMON.IOUNITS'
3852       include 'COMMON.GEO'
3853       include 'COMMON.VAR'
3854       include 'COMMON.LOCAL'
3855       include 'COMMON.CHAIN'
3856       include 'COMMON.DERIV'
3857       include 'COMMON.INTERACT'
3858       include 'COMMON.CONTACTS'
3859       include 'COMMON.TORSION'
3860       include 'COMMON.VECTORS'
3861       include 'COMMON.FFIELD'
3862       include 'COMMON.CONTROL'
3863       dimension ggg(3)
3864       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3865      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3866      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3867       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3868      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3869       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3870      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3871      &    num_conti,j1,j2
3872       j=i+3
3873 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3874 C
3875 C               Fourth-order contributions
3876 C
3877 C                 (i+3)o----(i+4)
3878 C                     /  |
3879 C               (i+2)o   |
3880 C                     \  |
3881 C                 (i+1)o----i
3882 C
3883 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3884 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3885 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3886         a_temp(1,1)=a22
3887         a_temp(1,2)=a23
3888         a_temp(2,1)=a32
3889         a_temp(2,2)=a33
3890         iti1=itortyp(itype(i+1))
3891         iti2=itortyp(itype(i+2))
3892         iti3=itortyp(itype(i+3))
3893 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3894         call transpose2(EUg(1,1,i+1),e1t(1,1))
3895         call transpose2(Eug(1,1,i+2),e2t(1,1))
3896         call transpose2(Eug(1,1,i+3),e3t(1,1))
3897         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3898         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3899         s1=scalar2(b1(1,iti2),auxvec(1))
3900         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3901         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3902         s2=scalar2(b1(1,iti1),auxvec(1))
3903         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3904         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3905         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3906         eello_turn4=eello_turn4-(s1+s2+s3)
3907         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3908      &      'eturn4',i,j,-(s1+s2+s3)
3909 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3910 cd     &    ' eello_turn4_num',8*eello_turn4_num
3911 C Derivatives in gamma(i)
3912         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3913         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3914         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3915         s1=scalar2(b1(1,iti2),auxvec(1))
3916         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3917         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3918         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3919 C Derivatives in gamma(i+1)
3920         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3921         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3922         s2=scalar2(b1(1,iti1),auxvec(1))
3923         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3924         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3925         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3926         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3927 C Derivatives in gamma(i+2)
3928         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3929         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3930         s1=scalar2(b1(1,iti2),auxvec(1))
3931         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3932         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3933         s2=scalar2(b1(1,iti1),auxvec(1))
3934         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3935         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3936         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3937         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3938 C Cartesian derivatives
3939 C Derivatives of this turn contributions in DC(i+2)
3940         if (j.lt.nres-1) then
3941           do l=1,3
3942             a_temp(1,1)=agg(l,1)
3943             a_temp(1,2)=agg(l,2)
3944             a_temp(2,1)=agg(l,3)
3945             a_temp(2,2)=agg(l,4)
3946             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3947             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3948             s1=scalar2(b1(1,iti2),auxvec(1))
3949             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3950             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3951             s2=scalar2(b1(1,iti1),auxvec(1))
3952             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3953             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3954             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3955             ggg(l)=-(s1+s2+s3)
3956             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3957           enddo
3958         endif
3959 C Remaining derivatives of this turn contribution
3960         do l=1,3
3961           a_temp(1,1)=aggi(l,1)
3962           a_temp(1,2)=aggi(l,2)
3963           a_temp(2,1)=aggi(l,3)
3964           a_temp(2,2)=aggi(l,4)
3965           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3966           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3967           s1=scalar2(b1(1,iti2),auxvec(1))
3968           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3969           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3970           s2=scalar2(b1(1,iti1),auxvec(1))
3971           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3972           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3973           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3974           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3975           a_temp(1,1)=aggi1(l,1)
3976           a_temp(1,2)=aggi1(l,2)
3977           a_temp(2,1)=aggi1(l,3)
3978           a_temp(2,2)=aggi1(l,4)
3979           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3980           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3981           s1=scalar2(b1(1,iti2),auxvec(1))
3982           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3983           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3984           s2=scalar2(b1(1,iti1),auxvec(1))
3985           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3986           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3987           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3988           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3989           a_temp(1,1)=aggj(l,1)
3990           a_temp(1,2)=aggj(l,2)
3991           a_temp(2,1)=aggj(l,3)
3992           a_temp(2,2)=aggj(l,4)
3993           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3994           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3995           s1=scalar2(b1(1,iti2),auxvec(1))
3996           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3997           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3998           s2=scalar2(b1(1,iti1),auxvec(1))
3999           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4000           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4001           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4002           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
4003           a_temp(1,1)=aggj1(l,1)
4004           a_temp(1,2)=aggj1(l,2)
4005           a_temp(2,1)=aggj1(l,3)
4006           a_temp(2,2)=aggj1(l,4)
4007           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4008           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4009           s1=scalar2(b1(1,iti2),auxvec(1))
4010           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4011           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4012           s2=scalar2(b1(1,iti1),auxvec(1))
4013           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4014           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4015           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4016 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4017           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4018         enddo
4019       return
4020       end
4021 C-----------------------------------------------------------------------------
4022       subroutine vecpr(u,v,w)
4023       implicit real*8(a-h,o-z)
4024       dimension u(3),v(3),w(3)
4025       w(1)=u(2)*v(3)-u(3)*v(2)
4026       w(2)=-u(1)*v(3)+u(3)*v(1)
4027       w(3)=u(1)*v(2)-u(2)*v(1)
4028       return
4029       end
4030 C-----------------------------------------------------------------------------
4031       subroutine unormderiv(u,ugrad,unorm,ungrad)
4032 C This subroutine computes the derivatives of a normalized vector u, given
4033 C the derivatives computed without normalization conditions, ugrad. Returns
4034 C ungrad.
4035       implicit none
4036       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4037       double precision vec(3)
4038       double precision scalar
4039       integer i,j
4040 c      write (2,*) 'ugrad',ugrad
4041 c      write (2,*) 'u',u
4042       do i=1,3
4043         vec(i)=scalar(ugrad(1,i),u(1))
4044       enddo
4045 c      write (2,*) 'vec',vec
4046       do i=1,3
4047         do j=1,3
4048           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4049         enddo
4050       enddo
4051 c      write (2,*) 'ungrad',ungrad
4052       return
4053       end
4054 C-----------------------------------------------------------------------------
4055       subroutine escp_soft_sphere(evdw2,evdw2_14)
4056 C
4057 C This subroutine calculates the excluded-volume interaction energy between
4058 C peptide-group centers and side chains and its gradient in virtual-bond and
4059 C side-chain vectors.
4060 C
4061       implicit real*8 (a-h,o-z)
4062       include 'DIMENSIONS'
4063       include 'COMMON.GEO'
4064       include 'COMMON.VAR'
4065       include 'COMMON.LOCAL'
4066       include 'COMMON.CHAIN'
4067       include 'COMMON.DERIV'
4068       include 'COMMON.INTERACT'
4069       include 'COMMON.FFIELD'
4070       include 'COMMON.IOUNITS'
4071       include 'COMMON.CONTROL'
4072       dimension ggg(3)
4073       evdw2=0.0D0
4074       evdw2_14=0.0d0
4075       r0_scp=4.5d0
4076 cd    print '(a)','Enter ESCP'
4077 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4078       do i=iatscp_s,iatscp_e
4079         iteli=itel(i)
4080         xi=0.5D0*(c(1,i)+c(1,i+1))
4081         yi=0.5D0*(c(2,i)+c(2,i+1))
4082         zi=0.5D0*(c(3,i)+c(3,i+1))
4083
4084         do iint=1,nscp_gr(i)
4085
4086         do j=iscpstart(i,iint),iscpend(i,iint)
4087           itypj=itype(j)
4088 C Uncomment following three lines for SC-p interactions
4089 c         xj=c(1,nres+j)-xi
4090 c         yj=c(2,nres+j)-yi
4091 c         zj=c(3,nres+j)-zi
4092 C Uncomment following three lines for Ca-p interactions
4093           xj=c(1,j)-xi
4094           yj=c(2,j)-yi
4095           zj=c(3,j)-zi
4096           rij=xj*xj+yj*yj+zj*zj
4097           r0ij=r0_scp
4098           r0ijsq=r0ij*r0ij
4099           if (rij.lt.r0ijsq) then
4100             evdwij=0.25d0*(rij-r0ijsq)**2
4101             fac=rij-r0ijsq
4102           else
4103             evdwij=0.0d0
4104             fac=0.0d0
4105           endif
4106           evdw2=evdw2+evdwij
4107 C
4108 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4109 C
4110           ggg(1)=xj*fac
4111           ggg(2)=yj*fac
4112           ggg(3)=zj*fac
4113 cgrad          if (j.lt.i) then
4114 cd          write (iout,*) 'j<i'
4115 C Uncomment following three lines for SC-p interactions
4116 c           do k=1,3
4117 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4118 c           enddo
4119 cgrad          else
4120 cd          write (iout,*) 'j>i'
4121 cgrad            do k=1,3
4122 cgrad              ggg(k)=-ggg(k)
4123 C Uncomment following line for SC-p interactions
4124 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4125 cgrad            enddo
4126 cgrad          endif
4127 cgrad          do k=1,3
4128 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4129 cgrad          enddo
4130 cgrad          kstart=min0(i+1,j)
4131 cgrad          kend=max0(i-1,j-1)
4132 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4133 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4134 cgrad          do k=kstart,kend
4135 cgrad            do l=1,3
4136 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4137 cgrad            enddo
4138 cgrad          enddo
4139           do k=1,3
4140             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4141             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4142           enddo
4143         enddo
4144
4145         enddo ! iint
4146       enddo ! i
4147       return
4148       end
4149 C-----------------------------------------------------------------------------
4150       subroutine escp(evdw2,evdw2_14)
4151 C
4152 C This subroutine calculates the excluded-volume interaction energy between
4153 C peptide-group centers and side chains and its gradient in virtual-bond and
4154 C side-chain vectors.
4155 C
4156       implicit real*8 (a-h,o-z)
4157       include 'DIMENSIONS'
4158       include 'COMMON.GEO'
4159       include 'COMMON.VAR'
4160       include 'COMMON.LOCAL'
4161       include 'COMMON.CHAIN'
4162       include 'COMMON.DERIV'
4163       include 'COMMON.INTERACT'
4164       include 'COMMON.FFIELD'
4165       include 'COMMON.IOUNITS'
4166       include 'COMMON.CONTROL'
4167       dimension ggg(3)
4168       evdw2=0.0D0
4169       evdw2_14=0.0d0
4170 cd    print '(a)','Enter ESCP'
4171 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4172       do i=iatscp_s,iatscp_e
4173         iteli=itel(i)
4174         xi=0.5D0*(c(1,i)+c(1,i+1))
4175         yi=0.5D0*(c(2,i)+c(2,i+1))
4176         zi=0.5D0*(c(3,i)+c(3,i+1))
4177
4178         do iint=1,nscp_gr(i)
4179
4180         do j=iscpstart(i,iint),iscpend(i,iint)
4181           itypj=itype(j)
4182 C Uncomment following three lines for SC-p interactions
4183 c         xj=c(1,nres+j)-xi
4184 c         yj=c(2,nres+j)-yi
4185 c         zj=c(3,nres+j)-zi
4186 C Uncomment following three lines for Ca-p interactions
4187           xj=c(1,j)-xi
4188           yj=c(2,j)-yi
4189           zj=c(3,j)-zi
4190           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4191           fac=rrij**expon2
4192           e1=fac*fac*aad(itypj,iteli)
4193           e2=fac*bad(itypj,iteli)
4194           if (iabs(j-i) .le. 2) then
4195             e1=scal14*e1
4196             e2=scal14*e2
4197             evdw2_14=evdw2_14+e1+e2
4198           endif
4199           evdwij=e1+e2
4200           evdw2=evdw2+evdwij
4201           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4202      &        'evdw2',i,j,evdwij
4203 C
4204 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4205 C
4206           fac=-(evdwij+e1)*rrij
4207           ggg(1)=xj*fac
4208           ggg(2)=yj*fac
4209           ggg(3)=zj*fac
4210 cgrad          if (j.lt.i) then
4211 cd          write (iout,*) 'j<i'
4212 C Uncomment following three lines for SC-p interactions
4213 c           do k=1,3
4214 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4215 c           enddo
4216 cgrad          else
4217 cd          write (iout,*) 'j>i'
4218 cgrad            do k=1,3
4219 cgrad              ggg(k)=-ggg(k)
4220 C Uncomment following line for SC-p interactions
4221 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4222 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4223 cgrad            enddo
4224 cgrad          endif
4225 cgrad          do k=1,3
4226 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4227 cgrad          enddo
4228 cgrad          kstart=min0(i+1,j)
4229 cgrad          kend=max0(i-1,j-1)
4230 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4231 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4232 cgrad          do k=kstart,kend
4233 cgrad            do l=1,3
4234 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4235 cgrad            enddo
4236 cgrad          enddo
4237           do k=1,3
4238             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4239             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4240           enddo
4241         enddo
4242
4243         enddo ! iint
4244       enddo ! i
4245       do i=1,nct
4246         do j=1,3
4247           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4248           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4249           gradx_scp(j,i)=expon*gradx_scp(j,i)
4250         enddo
4251       enddo
4252 C******************************************************************************
4253 C
4254 C                              N O T E !!!
4255 C
4256 C To save time the factor EXPON has been extracted from ALL components
4257 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4258 C use!
4259 C
4260 C******************************************************************************
4261       return
4262       end
4263 C--------------------------------------------------------------------------
4264       subroutine edis(ehpb)
4265 C
4266 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4267 C
4268       implicit real*8 (a-h,o-z)
4269       include 'DIMENSIONS'
4270       include 'COMMON.SBRIDGE'
4271       include 'COMMON.CHAIN'
4272       include 'COMMON.DERIV'
4273       include 'COMMON.VAR'
4274       include 'COMMON.INTERACT'
4275       include 'COMMON.IOUNITS'
4276       dimension ggg(3)
4277       ehpb=0.0D0
4278 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4279 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4280       if (link_end.eq.0) return
4281       do i=link_start,link_end
4282 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4283 C CA-CA distance used in regularization of structure.
4284         ii=ihpb(i)
4285         jj=jhpb(i)
4286 C iii and jjj point to the residues for which the distance is assigned.
4287         if (ii.gt.nres) then
4288           iii=ii-nres
4289           jjj=jj-nres
4290         else
4291           iii=ii
4292           jjj=jj
4293         endif
4294 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4295 c     &    dhpb(i),dhpb1(i),forcon(i)
4296 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4297 C    distance and angle dependent SS bond potential.
4298 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4299 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4300         if (.not.dyn_ss .and. i.le.nss) then
4301 C 15/02/13 CC dynamic SSbond - additional check
4302          if (ii.gt.nres
4303      &       .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4304           call ssbond_ene(iii,jjj,eij)
4305           ehpb=ehpb+2*eij
4306          endif
4307 cd          write (iout,*) "eij",eij
4308         else if (ii.gt.nres .and. jj.gt.nres) then
4309 c Restraints from contact prediction
4310           dd=dist(ii,jj)
4311           if (dhpb1(i).gt.0.0d0) then
4312             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4313             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4314 c            write (iout,*) "beta nmr",
4315 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4316           else
4317             dd=dist(ii,jj)
4318             rdis=dd-dhpb(i)
4319 C Get the force constant corresponding to this distance.
4320             waga=forcon(i)
4321 C Calculate the contribution to energy.
4322             ehpb=ehpb+waga*rdis*rdis
4323 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
4324 C
4325 C Evaluate gradient.
4326 C
4327             fac=waga*rdis/dd
4328           endif
4329           do j=1,3
4330             ggg(j)=fac*(c(j,jj)-c(j,ii))
4331           enddo
4332           do j=1,3
4333             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4334             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4335           enddo
4336           do k=1,3
4337             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4338             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4339           enddo
4340         else
4341 C Calculate the distance between the two points and its difference from the
4342 C target distance.
4343           dd=dist(ii,jj)
4344           if (dhpb1(i).gt.0.0d0) then
4345             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4346             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4347 c            write (iout,*) "alph nmr",
4348 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4349           else
4350             rdis=dd-dhpb(i)
4351 C Get the force constant corresponding to this distance.
4352             waga=forcon(i)
4353 C Calculate the contribution to energy.
4354             ehpb=ehpb+waga*rdis*rdis
4355 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
4356 C
4357 C Evaluate gradient.
4358 C
4359             fac=waga*rdis/dd
4360           endif
4361 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4362 cd   &   ' waga=',waga,' fac=',fac
4363             do j=1,3
4364               ggg(j)=fac*(c(j,jj)-c(j,ii))
4365             enddo
4366 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4367 C If this is a SC-SC distance, we need to calculate the contributions to the
4368 C Cartesian gradient in the SC vectors (ghpbx).
4369           if (iii.lt.ii) then
4370           do j=1,3
4371             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4372             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4373           enddo
4374           endif
4375 cgrad        do j=iii,jjj-1
4376 cgrad          do k=1,3
4377 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4378 cgrad          enddo
4379 cgrad        enddo
4380           do k=1,3
4381             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4382             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4383           enddo
4384         endif
4385       enddo
4386       ehpb=0.5D0*ehpb
4387       return
4388       end
4389 C--------------------------------------------------------------------------
4390       subroutine ssbond_ene(i,j,eij)
4391 C
4392 C Calculate the distance and angle dependent SS-bond potential energy
4393 C using a free-energy function derived based on RHF/6-31G** ab initio
4394 C calculations of diethyl disulfide.
4395 C
4396 C A. Liwo and U. Kozlowska, 11/24/03
4397 C
4398       implicit real*8 (a-h,o-z)
4399       include 'DIMENSIONS'
4400       include 'COMMON.SBRIDGE'
4401       include 'COMMON.CHAIN'
4402       include 'COMMON.DERIV'
4403       include 'COMMON.LOCAL'
4404       include 'COMMON.INTERACT'
4405       include 'COMMON.VAR'
4406       include 'COMMON.IOUNITS'
4407       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4408       itypi=itype(i)
4409       xi=c(1,nres+i)
4410       yi=c(2,nres+i)
4411       zi=c(3,nres+i)
4412       dxi=dc_norm(1,nres+i)
4413       dyi=dc_norm(2,nres+i)
4414       dzi=dc_norm(3,nres+i)
4415 c      dsci_inv=dsc_inv(itypi)
4416       dsci_inv=vbld_inv(nres+i)
4417       itypj=itype(j)
4418 c      dscj_inv=dsc_inv(itypj)
4419       dscj_inv=vbld_inv(nres+j)
4420       xj=c(1,nres+j)-xi
4421       yj=c(2,nres+j)-yi
4422       zj=c(3,nres+j)-zi
4423       dxj=dc_norm(1,nres+j)
4424       dyj=dc_norm(2,nres+j)
4425       dzj=dc_norm(3,nres+j)
4426       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4427       rij=dsqrt(rrij)
4428       erij(1)=xj*rij
4429       erij(2)=yj*rij
4430       erij(3)=zj*rij
4431       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4432       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4433       om12=dxi*dxj+dyi*dyj+dzi*dzj
4434       do k=1,3
4435         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4436         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4437       enddo
4438       rij=1.0d0/rij
4439       deltad=rij-d0cm
4440       deltat1=1.0d0-om1
4441       deltat2=1.0d0+om2
4442       deltat12=om2-om1+2.0d0
4443       cosphi=om12-om1*om2
4444       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4445      &  +akct*deltad*deltat12+ebr
4446      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4447 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4448 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4449 c     &  " deltat12",deltat12," eij",eij
4450       ed=2*akcm*deltad+akct*deltat12
4451       pom1=akct*deltad
4452       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4453       eom1=-2*akth*deltat1-pom1-om2*pom2
4454       eom2= 2*akth*deltat2+pom1-om1*pom2
4455       eom12=pom2
4456       do k=1,3
4457         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4458         ghpbx(k,i)=ghpbx(k,i)-ggk
4459      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4460      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4461         ghpbx(k,j)=ghpbx(k,j)+ggk
4462      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4463      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4464         ghpbc(k,i)=ghpbc(k,i)-ggk
4465         ghpbc(k,j)=ghpbc(k,j)+ggk
4466       enddo
4467 C
4468 C Calculate the components of the gradient in DC and X
4469 C
4470 cgrad      do k=i,j-1
4471 cgrad        do l=1,3
4472 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4473 cgrad        enddo
4474 cgrad      enddo
4475       return
4476       end
4477 C--------------------------------------------------------------------------
4478       subroutine ebond(estr)
4479 c
4480 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4481 c
4482       implicit real*8 (a-h,o-z)
4483       include 'DIMENSIONS'
4484       include 'COMMON.LOCAL'
4485       include 'COMMON.GEO'
4486       include 'COMMON.INTERACT'
4487       include 'COMMON.DERIV'
4488       include 'COMMON.VAR'
4489       include 'COMMON.CHAIN'
4490       include 'COMMON.IOUNITS'
4491       include 'COMMON.NAMES'
4492       include 'COMMON.FFIELD'
4493       include 'COMMON.CONTROL'
4494       include 'COMMON.SETUP'
4495       double precision u(3),ud(3)
4496       estr=0.0d0
4497       do i=ibondp_start,ibondp_end
4498         diff = vbld(i)-vbldp0
4499 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4500         estr=estr+diff*diff
4501         do j=1,3
4502           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4503         enddo
4504 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4505       enddo
4506       estr=0.5d0*AKP*estr
4507 c
4508 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4509 c
4510       do i=ibond_start,ibond_end
4511         iti=itype(i)
4512         if (iti.ne.10) then
4513           nbi=nbondterm(iti)
4514           if (nbi.eq.1) then
4515             diff=vbld(i+nres)-vbldsc0(1,iti)
4516 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4517 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4518             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4519             do j=1,3
4520               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4521             enddo
4522           else
4523             do j=1,nbi
4524               diff=vbld(i+nres)-vbldsc0(j,iti)
4525               ud(j)=aksc(j,iti)*diff
4526               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4527             enddo
4528             uprod=u(1)
4529             do j=2,nbi
4530               uprod=uprod*u(j)
4531             enddo
4532             usum=0.0d0
4533             usumsqder=0.0d0
4534             do j=1,nbi
4535               uprod1=1.0d0
4536               uprod2=1.0d0
4537               do k=1,nbi
4538                 if (k.ne.j) then
4539                   uprod1=uprod1*u(k)
4540                   uprod2=uprod2*u(k)*u(k)
4541                 endif
4542               enddo
4543               usum=usum+uprod1
4544               usumsqder=usumsqder+ud(j)*uprod2
4545             enddo
4546             estr=estr+uprod/usum
4547             do j=1,3
4548              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4549             enddo
4550           endif
4551         endif
4552       enddo
4553       return
4554       end
4555 #ifdef CRYST_THETA
4556 C--------------------------------------------------------------------------
4557       subroutine ebend(etheta)
4558 C
4559 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4560 C angles gamma and its derivatives in consecutive thetas and gammas.
4561 C
4562       implicit real*8 (a-h,o-z)
4563       include 'DIMENSIONS'
4564       include 'COMMON.LOCAL'
4565       include 'COMMON.GEO'
4566       include 'COMMON.INTERACT'
4567       include 'COMMON.DERIV'
4568       include 'COMMON.VAR'
4569       include 'COMMON.CHAIN'
4570       include 'COMMON.IOUNITS'
4571       include 'COMMON.NAMES'
4572       include 'COMMON.FFIELD'
4573       include 'COMMON.CONTROL'
4574       common /calcthet/ term1,term2,termm,diffak,ratak,
4575      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4576      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4577       double precision y(2),z(2)
4578       delta=0.02d0*pi
4579 c      time11=dexp(-2*time)
4580 c      time12=1.0d0
4581       etheta=0.0D0
4582 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4583       do i=ithet_start,ithet_end
4584 C Zero the energy function and its derivative at 0 or pi.
4585         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4586         it=itype(i-1)
4587         if (i.gt.3) then
4588 #ifdef OSF
4589           phii=phi(i)
4590           if (phii.ne.phii) phii=150.0
4591 #else
4592           phii=phi(i)
4593 #endif
4594           y(1)=dcos(phii)
4595           y(2)=dsin(phii)
4596         else
4597           y(1)=0.0D0
4598           y(2)=0.0D0
4599         endif
4600         if (i.lt.nres) then
4601 #ifdef OSF
4602           phii1=phi(i+1)
4603           if (phii1.ne.phii1) phii1=150.0
4604           phii1=pinorm(phii1)
4605           z(1)=cos(phii1)
4606 #else
4607           phii1=phi(i+1)
4608           z(1)=dcos(phii1)
4609 #endif
4610           z(2)=dsin(phii1)
4611         else
4612           z(1)=0.0D0
4613           z(2)=0.0D0
4614         endif
4615 C Calculate the "mean" value of theta from the part of the distribution
4616 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4617 C In following comments this theta will be referred to as t_c.
4618         thet_pred_mean=0.0d0
4619         do k=1,2
4620           athetk=athet(k,it)
4621           bthetk=bthet(k,it)
4622           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4623         enddo
4624         dthett=thet_pred_mean*ssd
4625         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4626 C Derivatives of the "mean" values in gamma1 and gamma2.
4627         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
4628         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
4629         if (theta(i).gt.pi-delta) then
4630           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4631      &         E_tc0)
4632           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4633           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4634           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4635      &        E_theta)
4636           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4637      &        E_tc)
4638         else if (theta(i).lt.delta) then
4639           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4640           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4641           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4642      &        E_theta)
4643           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4644           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4645      &        E_tc)
4646         else
4647           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4648      &        E_theta,E_tc)
4649         endif
4650         etheta=etheta+ethetai
4651         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4652      &      'ebend',i,ethetai
4653         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4654         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4655         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
4656       enddo
4657 C Ufff.... We've done all this!!!
4658       return
4659       end
4660 C---------------------------------------------------------------------------
4661       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4662      &     E_tc)
4663       implicit real*8 (a-h,o-z)
4664       include 'DIMENSIONS'
4665       include 'COMMON.LOCAL'
4666       include 'COMMON.IOUNITS'
4667       common /calcthet/ term1,term2,termm,diffak,ratak,
4668      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4669      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4670 C Calculate the contributions to both Gaussian lobes.
4671 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4672 C The "polynomial part" of the "standard deviation" of this part of
4673 C the distribution.
4674         sig=polthet(3,it)
4675         do j=2,0,-1
4676           sig=sig*thet_pred_mean+polthet(j,it)
4677         enddo
4678 C Derivative of the "interior part" of the "standard deviation of the"
4679 C gamma-dependent Gaussian lobe in t_c.
4680         sigtc=3*polthet(3,it)
4681         do j=2,1,-1
4682           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4683         enddo
4684         sigtc=sig*sigtc
4685 C Set the parameters of both Gaussian lobes of the distribution.
4686 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4687         fac=sig*sig+sigc0(it)
4688         sigcsq=fac+fac
4689         sigc=1.0D0/sigcsq
4690 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4691         sigsqtc=-4.0D0*sigcsq*sigtc
4692 c       print *,i,sig,sigtc,sigsqtc
4693 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4694         sigtc=-sigtc/(fac*fac)
4695 C Following variable is sigma(t_c)**(-2)
4696         sigcsq=sigcsq*sigcsq
4697         sig0i=sig0(it)
4698         sig0inv=1.0D0/sig0i**2
4699         delthec=thetai-thet_pred_mean
4700         delthe0=thetai-theta0i
4701         term1=-0.5D0*sigcsq*delthec*delthec
4702         term2=-0.5D0*sig0inv*delthe0*delthe0
4703 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4704 C NaNs in taking the logarithm. We extract the largest exponent which is added
4705 C to the energy (this being the log of the distribution) at the end of energy
4706 C term evaluation for this virtual-bond angle.
4707         if (term1.gt.term2) then
4708           termm=term1
4709           term2=dexp(term2-termm)
4710           term1=1.0d0
4711         else
4712           termm=term2
4713           term1=dexp(term1-termm)
4714           term2=1.0d0
4715         endif
4716 C The ratio between the gamma-independent and gamma-dependent lobes of
4717 C the distribution is a Gaussian function of thet_pred_mean too.
4718         diffak=gthet(2,it)-thet_pred_mean
4719         ratak=diffak/gthet(3,it)**2
4720         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4721 C Let's differentiate it in thet_pred_mean NOW.
4722         aktc=ak*ratak
4723 C Now put together the distribution terms to make complete distribution.
4724         termexp=term1+ak*term2
4725         termpre=sigc+ak*sig0i
4726 C Contribution of the bending energy from this theta is just the -log of
4727 C the sum of the contributions from the two lobes and the pre-exponential
4728 C factor. Simple enough, isn't it?
4729         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4730 C NOW the derivatives!!!
4731 C 6/6/97 Take into account the deformation.
4732         E_theta=(delthec*sigcsq*term1
4733      &       +ak*delthe0*sig0inv*term2)/termexp
4734         E_tc=((sigtc+aktc*sig0i)/termpre
4735      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4736      &       aktc*term2)/termexp)
4737       return
4738       end
4739 c-----------------------------------------------------------------------------
4740       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4741       implicit real*8 (a-h,o-z)
4742       include 'DIMENSIONS'
4743       include 'COMMON.LOCAL'
4744       include 'COMMON.IOUNITS'
4745       common /calcthet/ term1,term2,termm,diffak,ratak,
4746      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4747      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4748       delthec=thetai-thet_pred_mean
4749       delthe0=thetai-theta0i
4750 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4751       t3 = thetai-thet_pred_mean
4752       t6 = t3**2
4753       t9 = term1
4754       t12 = t3*sigcsq
4755       t14 = t12+t6*sigsqtc
4756       t16 = 1.0d0
4757       t21 = thetai-theta0i
4758       t23 = t21**2
4759       t26 = term2
4760       t27 = t21*t26
4761       t32 = termexp
4762       t40 = t32**2
4763       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4764      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4765      & *(-t12*t9-ak*sig0inv*t27)
4766       return
4767       end
4768 #else
4769 C--------------------------------------------------------------------------
4770       subroutine ebend(etheta)
4771 C
4772 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4773 C angles gamma and its derivatives in consecutive thetas and gammas.
4774 C ab initio-derived potentials from
4775 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4776 C
4777       implicit real*8 (a-h,o-z)
4778       include 'DIMENSIONS'
4779       include 'COMMON.LOCAL'
4780       include 'COMMON.GEO'
4781       include 'COMMON.INTERACT'
4782       include 'COMMON.DERIV'
4783       include 'COMMON.VAR'
4784       include 'COMMON.CHAIN'
4785       include 'COMMON.IOUNITS'
4786       include 'COMMON.NAMES'
4787       include 'COMMON.FFIELD'
4788       include 'COMMON.CONTROL'
4789       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4790      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4791      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4792      & sinph1ph2(maxdouble,maxdouble)
4793       logical lprn /.false./, lprn1 /.false./
4794       etheta=0.0D0
4795       do i=ithet_start,ithet_end
4796         dethetai=0.0d0
4797         dephii=0.0d0
4798         dephii1=0.0d0
4799         theti2=0.5d0*theta(i)
4800         ityp2=ithetyp(itype(i-1))
4801         do k=1,nntheterm
4802           coskt(k)=dcos(k*theti2)
4803           sinkt(k)=dsin(k*theti2)
4804         enddo
4805         if (i.gt.3) then
4806 #ifdef OSF
4807           phii=phi(i)
4808           if (phii.ne.phii) phii=150.0
4809 #else
4810           phii=phi(i)
4811 #endif
4812           ityp1=ithetyp(itype(i-2))
4813           do k=1,nsingle
4814             cosph1(k)=dcos(k*phii)
4815             sinph1(k)=dsin(k*phii)
4816           enddo
4817         else
4818           phii=0.0d0
4819           ityp1=nthetyp+1
4820           do k=1,nsingle
4821             cosph1(k)=0.0d0
4822             sinph1(k)=0.0d0
4823           enddo
4824         endif
4825         if (i.lt.nres) then
4826 #ifdef OSF
4827           phii1=phi(i+1)
4828           if (phii1.ne.phii1) phii1=150.0
4829           phii1=pinorm(phii1)
4830 #else
4831           phii1=phi(i+1)
4832 #endif
4833           ityp3=ithetyp(itype(i))
4834           do k=1,nsingle
4835             cosph2(k)=dcos(k*phii1)
4836             sinph2(k)=dsin(k*phii1)
4837           enddo
4838         else
4839           phii1=0.0d0
4840           ityp3=nthetyp+1
4841           do k=1,nsingle
4842             cosph2(k)=0.0d0
4843             sinph2(k)=0.0d0
4844           enddo
4845         endif
4846         ethetai=aa0thet(ityp1,ityp2,ityp3)
4847         do k=1,ndouble
4848           do l=1,k-1
4849             ccl=cosph1(l)*cosph2(k-l)
4850             ssl=sinph1(l)*sinph2(k-l)
4851             scl=sinph1(l)*cosph2(k-l)
4852             csl=cosph1(l)*sinph2(k-l)
4853             cosph1ph2(l,k)=ccl-ssl
4854             cosph1ph2(k,l)=ccl+ssl
4855             sinph1ph2(l,k)=scl+csl
4856             sinph1ph2(k,l)=scl-csl
4857           enddo
4858         enddo
4859         if (lprn) then
4860         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4861      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4862         write (iout,*) "coskt and sinkt"
4863         do k=1,nntheterm
4864           write (iout,*) k,coskt(k),sinkt(k)
4865         enddo
4866         endif
4867         do k=1,ntheterm
4868           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4869           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4870      &      *coskt(k)
4871           if (lprn)
4872      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4873      &     " ethetai",ethetai
4874         enddo
4875         if (lprn) then
4876         write (iout,*) "cosph and sinph"
4877         do k=1,nsingle
4878           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4879         enddo
4880         write (iout,*) "cosph1ph2 and sinph2ph2"
4881         do k=2,ndouble
4882           do l=1,k-1
4883             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4884      &         sinph1ph2(l,k),sinph1ph2(k,l)
4885           enddo
4886         enddo
4887         write(iout,*) "ethetai",ethetai
4888         endif
4889         do m=1,ntheterm2
4890           do k=1,nsingle
4891             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4892      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4893      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4894      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4895             ethetai=ethetai+sinkt(m)*aux
4896             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4897             dephii=dephii+k*sinkt(m)*(
4898      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4899      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4900             dephii1=dephii1+k*sinkt(m)*(
4901      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4902      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4903             if (lprn)
4904      &      write (iout,*) "m",m," k",k," bbthet",
4905      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4906      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4907      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4908      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4909           enddo
4910         enddo
4911         if (lprn)
4912      &  write(iout,*) "ethetai",ethetai
4913         do m=1,ntheterm3
4914           do k=2,ndouble
4915             do l=1,k-1
4916               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4917      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4918      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4919      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4920               ethetai=ethetai+sinkt(m)*aux
4921               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4922               dephii=dephii+l*sinkt(m)*(
4923      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4924      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4925      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4926      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4927               dephii1=dephii1+(k-l)*sinkt(m)*(
4928      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4929      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4930      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
4931      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4932               if (lprn) then
4933               write (iout,*) "m",m," k",k," l",l," ffthet",
4934      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
4935      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
4936      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
4937      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4938               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4939      &            cosph1ph2(k,l)*sinkt(m),
4940      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4941               endif
4942             enddo
4943           enddo
4944         enddo
4945 10      continue
4946 c        lprn1=.true.
4947         if (lprn1) write (iout,'(a4,i2,3f8.1,9h ethetai ,f10.5)')
4948      &  'ebe', i,theta(i)*rad2deg,phii*rad2deg,
4949      &   phii1*rad2deg,ethetai
4950 c        lprn1=.false.
4951         etheta=etheta+ethetai
4952         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4953         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4954         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
4955       enddo
4956       return
4957       end
4958 #endif
4959 #ifdef CRYST_SC
4960 c-----------------------------------------------------------------------------
4961       subroutine esc(escloc)
4962 C Calculate the local energy of a side chain and its derivatives in the
4963 C corresponding virtual-bond valence angles THETA and the spherical angles
4964 C ALPHA and OMEGA.
4965       implicit real*8 (a-h,o-z)
4966       include 'DIMENSIONS'
4967       include 'COMMON.GEO'
4968       include 'COMMON.LOCAL'
4969       include 'COMMON.VAR'
4970       include 'COMMON.INTERACT'
4971       include 'COMMON.DERIV'
4972       include 'COMMON.CHAIN'
4973       include 'COMMON.IOUNITS'
4974       include 'COMMON.NAMES'
4975       include 'COMMON.FFIELD'
4976       include 'COMMON.CONTROL'
4977       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4978      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4979       common /sccalc/ time11,time12,time112,theti,it,nlobit
4980       delta=0.02d0*pi
4981       escloc=0.0D0
4982 c     write (iout,'(a)') 'ESC'
4983       do i=loc_start,loc_end
4984         it=itype(i)
4985         if (it.eq.10) goto 1
4986         nlobit=nlob(it)
4987 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4988 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4989         theti=theta(i+1)-pipol
4990         x(1)=dtan(theti)
4991         x(2)=alph(i)
4992         x(3)=omeg(i)
4993
4994         if (x(2).gt.pi-delta) then
4995           xtemp(1)=x(1)
4996           xtemp(2)=pi-delta
4997           xtemp(3)=x(3)
4998           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4999           xtemp(2)=pi
5000           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5001           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5002      &        escloci,dersc(2))
5003           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5004      &        ddersc0(1),dersc(1))
5005           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5006      &        ddersc0(3),dersc(3))
5007           xtemp(2)=pi-delta
5008           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5009           xtemp(2)=pi
5010           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5011           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5012      &            dersc0(2),esclocbi,dersc02)
5013           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5014      &            dersc12,dersc01)
5015           call splinthet(x(2),0.5d0*delta,ss,ssd)
5016           dersc0(1)=dersc01
5017           dersc0(2)=dersc02
5018           dersc0(3)=0.0d0
5019           do k=1,3
5020             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5021           enddo
5022           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5023 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5024 c    &             esclocbi,ss,ssd
5025           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5026 c         escloci=esclocbi
5027 c         write (iout,*) escloci
5028         else if (x(2).lt.delta) then
5029           xtemp(1)=x(1)
5030           xtemp(2)=delta
5031           xtemp(3)=x(3)
5032           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5033           xtemp(2)=0.0d0
5034           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5035           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5036      &        escloci,dersc(2))
5037           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5038      &        ddersc0(1),dersc(1))
5039           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5040      &        ddersc0(3),dersc(3))
5041           xtemp(2)=delta
5042           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5043           xtemp(2)=0.0d0
5044           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5045           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5046      &            dersc0(2),esclocbi,dersc02)
5047           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5048      &            dersc12,dersc01)
5049           dersc0(1)=dersc01
5050           dersc0(2)=dersc02
5051           dersc0(3)=0.0d0
5052           call splinthet(x(2),0.5d0*delta,ss,ssd)
5053           do k=1,3
5054             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5055           enddo
5056           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5057 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5058 c    &             esclocbi,ss,ssd
5059           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5060 c         write (iout,*) escloci
5061         else
5062           call enesc(x,escloci,dersc,ddummy,.false.)
5063         endif
5064
5065         escloc=escloc+escloci
5066         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5067      &     'escloc',i,escloci
5068 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5069
5070         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5071      &   wscloc*dersc(1)
5072         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5073         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5074     1   continue
5075       enddo
5076       return
5077       end
5078 C---------------------------------------------------------------------------
5079       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5080       implicit real*8 (a-h,o-z)
5081       include 'DIMENSIONS'
5082       include 'COMMON.GEO'
5083       include 'COMMON.LOCAL'
5084       include 'COMMON.IOUNITS'
5085       common /sccalc/ time11,time12,time112,theti,it,nlobit
5086       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5087       double precision contr(maxlob,-1:1)
5088       logical mixed
5089 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5090         escloc_i=0.0D0
5091         do j=1,3
5092           dersc(j)=0.0D0
5093           if (mixed) ddersc(j)=0.0d0
5094         enddo
5095         x3=x(3)
5096
5097 C Because of periodicity of the dependence of the SC energy in omega we have
5098 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5099 C To avoid underflows, first compute & store the exponents.
5100
5101         do iii=-1,1
5102
5103           x(3)=x3+iii*dwapi
5104
5105           do j=1,nlobit
5106             do k=1,3
5107               z(k)=x(k)-censc(k,j,it)
5108             enddo
5109             do k=1,3
5110               Axk=0.0D0
5111               do l=1,3
5112                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5113               enddo
5114               Ax(k,j,iii)=Axk
5115             enddo
5116             expfac=0.0D0
5117             do k=1,3
5118               expfac=expfac+Ax(k,j,iii)*z(k)
5119             enddo
5120             contr(j,iii)=expfac
5121           enddo ! j
5122
5123         enddo ! iii
5124
5125         x(3)=x3
5126 C As in the case of ebend, we want to avoid underflows in exponentiation and
5127 C subsequent NaNs and INFs in energy calculation.
5128 C Find the largest exponent
5129         emin=contr(1,-1)
5130         do iii=-1,1
5131           do j=1,nlobit
5132             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5133           enddo
5134         enddo
5135         emin=0.5D0*emin
5136 cd      print *,'it=',it,' emin=',emin
5137
5138 C Compute the contribution to SC energy and derivatives
5139         do iii=-1,1
5140
5141           do j=1,nlobit
5142 #ifdef OSF
5143             adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin
5144             if(adexp.ne.adexp) adexp=1.0
5145             expfac=dexp(adexp)
5146 #else
5147             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
5148 #endif
5149 cd          print *,'j=',j,' expfac=',expfac
5150             escloc_i=escloc_i+expfac
5151             do k=1,3
5152               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5153             enddo
5154             if (mixed) then
5155               do k=1,3,2
5156                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5157      &            +gaussc(k,2,j,it))*expfac
5158               enddo
5159             endif
5160           enddo
5161
5162         enddo ! iii
5163
5164         dersc(1)=dersc(1)/cos(theti)**2
5165         ddersc(1)=ddersc(1)/cos(theti)**2
5166         ddersc(3)=ddersc(3)
5167
5168         escloci=-(dlog(escloc_i)-emin)
5169         do j=1,3
5170           dersc(j)=dersc(j)/escloc_i
5171         enddo
5172         if (mixed) then
5173           do j=1,3,2
5174             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5175           enddo
5176         endif
5177       return
5178       end
5179 C------------------------------------------------------------------------------
5180       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5181       implicit real*8 (a-h,o-z)
5182       include 'DIMENSIONS'
5183       include 'COMMON.GEO'
5184       include 'COMMON.LOCAL'
5185       include 'COMMON.IOUNITS'
5186       common /sccalc/ time11,time12,time112,theti,it,nlobit
5187       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5188       double precision contr(maxlob)
5189       logical mixed
5190
5191       escloc_i=0.0D0
5192
5193       do j=1,3
5194         dersc(j)=0.0D0
5195       enddo
5196
5197       do j=1,nlobit
5198         do k=1,2
5199           z(k)=x(k)-censc(k,j,it)
5200         enddo
5201         z(3)=dwapi
5202         do k=1,3
5203           Axk=0.0D0
5204           do l=1,3
5205             Axk=Axk+gaussc(l,k,j,it)*z(l)
5206           enddo
5207           Ax(k,j)=Axk
5208         enddo
5209         expfac=0.0D0
5210         do k=1,3
5211           expfac=expfac+Ax(k,j)*z(k)
5212         enddo
5213         contr(j)=expfac
5214       enddo ! j
5215
5216 C As in the case of ebend, we want to avoid underflows in exponentiation and
5217 C subsequent NaNs and INFs in energy calculation.
5218 C Find the largest exponent
5219       emin=contr(1)
5220       do j=1,nlobit
5221         if (emin.gt.contr(j)) emin=contr(j)
5222       enddo
5223       emin=0.5D0*emin
5224
5225 C Compute the contribution to SC energy and derivatives
5226
5227       dersc12=0.0d0
5228       do j=1,nlobit
5229         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
5230         escloc_i=escloc_i+expfac
5231         do k=1,2
5232           dersc(k)=dersc(k)+Ax(k,j)*expfac
5233         enddo
5234         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5235      &            +gaussc(1,2,j,it))*expfac
5236         dersc(3)=0.0d0
5237       enddo
5238
5239       dersc(1)=dersc(1)/cos(theti)**2
5240       dersc12=dersc12/cos(theti)**2
5241       escloci=-(dlog(escloc_i)-emin)
5242       do j=1,2
5243         dersc(j)=dersc(j)/escloc_i
5244       enddo
5245       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5246       return
5247       end
5248 #else
5249 c----------------------------------------------------------------------------------
5250       subroutine esc(escloc)
5251 C Calculate the local energy of a side chain and its derivatives in the
5252 C corresponding virtual-bond valence angles THETA and the spherical angles
5253 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5254 C added by Urszula Kozlowska. 07/11/2007
5255 C
5256       implicit real*8 (a-h,o-z)
5257       include 'DIMENSIONS'
5258       include 'COMMON.GEO'
5259       include 'COMMON.LOCAL'
5260       include 'COMMON.VAR'
5261       include 'COMMON.SCROT'
5262       include 'COMMON.INTERACT'
5263       include 'COMMON.DERIV'
5264       include 'COMMON.CHAIN'
5265       include 'COMMON.IOUNITS'
5266       include 'COMMON.NAMES'
5267       include 'COMMON.FFIELD'
5268       include 'COMMON.CONTROL'
5269       include 'COMMON.VECTORS'
5270       double precision x_prime(3),y_prime(3),z_prime(3)
5271      &    , sumene,dsc_i,dp2_i,x(65),
5272      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5273      &    de_dxx,de_dyy,de_dzz,de_dt
5274       double precision s1_t,s1_6_t,s2_t,s2_6_t
5275       double precision
5276      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5277      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5278      & dt_dCi(3),dt_dCi1(3)
5279       common /sccalc/ time11,time12,time112,theti,it,nlobit
5280       delta=0.02d0*pi
5281       escloc=0.0D0
5282       do i=loc_start,loc_end
5283         costtab(i+1) =dcos(theta(i+1))
5284         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5285         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5286         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5287         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5288         cosfac=dsqrt(cosfac2)
5289         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5290         sinfac=dsqrt(sinfac2)
5291         it=itype(i)
5292         if (it.eq.10) goto 1
5293 c
5294 C  Compute the axes of tghe local cartesian coordinates system; store in
5295 c   x_prime, y_prime and z_prime
5296 c
5297         do j=1,3
5298           x_prime(j) = 0.00
5299           y_prime(j) = 0.00
5300           z_prime(j) = 0.00
5301         enddo
5302 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5303 C     &   dc_norm(3,i+nres)
5304         do j = 1,3
5305           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5306           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5307         enddo
5308         do j = 1,3
5309           z_prime(j) = -uz(j,i-1)
5310         enddo
5311 c       write (2,*) "i",i
5312 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5313 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5314 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5315 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5316 c      & " xy",scalar(x_prime(1),y_prime(1)),
5317 c      & " xz",scalar(x_prime(1),z_prime(1)),
5318 c      & " yy",scalar(y_prime(1),y_prime(1)),
5319 c      & " yz",scalar(y_prime(1),z_prime(1)),
5320 c      & " zz",scalar(z_prime(1),z_prime(1))
5321 c
5322 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5323 C to local coordinate system. Store in xx, yy, zz.
5324 c
5325         xx=0.0d0
5326         yy=0.0d0
5327         zz=0.0d0
5328         do j = 1,3
5329           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5330           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5331           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5332         enddo
5333
5334         xxtab(i)=xx
5335         yytab(i)=yy
5336         zztab(i)=zz
5337 C
5338 C Compute the energy of the ith side cbain
5339 C
5340 c        write (2,*) "xx",xx," yy",yy," zz",zz
5341         it=itype(i)
5342         do j = 1,65
5343           x(j) = sc_parmin(j,it)
5344         enddo
5345 #ifdef CHECK_COORD
5346 Cc diagnostics - remove later
5347         xx1 = dcos(alph(2))
5348         yy1 = dsin(alph(2))*dcos(omeg(2))
5349         zz1 = -dsin(alph(2))*dsin(omeg(2))
5350         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5351      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5352      &    xx1,yy1,zz1
5353 C,"  --- ", xx_w,yy_w,zz_w
5354 c end diagnostics
5355 #endif
5356         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5357      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5358      &   + x(10)*yy*zz
5359         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5360      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5361      & + x(20)*yy*zz
5362         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5363      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5364      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5365      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5366      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5367      &  +x(40)*xx*yy*zz
5368         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5369      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5370      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5371      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5372      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5373      &  +x(60)*xx*yy*zz
5374         dsc_i   = 0.743d0+x(61)
5375         dp2_i   = 1.9d0+x(62)
5376         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5377      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5378         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5379      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5380         s1=(1+x(63))/(0.1d0 + dscp1)
5381         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5382         s2=(1+x(65))/(0.1d0 + dscp2)
5383         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5384         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5385      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5386 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5387 c     &   sumene4,
5388 c     &   dscp1,dscp2,sumene
5389 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5390         escloc = escloc + sumene
5391 c        write (2,*) "i",i," escloc",sumene,escloc
5392 #ifdef DEBUG
5393 C
5394 C This section to check the numerical derivatives of the energy of ith side
5395 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5396 C #define DEBUG in the code to turn it on.
5397 C
5398         write (2,*) "sumene               =",sumene
5399         aincr=1.0d-7
5400         xxsave=xx
5401         xx=xx+aincr
5402         write (2,*) xx,yy,zz
5403         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5404         de_dxx_num=(sumenep-sumene)/aincr
5405         xx=xxsave
5406         write (2,*) "xx+ sumene from enesc=",sumenep
5407         yysave=yy
5408         yy=yy+aincr
5409         write (2,*) xx,yy,zz
5410         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5411         de_dyy_num=(sumenep-sumene)/aincr
5412         yy=yysave
5413         write (2,*) "yy+ sumene from enesc=",sumenep
5414         zzsave=zz
5415         zz=zz+aincr
5416         write (2,*) xx,yy,zz
5417         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5418         de_dzz_num=(sumenep-sumene)/aincr
5419         zz=zzsave
5420         write (2,*) "zz+ sumene from enesc=",sumenep
5421         costsave=cost2tab(i+1)
5422         sintsave=sint2tab(i+1)
5423         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5424         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5425         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5426         de_dt_num=(sumenep-sumene)/aincr
5427         write (2,*) " t+ sumene from enesc=",sumenep
5428         cost2tab(i+1)=costsave
5429         sint2tab(i+1)=sintsave
5430 C End of diagnostics section.
5431 #endif
5432 C
5433 C Compute the gradient of esc
5434 C
5435         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5436         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5437         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5438         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5439         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5440         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5441         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5442         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5443         pom1=(sumene3*sint2tab(i+1)+sumene1)
5444      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5445         pom2=(sumene4*cost2tab(i+1)+sumene2)
5446      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5447         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5448         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5449      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5450      &  +x(40)*yy*zz
5451         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5452         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5453      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5454      &  +x(60)*yy*zz
5455         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5456      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5457      &        +(pom1+pom2)*pom_dx
5458 #ifdef DEBUG
5459         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5460 #endif
5461 C
5462         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5463         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5464      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5465      &  +x(40)*xx*zz
5466         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5467         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5468      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5469      &  +x(59)*zz**2 +x(60)*xx*zz
5470         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5471      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5472      &        +(pom1-pom2)*pom_dy
5473 #ifdef DEBUG
5474         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5475 #endif
5476 C
5477         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5478      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5479      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5480      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5481      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5482      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5483      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5484      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5485 #ifdef DEBUG
5486         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5487 #endif
5488 C
5489         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5490      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5491      &  +pom1*pom_dt1+pom2*pom_dt2
5492 #ifdef DEBUG
5493         write(2,*), "de_dt = ", de_dt,de_dt_num
5494 #endif
5495 c
5496 C
5497        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5498        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5499        cosfac2xx=cosfac2*xx
5500        sinfac2yy=sinfac2*yy
5501        do k = 1,3
5502          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5503      &      vbld_inv(i+1)
5504          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5505      &      vbld_inv(i)
5506          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5507          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5508 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5509 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5510 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5511 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5512          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5513          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5514          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5515          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5516          dZZ_Ci1(k)=0.0d0
5517          dZZ_Ci(k)=0.0d0
5518          do j=1,3
5519            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5520            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5521          enddo
5522
5523          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5524          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5525          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5526 c
5527          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5528          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5529        enddo
5530
5531        do k=1,3
5532          dXX_Ctab(k,i)=dXX_Ci(k)
5533          dXX_C1tab(k,i)=dXX_Ci1(k)
5534          dYY_Ctab(k,i)=dYY_Ci(k)
5535          dYY_C1tab(k,i)=dYY_Ci1(k)
5536          dZZ_Ctab(k,i)=dZZ_Ci(k)
5537          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5538          dXX_XYZtab(k,i)=dXX_XYZ(k)
5539          dYY_XYZtab(k,i)=dYY_XYZ(k)
5540          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5541        enddo
5542
5543        do k = 1,3
5544 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5545 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5546 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5547 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5548 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5549 c     &    dt_dci(k)
5550 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5551 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5552          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5553      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5554          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5555      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5556          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5557      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5558        enddo
5559 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5560 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5561
5562 C to check gradient call subroutine check_grad
5563
5564     1 continue
5565       enddo
5566       return
5567       end
5568 c------------------------------------------------------------------------------
5569       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5570       implicit none
5571       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5572      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5573       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5574      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5575      &   + x(10)*yy*zz
5576       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5577      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5578      & + x(20)*yy*zz
5579       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5580      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5581      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5582      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5583      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5584      &  +x(40)*xx*yy*zz
5585       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5586      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5587      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5588      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5589      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5590      &  +x(60)*xx*yy*zz
5591       dsc_i   = 0.743d0+x(61)
5592       dp2_i   = 1.9d0+x(62)
5593       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5594      &          *(xx*cost2+yy*sint2))
5595       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5596      &          *(xx*cost2-yy*sint2))
5597       s1=(1+x(63))/(0.1d0 + dscp1)
5598       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5599       s2=(1+x(65))/(0.1d0 + dscp2)
5600       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5601       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5602      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5603       enesc=sumene
5604       return
5605       end
5606 #endif
5607 c------------------------------------------------------------------------------
5608       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5609 C
5610 C This procedure calculates two-body contact function g(rij) and its derivative:
5611 C
5612 C           eps0ij                                     !       x < -1
5613 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5614 C            0                                         !       x > 1
5615 C
5616 C where x=(rij-r0ij)/delta
5617 C
5618 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5619 C
5620       implicit none
5621       double precision rij,r0ij,eps0ij,fcont,fprimcont
5622       double precision x,x2,x4,delta
5623 c     delta=0.02D0*r0ij
5624 c      delta=0.2D0*r0ij
5625       x=(rij-r0ij)/delta
5626       if (x.lt.-1.0D0) then
5627         fcont=eps0ij
5628         fprimcont=0.0D0
5629       else if (x.le.1.0D0) then
5630         x2=x*x
5631         x4=x2*x2
5632         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5633         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5634       else
5635         fcont=0.0D0
5636         fprimcont=0.0D0
5637       endif
5638       return
5639       end
5640 c------------------------------------------------------------------------------
5641       subroutine splinthet(theti,delta,ss,ssder)
5642       implicit real*8 (a-h,o-z)
5643       include 'DIMENSIONS'
5644       include 'COMMON.VAR'
5645       include 'COMMON.GEO'
5646       thetup=pi-delta
5647       thetlow=delta
5648       if (theti.gt.pipol) then
5649         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5650       else
5651         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5652         ssder=-ssder
5653       endif
5654       return
5655       end
5656 c------------------------------------------------------------------------------
5657       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5658       implicit none
5659       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5660       double precision ksi,ksi2,ksi3,a1,a2,a3
5661       a1=fprim0*delta/(f1-f0)
5662       a2=3.0d0-2.0d0*a1
5663       a3=a1-2.0d0
5664       ksi=(x-x0)/delta
5665       ksi2=ksi*ksi
5666       ksi3=ksi2*ksi
5667       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5668       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5669       return
5670       end
5671 c------------------------------------------------------------------------------
5672       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5673       implicit none
5674       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5675       double precision ksi,ksi2,ksi3,a1,a2,a3
5676       ksi=(x-x0)/delta
5677       ksi2=ksi*ksi
5678       ksi3=ksi2*ksi
5679       a1=fprim0x*delta
5680       a2=3*(f1x-f0x)-2*fprim0x*delta
5681       a3=fprim0x*delta-2*(f1x-f0x)
5682       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5683       return
5684       end
5685 C-----------------------------------------------------------------------------
5686 #ifdef CRYST_TOR
5687 C-----------------------------------------------------------------------------
5688       subroutine etor(etors,edihcnstr)
5689       implicit real*8 (a-h,o-z)
5690       include 'DIMENSIONS'
5691       include 'COMMON.VAR'
5692       include 'COMMON.GEO'
5693       include 'COMMON.LOCAL'
5694       include 'COMMON.TORSION'
5695       include 'COMMON.INTERACT'
5696       include 'COMMON.DERIV'
5697       include 'COMMON.CHAIN'
5698       include 'COMMON.NAMES'
5699       include 'COMMON.IOUNITS'
5700       include 'COMMON.FFIELD'
5701       include 'COMMON.TORCNSTR'
5702       include 'COMMON.CONTROL'
5703       logical lprn
5704 C Set lprn=.true. for debugging
5705       lprn=.false.
5706 c      lprn=.true.
5707       etors=0.0D0
5708       do i=iphi_start,iphi_end
5709       etors_ii=0.0D0
5710         itori=itortyp(itype(i-2))
5711         itori1=itortyp(itype(i-1))
5712         phii=phi(i)
5713         gloci=0.0D0
5714 C Proline-Proline pair is a special case...
5715         if (itori.eq.3 .and. itori1.eq.3) then
5716           if (phii.gt.-dwapi3) then
5717             cosphi=dcos(3*phii)
5718             fac=1.0D0/(1.0D0-cosphi)
5719             etorsi=v1(1,3,3)*fac
5720             etorsi=etorsi+etorsi
5721             etors=etors+etorsi-v1(1,3,3)
5722             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5723             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5724           endif
5725           do j=1,3
5726             v1ij=v1(j+1,itori,itori1)
5727             v2ij=v2(j+1,itori,itori1)
5728             cosphi=dcos(j*phii)
5729             sinphi=dsin(j*phii)
5730             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5731             if (energy_dec) etors_ii=etors_ii+
5732      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5733             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5734           enddo
5735         else
5736           do j=1,nterm_old
5737             v1ij=v1(j,itori,itori1)
5738             v2ij=v2(j,itori,itori1)
5739             cosphi=dcos(j*phii)
5740             sinphi=dsin(j*phii)
5741             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5742             if (energy_dec) etors_ii=etors_ii+
5743      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5744             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5745           enddo
5746         endif
5747         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5748      &        'etor',i,etors_ii
5749         if (lprn)
5750      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5751      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5752      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5753         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5754         write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5755       enddo
5756 ! 6/20/98 - dihedral angle constraints
5757       edihcnstr=0.0d0
5758       do i=1,ndih_constr
5759         itori=idih_constr(i)
5760         phii=phi(itori)
5761         difi=phii-phi0(i)
5762         if (difi.gt.drange(i)) then
5763           difi=difi-drange(i)
5764           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5765           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5766         else if (difi.lt.-drange(i)) then
5767           difi=difi+drange(i)
5768           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5769           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5770         endif
5771 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5772 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5773       enddo
5774 !      write (iout,*) 'edihcnstr',edihcnstr
5775       return
5776       end
5777 c------------------------------------------------------------------------------
5778 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
5779       subroutine e_modeller(ehomology_constr)
5780       ehomology_constr=0.0
5781       write (iout,*) "!!!!!UWAGA, JESTEM W DZIWNEJ PETLI, TEST!!!!!"
5782       return
5783       end
5784 C !!!!!!!! NIE CZYTANE !!!!!!!!!!!
5785
5786 c------------------------------------------------------------------------------
5787       subroutine etor_d(etors_d)
5788       etors_d=0.0d0
5789       return
5790       end
5791 c----------------------------------------------------------------------------
5792 #else
5793       subroutine etor(etors,edihcnstr)
5794       implicit real*8 (a-h,o-z)
5795       include 'DIMENSIONS'
5796       include 'COMMON.VAR'
5797       include 'COMMON.GEO'
5798       include 'COMMON.LOCAL'
5799       include 'COMMON.TORSION'
5800       include 'COMMON.INTERACT'
5801       include 'COMMON.DERIV'
5802       include 'COMMON.CHAIN'
5803       include 'COMMON.NAMES'
5804       include 'COMMON.IOUNITS'
5805       include 'COMMON.FFIELD'
5806       include 'COMMON.TORCNSTR'
5807       include 'COMMON.CONTROL'
5808       logical lprn
5809 C Set lprn=.true. for debugging
5810       lprn=.false.
5811 c     lprn=.true.
5812       etors=0.0D0
5813       do i=iphi_start,iphi_end
5814       etors_ii=0.0D0
5815         itori=itortyp(itype(i-2))
5816         itori1=itortyp(itype(i-1))
5817         phii=phi(i)
5818         gloci=0.0D0
5819 C Regular cosine and sine terms
5820         do j=1,nterm(itori,itori1)
5821           v1ij=v1(j,itori,itori1)
5822           v2ij=v2(j,itori,itori1)
5823           cosphi=dcos(j*phii)
5824           sinphi=dsin(j*phii)
5825           etors=etors+v1ij*cosphi+v2ij*sinphi
5826           if (energy_dec) etors_ii=etors_ii+
5827      &                v1ij*cosphi+v2ij*sinphi
5828           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5829         enddo
5830 C Lorentz terms
5831 C                         v1
5832 C  E = SUM ----------------------------------- - v1
5833 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5834 C
5835         cosphi=dcos(0.5d0*phii)
5836         sinphi=dsin(0.5d0*phii)
5837         do j=1,nlor(itori,itori1)
5838           vl1ij=vlor1(j,itori,itori1)
5839           vl2ij=vlor2(j,itori,itori1)
5840           vl3ij=vlor3(j,itori,itori1)
5841           pom=vl2ij*cosphi+vl3ij*sinphi
5842           pom1=1.0d0/(pom*pom+1.0d0)
5843           etors=etors+vl1ij*pom1
5844           if (energy_dec) etors_ii=etors_ii+
5845      &                vl1ij*pom1
5846           pom=-pom*pom1*pom1
5847           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5848         enddo
5849 C Subtract the constant term
5850         etors=etors-v0(itori,itori1)
5851           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5852      &         'etor',i,etors_ii-v0(itori,itori1)
5853         if (lprn)
5854      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5855      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5856      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5857         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5858 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5859       enddo
5860 ! 6/20/98 - dihedral angle constraints
5861       edihcnstr=0.0d0
5862 c      do i=1,ndih_constr
5863       do i=idihconstr_start,idihconstr_end
5864         itori=idih_constr(i)
5865         phii=phi(itori)
5866         difi=pinorm(phii-phi0(i))
5867         if (difi.gt.drange(i)) then
5868           difi=difi-drange(i)
5869           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5870           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5871         else if (difi.lt.-drange(i)) then
5872           difi=difi+drange(i)
5873           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5874           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5875         else
5876           difi=0.0
5877         endif
5878 c        write (iout,*) "gloci", gloc(i-3,icg)
5879 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5880 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5881 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5882       enddo
5883 cd       write (iout,*) 'edihcnstr',edihcnstr
5884       return
5885       end
5886 c----------------------------------------------------------------------------
5887 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
5888       subroutine e_modeller(ehomology_constr)
5889       implicit real*8 (a-h,o-z)
5890
5891       integer nnn, i, j, k, ki, irec, l
5892       integer katy, odleglosci, test7
5893       real*8 odleg, odleg2, odleg3, kat, kat2, kat3
5894       real*8 distance(799,799,19), dih_diff(799,19)
5895       real*8 distancek(19), min_odl(799,799)
5896
5897
5898       include 'DIMENSIONS'
5899       include 'COMMON.SBRIDGE'
5900       include 'COMMON.CHAIN'
5901       include 'COMMON.GEO'
5902       include 'COMMON.DERIV'
5903       include 'COMMON.LOCAL'
5904       include 'COMMON.INTERACT'
5905       include 'COMMON.VAR'
5906       include 'COMMON.IOUNITS'
5907       include 'COMMON.MD'
5908       include 'COMMON.CONTROL'
5909
5910
5911       do i=1,19
5912         distancek(i)=9999999.9
5913       enddo
5914
5915
5916       odleg=0.0
5917       odleg2=0.0
5918       kat=0.0
5919       kat2=0.0
5920
5921 c LICZENIE WKLADU DO ENERGI POCHODZACEGO Z WIEZOW NA ODLEGLOSCI
5922       do i=1, lim_odl-1
5923        do j=i+2, lim_odl+1
5924           do k=1,constr_homology
5925             distance(i,j,k)=(odl(i,j,k)-dist(i+1,j+1))
5926             distancek(k)=waga_dist*((distance(i,j,k)**2)/
5927      &              (2*(sigma_odl(i,j,k))**2))
5928           enddo
5929
5930           min_odl(i,j)=minval(distancek)
5931
5932          do k=1,constr_homology
5933             odleg3=-waga_dist*((distance(i,j,k)**2)/
5934      &              (2*(sigma_odl(i,j,k))**2))
5935             odleg2=odleg2+dexp(odleg3+min_odl(i,j))
5936
5937           write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
5938      & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
5939      & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
5940      & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
5941
5942           enddo
5943           odleg=odleg-dLOG(odleg2/constr_homology)+min_odl(i,j)
5944           write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
5945      & dLOG(odleg2),"-odleg=", -odleg
5946
5947           odleg2=0.0
5948         enddo
5949       enddo
5950
5951 c LICZENIE WKLADU DO ENERGI POCHODZACEGO Z WIEZOW NA KATY W
5952       do i=1, lim_dih
5953         do k=1,constr_homology
5954           dih_diff(i,k)=(dih(i,k)-beta(i+1,i+2,i+3,i+4))
5955           if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
5956      &                                   -(6.28318-dih_diff(i,k))
5957           if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
5958      &                                   6.28318+dih_diff(i,k)
5959
5960           kat3=-waga_angle*((dih_diff(i,k)**2)/
5961      &            (2*(sigma_dih(i,k))**2))
5962 c          write(iout,*) "w(i,k)=",w(i,k),"beta=",beta(i+1,i+2,i+3,i+4)
5963           kat2=kat2+dexp(kat3)
5964 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
5965 c          write(*,*)""
5966         enddo
5967         kat=kat-dLOG(kat2/constr_homology)
5968
5969 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
5970 ccc     & dLOG(kat2), "-kat=", -kat
5971
5972         kat2=0.0
5973       enddo
5974
5975       write(iout,748) "2odleg=", odleg, "kat=", kat,"suma=",odleg+kat
5976
5977
5978
5979 c ----------------------------------------------------------------------
5980 c LICZENIE GRADIENTU
5981 c ----------------------------------------------------------------------
5982
5983       sum_godl=0.0
5984       sum_sgodl=0.0
5985
5986 c GRADIENT DLA ODLEGLOSCI
5987       do i=1, lim_odl-1
5988         do j=i+2, lim_odl+1
5989           do k=1,constr_homology
5990             godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
5991      &           *waga_dist)+min_odl(i,j))
5992             sgodl=godl*((-((distance(i,j,k))/
5993      &              ((sigma_odl(i,j,k))**2)))*waga_dist)
5994
5995             sum_godl=sum_godl+godl
5996             sum_sgodl=sum_sgodl+sgodl
5997
5998 c            sgodl2=sgodl2+sgodl
5999 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
6000 c      write(iout,*) "constr_homology=",constr_homology
6001 c      write(iout,*) i, j, k, "TEST K"
6002           enddo
6003
6004           grad_odl3=((1/sum_godl)*sum_sgodl)
6005      &              /dist(i+1,j+1)
6006           sum_godl=0.0
6007           sum_sgodl=0.0
6008
6009
6010 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
6011 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
6012 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
6013
6014 ccc      write(iout,*) godl, sgodl, grad_odl3
6015
6016 c          grad_odl=grad_odl+grad_odl3
6017
6018           do jik=1,3
6019             ggodl=grad_odl3*(c(jik,i+1)-c(jik,j+1))
6020 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
6021 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
6022 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
6023             ghpbc(jik,i+1)=ghpbc(jik,i+1)+ggodl
6024             ghpbc(jik,j+1)=ghpbc(jik,j+1)-ggodl
6025 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
6026 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
6027
6028           enddo
6029
6030         enddo
6031       enddo
6032
6033
6034 c GRADIENT DLA KATOW
6035       sum_gdih=0.0
6036       sum_sgdih=0.0
6037       do i=1, lim_dih
6038         do k=1,constr_homology
6039           gdih=dexp((-(dih_diff(i,k)**2)/(2*(sigma_dih(i,k))**2))
6040      &         *waga_angle)
6041           sgdih=gdih*((-((dih_diff(i,k))/
6042      &         ((sigma_dih(i,k))**2)))*waga_angle)
6043
6044           sum_gdih=sum_gdih+gdih
6045           sum_sgdih=sum_sgdih+sgdih
6046         enddo
6047           grad_dih3=((1.0/sum_gdih)*sum_sgdih)
6048           sum_gdih=0.0
6049           sum_sgdih=0.0
6050
6051 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
6052 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
6053 ccc     & gloc(nphi+i-3,icg)
6054         gloc(i+1,icg)=gloc(i+1,icg)+grad_dih3
6055 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
6056 ccc     & gloc(nphi+i-3,icg)
6057
6058       enddo
6059
6060
6061 c CALKOWITY WKLAD DO ENERGII WYNIKAJACY Z WIEZOW
6062       ehomology_constr=odleg+kat
6063       return
6064
6065   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
6066   747 format(a12,i4,i4,i4,f8.3,f8.3)
6067   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
6068   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
6069   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
6070      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
6071       end
6072
6073 c------------------------------------------------------------------------------
6074
6075
6076
6077
6078       subroutine etor_d(etors_d)
6079 C 6/23/01 Compute double torsional energy
6080       implicit real*8 (a-h,o-z)
6081       include 'DIMENSIONS'
6082       include 'COMMON.VAR'
6083       include 'COMMON.GEO'
6084       include 'COMMON.LOCAL'
6085       include 'COMMON.TORSION'
6086       include 'COMMON.INTERACT'
6087       include 'COMMON.DERIV'
6088       include 'COMMON.CHAIN'
6089       include 'COMMON.NAMES'
6090       include 'COMMON.IOUNITS'
6091       include 'COMMON.FFIELD'
6092       include 'COMMON.TORCNSTR'
6093       logical lprn
6094 C Set lprn=.true. for debugging
6095       lprn=.false.
6096 c     lprn=.true.
6097       etors_d=0.0D0
6098       do i=iphid_start,iphid_end
6099         itori=itortyp(itype(i-2))
6100         itori1=itortyp(itype(i-1))
6101         itori2=itortyp(itype(i))
6102         phii=phi(i)
6103         phii1=phi(i+1)
6104         gloci1=0.0D0
6105         gloci2=0.0D0
6106         do j=1,ntermd_1(itori,itori1,itori2)
6107           v1cij=v1c(1,j,itori,itori1,itori2)
6108           v1sij=v1s(1,j,itori,itori1,itori2)
6109           v2cij=v1c(2,j,itori,itori1,itori2)
6110           v2sij=v1s(2,j,itori,itori1,itori2)
6111           cosphi1=dcos(j*phii)
6112           sinphi1=dsin(j*phii)
6113           cosphi2=dcos(j*phii1)
6114           sinphi2=dsin(j*phii1)
6115           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
6116      &     v2cij*cosphi2+v2sij*sinphi2
6117           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6118           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6119         enddo
6120         do k=2,ntermd_2(itori,itori1,itori2)
6121           do l=1,k-1
6122             v1cdij = v2c(k,l,itori,itori1,itori2)
6123             v2cdij = v2c(l,k,itori,itori1,itori2)
6124             v1sdij = v2s(k,l,itori,itori1,itori2)
6125             v2sdij = v2s(l,k,itori,itori1,itori2)
6126             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6127             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6128             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6129             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6130             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6131      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6132             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
6133      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6134             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
6135      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6136           enddo
6137         enddo
6138         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
6139         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
6140 c        write (iout,*) "gloci", gloc(i-3,icg)
6141       enddo
6142       return
6143       end
6144 #endif
6145 c------------------------------------------------------------------------------
6146       subroutine eback_sc_corr(esccor)
6147 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6148 c        conformational states; temporarily implemented as differences
6149 c        between UNRES torsional potentials (dependent on three types of
6150 c        residues) and the torsional potentials dependent on all 20 types
6151 c        of residues computed from AM1  energy surfaces of terminally-blocked
6152 c        amino-acid residues.
6153       implicit real*8 (a-h,o-z)
6154       include 'DIMENSIONS'
6155       include 'COMMON.VAR'
6156       include 'COMMON.GEO'
6157       include 'COMMON.LOCAL'
6158       include 'COMMON.TORSION'
6159       include 'COMMON.SCCOR'
6160       include 'COMMON.INTERACT'
6161       include 'COMMON.DERIV'
6162       include 'COMMON.CHAIN'
6163       include 'COMMON.NAMES'
6164       include 'COMMON.IOUNITS'
6165       include 'COMMON.FFIELD'
6166       include 'COMMON.CONTROL'
6167       logical lprn
6168 C Set lprn=.true. for debugging
6169       lprn=.false.
6170 c      lprn=.true.
6171 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
6172       esccor=0.0D0
6173       do i=itau_start,itau_end
6174         esccor_ii=0.0D0
6175         isccori=isccortyp(itype(i-2))
6176         isccori1=isccortyp(itype(i-1))
6177         phii=phi(i)
6178 cccc  Added 9 May 2012
6179 cc Tauangle is torsional engle depending on the value of first digit
6180 c(see comment below)
6181 cc Omicron is flat angle depending on the value of first digit
6182 c(see comment below)
6183
6184
6185         do intertyp=1,3 !intertyp
6186 cc Added 09 May 2012 (Adasko)
6187 cc  Intertyp means interaction type of backbone mainchain correlation:
6188 c   1 = SC...Ca...Ca...Ca
6189 c   2 = Ca...Ca...Ca...SC
6190 c   3 = SC...Ca...Ca...SCi
6191         gloci=0.0D0
6192         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6193      &      (itype(i-1).eq.10).or.(itype(i-2).eq.21).or.
6194      &      (itype(i-1).eq.21)))
6195      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6196      &     .or.(itype(i-2).eq.21)))
6197      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6198      &      (itype(i-1).eq.21)))) cycle
6199         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle
6200         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21))
6201      & cycle
6202         do j=1,nterm_sccor(isccori,isccori1)
6203           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6204           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6205           cosphi=dcos(j*tauangle(intertyp,i))
6206           sinphi=dsin(j*tauangle(intertyp,i))
6207           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6208           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6209         enddo
6210         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6211 c        write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
6212 c     &gloc_sc(intertyp,i-3,icg)
6213         if (lprn)
6214      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6215      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6216      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
6217      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
6218         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6219        enddo !intertyp
6220       enddo
6221 c        do i=1,nres
6222 c        write (iout,*) "W@T@F",  gloc_sc(1,i,icg),gloc(i,icg)
6223 c        enddo
6224       return
6225       end
6226 c----------------------------------------------------------------------------
6227       subroutine multibody(ecorr)
6228 C This subroutine calculates multi-body contributions to energy following
6229 C the idea of Skolnick et al. If side chains I and J make a contact and
6230 C at the same time side chains I+1 and J+1 make a contact, an extra
6231 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6232       implicit real*8 (a-h,o-z)
6233       include 'DIMENSIONS'
6234       include 'COMMON.IOUNITS'
6235       include 'COMMON.DERIV'
6236       include 'COMMON.INTERACT'
6237       include 'COMMON.CONTACTS'
6238       double precision gx(3),gx1(3)
6239       logical lprn
6240
6241 C Set lprn=.true. for debugging
6242       lprn=.false.
6243
6244       if (lprn) then
6245         write (iout,'(a)') 'Contact function values:'
6246         do i=nnt,nct-2
6247           write (iout,'(i2,20(1x,i2,f10.5))')
6248      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6249         enddo
6250       endif
6251       ecorr=0.0D0
6252       do i=nnt,nct
6253         do j=1,3
6254           gradcorr(j,i)=0.0D0
6255           gradxorr(j,i)=0.0D0
6256         enddo
6257       enddo
6258       do i=nnt,nct-2
6259
6260         DO ISHIFT = 3,4
6261
6262         i1=i+ishift
6263         num_conti=num_cont(i)
6264         num_conti1=num_cont(i1)
6265         do jj=1,num_conti
6266           j=jcont(jj,i)
6267           do kk=1,num_conti1
6268             j1=jcont(kk,i1)
6269             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6270 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6271 cd   &                   ' ishift=',ishift
6272 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6273 C The system gains extra energy.
6274               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6275             endif   ! j1==j+-ishift
6276           enddo     ! kk
6277         enddo       ! jj
6278
6279         ENDDO ! ISHIFT
6280
6281       enddo         ! i
6282       return
6283       end
6284 c------------------------------------------------------------------------------
6285       double precision function esccorr(i,j,k,l,jj,kk)
6286       implicit real*8 (a-h,o-z)
6287       include 'DIMENSIONS'
6288       include 'COMMON.IOUNITS'
6289       include 'COMMON.DERIV'
6290       include 'COMMON.INTERACT'
6291       include 'COMMON.CONTACTS'
6292       double precision gx(3),gx1(3)
6293       logical lprn
6294       lprn=.false.
6295       eij=facont(jj,i)
6296       ekl=facont(kk,k)
6297 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6298 C Calculate the multi-body contribution to energy.
6299 C Calculate multi-body contributions to the gradient.
6300 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6301 cd   & k,l,(gacont(m,kk,k),m=1,3)
6302       do m=1,3
6303         gx(m) =ekl*gacont(m,jj,i)
6304         gx1(m)=eij*gacont(m,kk,k)
6305         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6306         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6307         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6308         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6309       enddo
6310       do m=i,j-1
6311         do ll=1,3
6312           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6313         enddo
6314       enddo
6315       do m=k,l-1
6316         do ll=1,3
6317           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6318         enddo
6319       enddo
6320       esccorr=-eij*ekl
6321       return
6322       end
6323 c------------------------------------------------------------------------------
6324       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6325 C This subroutine calculates multi-body contributions to hydrogen-bonding
6326       implicit real*8 (a-h,o-z)
6327       include 'DIMENSIONS'
6328       include 'COMMON.IOUNITS'
6329 #ifdef MPI
6330       include "mpif.h"
6331       parameter (max_cont=maxconts)
6332       parameter (max_dim=26)
6333       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6334       double precision zapas(max_dim,maxconts,max_fg_procs),
6335      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6336       common /przechowalnia/ zapas
6337       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6338      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6339 #endif
6340       include 'COMMON.SETUP'
6341       include 'COMMON.FFIELD'
6342       include 'COMMON.DERIV'
6343       include 'COMMON.INTERACT'
6344       include 'COMMON.CONTACTS'
6345       include 'COMMON.CONTROL'
6346       include 'COMMON.LOCAL'
6347       double precision gx(3),gx1(3),time00
6348       logical lprn,ldone
6349
6350 C Set lprn=.true. for debugging
6351       lprn=.false.
6352 #ifdef MPI
6353       n_corr=0
6354       n_corr1=0
6355       if (nfgtasks.le.1) goto 30
6356       if (lprn) then
6357         write (iout,'(a)') 'Contact function values before RECEIVE:'
6358         do i=nnt,nct-2
6359           write (iout,'(2i3,50(1x,i2,f5.2))')
6360      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6361      &    j=1,num_cont_hb(i))
6362         enddo
6363       endif
6364       call flush(iout)
6365       do i=1,ntask_cont_from
6366         ncont_recv(i)=0
6367       enddo
6368       do i=1,ntask_cont_to
6369         ncont_sent(i)=0
6370       enddo
6371 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6372 c     & ntask_cont_to
6373 C Make the list of contacts to send to send to other procesors
6374 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6375 c      call flush(iout)
6376       do i=iturn3_start,iturn3_end
6377 c        write (iout,*) "make contact list turn3",i," num_cont",
6378 c     &    num_cont_hb(i)
6379         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6380       enddo
6381       do i=iturn4_start,iturn4_end
6382 c        write (iout,*) "make contact list turn4",i," num_cont",
6383 c     &   num_cont_hb(i)
6384         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6385       enddo
6386       do ii=1,nat_sent
6387         i=iat_sent(ii)
6388 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6389 c     &    num_cont_hb(i)
6390         do j=1,num_cont_hb(i)
6391         do k=1,4
6392           jjc=jcont_hb(j,i)
6393           iproc=iint_sent_local(k,jjc,ii)
6394 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6395           if (iproc.gt.0) then
6396             ncont_sent(iproc)=ncont_sent(iproc)+1
6397             nn=ncont_sent(iproc)
6398             zapas(1,nn,iproc)=i
6399             zapas(2,nn,iproc)=jjc
6400             zapas(3,nn,iproc)=facont_hb(j,i)
6401             zapas(4,nn,iproc)=ees0p(j,i)
6402             zapas(5,nn,iproc)=ees0m(j,i)
6403             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6404             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6405             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6406             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6407             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6408             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6409             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6410             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6411             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6412             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6413             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6414             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6415             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6416             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6417             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6418             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6419             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6420             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6421             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6422             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6423             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6424           endif
6425         enddo
6426         enddo
6427       enddo
6428       if (lprn) then
6429       write (iout,*)
6430      &  "Numbers of contacts to be sent to other processors",
6431      &  (ncont_sent(i),i=1,ntask_cont_to)
6432       write (iout,*) "Contacts sent"
6433       do ii=1,ntask_cont_to
6434         nn=ncont_sent(ii)
6435         iproc=itask_cont_to(ii)
6436         write (iout,*) nn," contacts to processor",iproc,
6437      &   " of CONT_TO_COMM group"
6438         do i=1,nn
6439           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6440         enddo
6441       enddo
6442       call flush(iout)
6443       endif
6444       CorrelType=477
6445       CorrelID=fg_rank+1
6446       CorrelType1=478
6447       CorrelID1=nfgtasks+fg_rank+1
6448       ireq=0
6449 C Receive the numbers of needed contacts from other processors
6450       do ii=1,ntask_cont_from
6451         iproc=itask_cont_from(ii)
6452         ireq=ireq+1
6453         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6454      &    FG_COMM,req(ireq),IERR)
6455       enddo
6456 c      write (iout,*) "IRECV ended"
6457 c      call flush(iout)
6458 C Send the number of contacts needed by other processors
6459       do ii=1,ntask_cont_to
6460         iproc=itask_cont_to(ii)
6461         ireq=ireq+1
6462         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6463      &    FG_COMM,req(ireq),IERR)
6464       enddo
6465 c      write (iout,*) "ISEND ended"
6466 c      write (iout,*) "number of requests (nn)",ireq
6467       call flush(iout)
6468       if (ireq.gt.0)
6469      &  call MPI_Waitall(ireq,req,status_array,ierr)
6470 c      write (iout,*)
6471 c     &  "Numbers of contacts to be received from other processors",
6472 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6473 c      call flush(iout)
6474 C Receive contacts
6475       ireq=0
6476       do ii=1,ntask_cont_from
6477         iproc=itask_cont_from(ii)
6478         nn=ncont_recv(ii)
6479 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6480 c     &   " of CONT_TO_COMM group"
6481         call flush(iout)
6482         if (nn.gt.0) then
6483           ireq=ireq+1
6484           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6485      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6486 c          write (iout,*) "ireq,req",ireq,req(ireq)
6487         endif
6488       enddo
6489 C Send the contacts to processors that need them
6490       do ii=1,ntask_cont_to
6491         iproc=itask_cont_to(ii)
6492         nn=ncont_sent(ii)
6493 c        write (iout,*) nn," contacts to processor",iproc,
6494 c     &   " of CONT_TO_COMM group"
6495         if (nn.gt.0) then
6496           ireq=ireq+1
6497           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6498      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6499 c          write (iout,*) "ireq,req",ireq,req(ireq)
6500 c          do i=1,nn
6501 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6502 c          enddo
6503         endif
6504       enddo
6505 c      write (iout,*) "number of requests (contacts)",ireq
6506 c      write (iout,*) "req",(req(i),i=1,4)
6507 c      call flush(iout)
6508       if (ireq.gt.0)
6509      & call MPI_Waitall(ireq,req,status_array,ierr)
6510       do iii=1,ntask_cont_from
6511         iproc=itask_cont_from(iii)
6512         nn=ncont_recv(iii)
6513         if (lprn) then
6514         write (iout,*) "Received",nn," contacts from processor",iproc,
6515      &   " of CONT_FROM_COMM group"
6516         call flush(iout)
6517         do i=1,nn
6518           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6519         enddo
6520         call flush(iout)
6521         endif
6522         do i=1,nn
6523           ii=zapas_recv(1,i,iii)
6524 c Flag the received contacts to prevent double-counting
6525           jj=-zapas_recv(2,i,iii)
6526 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6527 c          call flush(iout)
6528           nnn=num_cont_hb(ii)+1
6529           num_cont_hb(ii)=nnn
6530           jcont_hb(nnn,ii)=jj
6531           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6532           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6533           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6534           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6535           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6536           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6537           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6538           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6539           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6540           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6541           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6542           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6543           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6544           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6545           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6546           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6547           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6548           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6549           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6550           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6551           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6552           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6553           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6554           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6555         enddo
6556       enddo
6557       call flush(iout)
6558       if (lprn) then
6559         write (iout,'(a)') 'Contact function values after receive:'
6560         do i=nnt,nct-2
6561           write (iout,'(2i3,50(1x,i3,f5.2))')
6562      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6563      &    j=1,num_cont_hb(i))
6564         enddo
6565         call flush(iout)
6566       endif
6567    30 continue
6568 #endif
6569       if (lprn) then
6570         write (iout,'(a)') 'Contact function values:'
6571         do i=nnt,nct-2
6572           write (iout,'(2i3,50(1x,i3,f5.2))')
6573      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6574      &    j=1,num_cont_hb(i))
6575         enddo
6576       endif
6577       ecorr=0.0D0
6578 C Remove the loop below after debugging !!!
6579       do i=nnt,nct
6580         do j=1,3
6581           gradcorr(j,i)=0.0D0
6582           gradxorr(j,i)=0.0D0
6583         enddo
6584       enddo
6585 C Calculate the local-electrostatic correlation terms
6586       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6587         i1=i+1
6588         num_conti=num_cont_hb(i)
6589         num_conti1=num_cont_hb(i+1)
6590         do jj=1,num_conti
6591           j=jcont_hb(jj,i)
6592           jp=iabs(j)
6593           do kk=1,num_conti1
6594             j1=jcont_hb(kk,i1)
6595             jp1=iabs(j1)
6596 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6597 c     &         ' jj=',jj,' kk=',kk
6598             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6599      &          .or. j.lt.0 .and. j1.gt.0) .and.
6600      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6601 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6602 C The system gains extra energy.
6603               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6604               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6605      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6606               n_corr=n_corr+1
6607             else if (j1.eq.j) then
6608 C Contacts I-J and I-(J+1) occur simultaneously.
6609 C The system loses extra energy.
6610 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6611             endif
6612           enddo ! kk
6613           do kk=1,num_conti
6614             j1=jcont_hb(kk,i)
6615 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6616 c    &         ' jj=',jj,' kk=',kk
6617             if (j1.eq.j+1) then
6618 C Contacts I-J and (I+1)-J occur simultaneously.
6619 C The system loses extra energy.
6620 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6621             endif ! j1==j+1
6622           enddo ! kk
6623         enddo ! jj
6624       enddo ! i
6625       return
6626       end
6627 c------------------------------------------------------------------------------
6628       subroutine add_hb_contact(ii,jj,itask)
6629       implicit real*8 (a-h,o-z)
6630       include "DIMENSIONS"
6631       include "COMMON.IOUNITS"
6632       integer max_cont
6633       integer max_dim
6634       parameter (max_cont=maxconts)
6635       parameter (max_dim=26)
6636       include "COMMON.CONTACTS"
6637       double precision zapas(max_dim,maxconts,max_fg_procs),
6638      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6639       common /przechowalnia/ zapas
6640       integer i,j,ii,jj,iproc,itask(4),nn
6641 c      write (iout,*) "itask",itask
6642       do i=1,2
6643         iproc=itask(i)
6644         if (iproc.gt.0) then
6645           do j=1,num_cont_hb(ii)
6646             jjc=jcont_hb(j,ii)
6647 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6648             if (jjc.eq.jj) then
6649               ncont_sent(iproc)=ncont_sent(iproc)+1
6650               nn=ncont_sent(iproc)
6651               zapas(1,nn,iproc)=ii
6652               zapas(2,nn,iproc)=jjc
6653               zapas(3,nn,iproc)=facont_hb(j,ii)
6654               zapas(4,nn,iproc)=ees0p(j,ii)
6655               zapas(5,nn,iproc)=ees0m(j,ii)
6656               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6657               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6658               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6659               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6660               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6661               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6662               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6663               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6664               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6665               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6666               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6667               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6668               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6669               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6670               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6671               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6672               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6673               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6674               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6675               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6676               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6677               exit
6678             endif
6679           enddo
6680         endif
6681       enddo
6682       return
6683       end
6684 c------------------------------------------------------------------------------
6685       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6686      &  n_corr1)
6687 C This subroutine calculates multi-body contributions to hydrogen-bonding
6688       implicit real*8 (a-h,o-z)
6689       include 'DIMENSIONS'
6690       include 'COMMON.IOUNITS'
6691 #ifdef MPI
6692       include "mpif.h"
6693       parameter (max_cont=maxconts)
6694       parameter (max_dim=70)
6695       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6696       double precision zapas(max_dim,maxconts,max_fg_procs),
6697      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6698       common /przechowalnia/ zapas
6699       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6700      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6701 #endif
6702       include 'COMMON.SETUP'
6703       include 'COMMON.FFIELD'
6704       include 'COMMON.DERIV'
6705       include 'COMMON.LOCAL'
6706       include 'COMMON.INTERACT'
6707       include 'COMMON.CONTACTS'
6708       include 'COMMON.CHAIN'
6709       include 'COMMON.CONTROL'
6710       double precision gx(3),gx1(3)
6711       integer num_cont_hb_old(maxres)
6712       logical lprn,ldone
6713       double precision eello4,eello5,eelo6,eello_turn6
6714       external eello4,eello5,eello6,eello_turn6
6715 C Set lprn=.true. for debugging
6716       lprn=.false.
6717       eturn6=0.0d0
6718 #ifdef MPI
6719       do i=1,nres
6720         num_cont_hb_old(i)=num_cont_hb(i)
6721       enddo
6722       n_corr=0
6723       n_corr1=0
6724       if (nfgtasks.le.1) goto 30
6725       if (lprn) then
6726         write (iout,'(a)') 'Contact function values before RECEIVE:'
6727         do i=nnt,nct-2
6728           write (iout,'(2i3,50(1x,i2,f5.2))')
6729      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6730      &    j=1,num_cont_hb(i))
6731         enddo
6732       endif
6733       call flush(iout)
6734       do i=1,ntask_cont_from
6735         ncont_recv(i)=0
6736       enddo
6737       do i=1,ntask_cont_to
6738         ncont_sent(i)=0
6739       enddo
6740 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6741 c     & ntask_cont_to
6742 C Make the list of contacts to send to send to other procesors
6743       do i=iturn3_start,iturn3_end
6744 c        write (iout,*) "make contact list turn3",i," num_cont",
6745 c     &    num_cont_hb(i)
6746         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6747       enddo
6748       do i=iturn4_start,iturn4_end
6749 c        write (iout,*) "make contact list turn4",i," num_cont",
6750 c     &   num_cont_hb(i)
6751         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6752       enddo
6753       do ii=1,nat_sent
6754         i=iat_sent(ii)
6755 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6756 c     &    num_cont_hb(i)
6757         do j=1,num_cont_hb(i)
6758         do k=1,4
6759           jjc=jcont_hb(j,i)
6760           iproc=iint_sent_local(k,jjc,ii)
6761 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6762           if (iproc.ne.0) then
6763             ncont_sent(iproc)=ncont_sent(iproc)+1
6764             nn=ncont_sent(iproc)
6765             zapas(1,nn,iproc)=i
6766             zapas(2,nn,iproc)=jjc
6767             zapas(3,nn,iproc)=d_cont(j,i)
6768             ind=3
6769             do kk=1,3
6770               ind=ind+1
6771               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6772             enddo
6773             do kk=1,2
6774               do ll=1,2
6775                 ind=ind+1
6776                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6777               enddo
6778             enddo
6779             do jj=1,5
6780               do kk=1,3
6781                 do ll=1,2
6782                   do mm=1,2
6783                     ind=ind+1
6784                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6785                   enddo
6786                 enddo
6787               enddo
6788             enddo
6789           endif
6790         enddo
6791         enddo
6792       enddo
6793       if (lprn) then
6794       write (iout,*)
6795      &  "Numbers of contacts to be sent to other processors",
6796      &  (ncont_sent(i),i=1,ntask_cont_to)
6797       write (iout,*) "Contacts sent"
6798       do ii=1,ntask_cont_to
6799         nn=ncont_sent(ii)
6800         iproc=itask_cont_to(ii)
6801         write (iout,*) nn," contacts to processor",iproc,
6802      &   " of CONT_TO_COMM group"
6803         do i=1,nn
6804           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6805         enddo
6806       enddo
6807       call flush(iout)
6808       endif
6809       CorrelType=477
6810       CorrelID=fg_rank+1
6811       CorrelType1=478
6812       CorrelID1=nfgtasks+fg_rank+1
6813       ireq=0
6814 C Receive the numbers of needed contacts from other processors
6815       do ii=1,ntask_cont_from
6816         iproc=itask_cont_from(ii)
6817         ireq=ireq+1
6818         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6819      &    FG_COMM,req(ireq),IERR)
6820       enddo
6821 c      write (iout,*) "IRECV ended"
6822 c      call flush(iout)
6823 C Send the number of contacts needed by other processors
6824       do ii=1,ntask_cont_to
6825         iproc=itask_cont_to(ii)
6826         ireq=ireq+1
6827         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6828      &    FG_COMM,req(ireq),IERR)
6829       enddo
6830 c      write (iout,*) "ISEND ended"
6831 c      write (iout,*) "number of requests (nn)",ireq
6832       call flush(iout)
6833       if (ireq.gt.0)
6834      &  call MPI_Waitall(ireq,req,status_array,ierr)
6835 c      write (iout,*)
6836 c     &  "Numbers of contacts to be received from other processors",
6837 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6838 c      call flush(iout)
6839 C Receive contacts
6840       ireq=0
6841       do ii=1,ntask_cont_from
6842         iproc=itask_cont_from(ii)
6843         nn=ncont_recv(ii)
6844 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6845 c     &   " of CONT_TO_COMM group"
6846         call flush(iout)
6847         if (nn.gt.0) then
6848           ireq=ireq+1
6849           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6850      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6851 c          write (iout,*) "ireq,req",ireq,req(ireq)
6852         endif
6853       enddo
6854 C Send the contacts to processors that need them
6855       do ii=1,ntask_cont_to
6856         iproc=itask_cont_to(ii)
6857         nn=ncont_sent(ii)
6858 c        write (iout,*) nn," contacts to processor",iproc,
6859 c     &   " of CONT_TO_COMM group"
6860         if (nn.gt.0) then
6861           ireq=ireq+1
6862           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6863      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6864 c          write (iout,*) "ireq,req",ireq,req(ireq)
6865 c          do i=1,nn
6866 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6867 c          enddo
6868         endif
6869       enddo
6870 c      write (iout,*) "number of requests (contacts)",ireq
6871 c      write (iout,*) "req",(req(i),i=1,4)
6872 c      call flush(iout)
6873       if (ireq.gt.0)
6874      & call MPI_Waitall(ireq,req,status_array,ierr)
6875       do iii=1,ntask_cont_from
6876         iproc=itask_cont_from(iii)
6877         nn=ncont_recv(iii)
6878         if (lprn) then
6879         write (iout,*) "Received",nn," contacts from processor",iproc,
6880      &   " of CONT_FROM_COMM group"
6881         call flush(iout)
6882         do i=1,nn
6883           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6884         enddo
6885         call flush(iout)
6886         endif
6887         do i=1,nn
6888           ii=zapas_recv(1,i,iii)
6889 c Flag the received contacts to prevent double-counting
6890           jj=-zapas_recv(2,i,iii)
6891 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6892 c          call flush(iout)
6893           nnn=num_cont_hb(ii)+1
6894           num_cont_hb(ii)=nnn
6895           jcont_hb(nnn,ii)=jj
6896           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6897           ind=3
6898           do kk=1,3
6899             ind=ind+1
6900             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6901           enddo
6902           do kk=1,2
6903             do ll=1,2
6904               ind=ind+1
6905               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6906             enddo
6907           enddo
6908           do jj=1,5
6909             do kk=1,3
6910               do ll=1,2
6911                 do mm=1,2
6912                   ind=ind+1
6913                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6914                 enddo
6915               enddo
6916             enddo
6917           enddo
6918         enddo
6919       enddo
6920       call flush(iout)
6921       if (lprn) then
6922         write (iout,'(a)') 'Contact function values after receive:'
6923         do i=nnt,nct-2
6924           write (iout,'(2i3,50(1x,i3,5f6.3))')
6925      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6926      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6927         enddo
6928         call flush(iout)
6929       endif
6930    30 continue
6931 #endif
6932       if (lprn) then
6933         write (iout,'(a)') 'Contact function values:'
6934         do i=nnt,nct-2
6935           write (iout,'(2i3,50(1x,i2,5f6.3))')
6936      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6937      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6938         enddo
6939       endif
6940       ecorr=0.0D0
6941       ecorr5=0.0d0
6942       ecorr6=0.0d0
6943 C Remove the loop below after debugging !!!
6944       do i=nnt,nct
6945         do j=1,3
6946           gradcorr(j,i)=0.0D0
6947           gradxorr(j,i)=0.0D0
6948         enddo
6949       enddo
6950 C Calculate the dipole-dipole interaction energies
6951       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6952       do i=iatel_s,iatel_e+1
6953         num_conti=num_cont_hb(i)
6954         do jj=1,num_conti
6955           j=jcont_hb(jj,i)
6956 #ifdef MOMENT
6957           call dipole(i,j,jj)
6958 #endif
6959         enddo
6960       enddo
6961       endif
6962 C Calculate the local-electrostatic correlation terms
6963 c                write (iout,*) "gradcorr5 in eello5 before loop"
6964 c                do iii=1,nres
6965 c                  write (iout,'(i5,3f10.5)')
6966 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6967 c                enddo
6968       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6969 c        write (iout,*) "corr loop i",i
6970         i1=i+1
6971         num_conti=num_cont_hb(i)
6972         num_conti1=num_cont_hb(i+1)
6973         do jj=1,num_conti
6974           j=jcont_hb(jj,i)
6975           jp=iabs(j)
6976           do kk=1,num_conti1
6977             j1=jcont_hb(kk,i1)
6978             jp1=iabs(j1)
6979 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6980 c     &         ' jj=',jj,' kk=',kk
6981 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6982             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6983      &          .or. j.lt.0 .and. j1.gt.0) .and.
6984      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6985 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6986 C The system gains extra energy.
6987               n_corr=n_corr+1
6988               sqd1=dsqrt(d_cont(jj,i))
6989               sqd2=dsqrt(d_cont(kk,i1))
6990               sred_geom = sqd1*sqd2
6991               IF (sred_geom.lt.cutoff_corr) THEN
6992                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6993      &            ekont,fprimcont)
6994 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6995 cd     &         ' jj=',jj,' kk=',kk
6996                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6997                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6998                 do l=1,3
6999                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7000                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7001                 enddo
7002                 n_corr1=n_corr1+1
7003 cd               write (iout,*) 'sred_geom=',sred_geom,
7004 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
7005 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7006 cd               write (iout,*) "g_contij",g_contij
7007 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7008 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7009                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7010                 if (wcorr4.gt.0.0d0)
7011      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7012                   if (energy_dec.and.wcorr4.gt.0.0d0)
7013      1                 write (iout,'(a6,4i5,0pf7.3)')
7014      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7015 c                write (iout,*) "gradcorr5 before eello5"
7016 c                do iii=1,nres
7017 c                  write (iout,'(i5,3f10.5)')
7018 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7019 c                enddo
7020                 if (wcorr5.gt.0.0d0)
7021      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7022 c                write (iout,*) "gradcorr5 after eello5"
7023 c                do iii=1,nres
7024 c                  write (iout,'(i5,3f10.5)')
7025 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7026 c                enddo
7027                   if (energy_dec.and.wcorr5.gt.0.0d0)
7028      1                 write (iout,'(a6,4i5,0pf7.3)')
7029      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7030 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7031 cd                write(2,*)'ijkl',i,jp,i+1,jp1
7032                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
7033      &               .or. wturn6.eq.0.0d0))then
7034 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7035                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7036                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7037      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7038 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7039 cd     &            'ecorr6=',ecorr6
7040 cd                write (iout,'(4e15.5)') sred_geom,
7041 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7042 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7043 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7044                 else if (wturn6.gt.0.0d0
7045      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7046 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7047                   eturn6=eturn6+eello_turn6(i,jj,kk)
7048                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7049      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7050 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
7051                 endif
7052               ENDIF
7053 1111          continue
7054             endif
7055           enddo ! kk
7056         enddo ! jj
7057       enddo ! i
7058       do i=1,nres
7059         num_cont_hb(i)=num_cont_hb_old(i)
7060       enddo
7061 c                write (iout,*) "gradcorr5 in eello5"
7062 c                do iii=1,nres
7063 c                  write (iout,'(i5,3f10.5)')
7064 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7065 c                enddo
7066       return
7067       end
7068 c------------------------------------------------------------------------------
7069       subroutine add_hb_contact_eello(ii,jj,itask)
7070       implicit real*8 (a-h,o-z)
7071       include "DIMENSIONS"
7072       include "COMMON.IOUNITS"
7073       integer max_cont
7074       integer max_dim
7075       parameter (max_cont=maxconts)
7076       parameter (max_dim=70)
7077       include "COMMON.CONTACTS"
7078       double precision zapas(max_dim,maxconts,max_fg_procs),
7079      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7080       common /przechowalnia/ zapas
7081       integer i,j,ii,jj,iproc,itask(4),nn
7082 c      write (iout,*) "itask",itask
7083       do i=1,2
7084         iproc=itask(i)
7085         if (iproc.gt.0) then
7086           do j=1,num_cont_hb(ii)
7087             jjc=jcont_hb(j,ii)
7088 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
7089             if (jjc.eq.jj) then
7090               ncont_sent(iproc)=ncont_sent(iproc)+1
7091               nn=ncont_sent(iproc)
7092               zapas(1,nn,iproc)=ii
7093               zapas(2,nn,iproc)=jjc
7094               zapas(3,nn,iproc)=d_cont(j,ii)
7095               ind=3
7096               do kk=1,3
7097                 ind=ind+1
7098                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
7099               enddo
7100               do kk=1,2
7101                 do ll=1,2
7102                   ind=ind+1
7103                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
7104                 enddo
7105               enddo
7106               do jj=1,5
7107                 do kk=1,3
7108                   do ll=1,2
7109                     do mm=1,2
7110                       ind=ind+1
7111                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
7112                     enddo
7113                   enddo
7114                 enddo
7115               enddo
7116               exit
7117             endif
7118           enddo
7119         endif
7120       enddo
7121       return
7122       end
7123 c------------------------------------------------------------------------------
7124       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7125       implicit real*8 (a-h,o-z)
7126       include 'DIMENSIONS'
7127       include 'COMMON.IOUNITS'
7128       include 'COMMON.DERIV'
7129       include 'COMMON.INTERACT'
7130       include 'COMMON.CONTACTS'
7131       double precision gx(3),gx1(3)
7132       logical lprn
7133       lprn=.false.
7134       eij=facont_hb(jj,i)
7135       ekl=facont_hb(kk,k)
7136       ees0pij=ees0p(jj,i)
7137       ees0pkl=ees0p(kk,k)
7138       ees0mij=ees0m(jj,i)
7139       ees0mkl=ees0m(kk,k)
7140       ekont=eij*ekl
7141       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7142 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7143 C Following 4 lines for diagnostics.
7144 cd    ees0pkl=0.0D0
7145 cd    ees0pij=1.0D0
7146 cd    ees0mkl=0.0D0
7147 cd    ees0mij=1.0D0
7148 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7149 c     & 'Contacts ',i,j,
7150 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7151 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7152 c     & 'gradcorr_long'
7153 C Calculate the multi-body contribution to energy.
7154 c      ecorr=ecorr+ekont*ees
7155 C Calculate multi-body contributions to the gradient.
7156       coeffpees0pij=coeffp*ees0pij
7157       coeffmees0mij=coeffm*ees0mij
7158       coeffpees0pkl=coeffp*ees0pkl
7159       coeffmees0mkl=coeffm*ees0mkl
7160       do ll=1,3
7161 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7162         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
7163      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
7164      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
7165         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
7166      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
7167      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
7168 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7169         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
7170      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
7171      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
7172         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
7173      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
7174      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
7175         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
7176      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
7177      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
7178         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7179         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7180         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
7181      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
7182      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
7183         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7184         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7185 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7186       enddo
7187 c      write (iout,*)
7188 cgrad      do m=i+1,j-1
7189 cgrad        do ll=1,3
7190 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7191 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7192 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7193 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7194 cgrad        enddo
7195 cgrad      enddo
7196 cgrad      do m=k+1,l-1
7197 cgrad        do ll=1,3
7198 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7199 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7200 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7201 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7202 cgrad        enddo
7203 cgrad      enddo
7204 c      write (iout,*) "ehbcorr",ekont*ees
7205       ehbcorr=ekont*ees
7206       return
7207       end
7208 #ifdef MOMENT
7209 C---------------------------------------------------------------------------
7210       subroutine dipole(i,j,jj)
7211       implicit real*8 (a-h,o-z)
7212       include 'DIMENSIONS'
7213       include 'COMMON.IOUNITS'
7214       include 'COMMON.CHAIN'
7215       include 'COMMON.FFIELD'
7216       include 'COMMON.DERIV'
7217       include 'COMMON.INTERACT'
7218       include 'COMMON.CONTACTS'
7219       include 'COMMON.TORSION'
7220       include 'COMMON.VAR'
7221       include 'COMMON.GEO'
7222       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7223      &  auxmat(2,2)
7224       iti1 = itortyp(itype(i+1))
7225       if (j.lt.nres-1) then
7226         itj1 = itortyp(itype(j+1))
7227       else
7228         itj1=ntortyp+1
7229       endif
7230       do iii=1,2
7231         dipi(iii,1)=Ub2(iii,i)
7232         dipderi(iii)=Ub2der(iii,i)
7233         dipi(iii,2)=b1(iii,iti1)
7234         dipj(iii,1)=Ub2(iii,j)
7235         dipderj(iii)=Ub2der(iii,j)
7236         dipj(iii,2)=b1(iii,itj1)
7237       enddo
7238       kkk=0
7239       do iii=1,2
7240         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7241         do jjj=1,2
7242           kkk=kkk+1
7243           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7244         enddo
7245       enddo
7246       do kkk=1,5
7247         do lll=1,3
7248           mmm=0
7249           do iii=1,2
7250             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7251      &        auxvec(1))
7252             do jjj=1,2
7253               mmm=mmm+1
7254               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7255             enddo
7256           enddo
7257         enddo
7258       enddo
7259       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7260       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7261       do iii=1,2
7262         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7263       enddo
7264       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7265       do iii=1,2
7266         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7267       enddo
7268       return
7269       end
7270 #endif
7271 C---------------------------------------------------------------------------
7272       subroutine calc_eello(i,j,k,l,jj,kk)
7273 C
7274 C This subroutine computes matrices and vectors needed to calculate
7275 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7276 C
7277       implicit real*8 (a-h,o-z)
7278       include 'DIMENSIONS'
7279       include 'COMMON.IOUNITS'
7280       include 'COMMON.CHAIN'
7281       include 'COMMON.DERIV'
7282       include 'COMMON.INTERACT'
7283       include 'COMMON.CONTACTS'
7284       include 'COMMON.TORSION'
7285       include 'COMMON.VAR'
7286       include 'COMMON.GEO'
7287       include 'COMMON.FFIELD'
7288       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7289      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7290       logical lprn
7291       common /kutas/ lprn
7292 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7293 cd     & ' jj=',jj,' kk=',kk
7294 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7295 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7296 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7297       do iii=1,2
7298         do jjj=1,2
7299           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7300           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7301         enddo
7302       enddo
7303       call transpose2(aa1(1,1),aa1t(1,1))
7304       call transpose2(aa2(1,1),aa2t(1,1))
7305       do kkk=1,5
7306         do lll=1,3
7307           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7308      &      aa1tder(1,1,lll,kkk))
7309           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7310      &      aa2tder(1,1,lll,kkk))
7311         enddo
7312       enddo
7313       if (l.eq.j+1) then
7314 C parallel orientation of the two CA-CA-CA frames.
7315         if (i.gt.1) then
7316           iti=itortyp(itype(i))
7317         else
7318           iti=ntortyp+1
7319         endif
7320         itk1=itortyp(itype(k+1))
7321         itj=itortyp(itype(j))
7322         if (l.lt.nres-1) then
7323           itl1=itortyp(itype(l+1))
7324         else
7325           itl1=ntortyp+1
7326         endif
7327 C A1 kernel(j+1) A2T
7328 cd        do iii=1,2
7329 cd          write (iout,'(3f10.5,5x,3f10.5)')
7330 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7331 cd        enddo
7332         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7333      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7334      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7335 C Following matrices are needed only for 6-th order cumulants
7336         IF (wcorr6.gt.0.0d0) THEN
7337         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7338      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7339      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7340         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7341      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7342      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7343      &   ADtEAderx(1,1,1,1,1,1))
7344         lprn=.false.
7345         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7346      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7347      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7348      &   ADtEA1derx(1,1,1,1,1,1))
7349         ENDIF
7350 C End 6-th order cumulants
7351 cd        lprn=.false.
7352 cd        if (lprn) then
7353 cd        write (2,*) 'In calc_eello6'
7354 cd        do iii=1,2
7355 cd          write (2,*) 'iii=',iii
7356 cd          do kkk=1,5
7357 cd            write (2,*) 'kkk=',kkk
7358 cd            do jjj=1,2
7359 cd              write (2,'(3(2f10.5),5x)')
7360 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7361 cd            enddo
7362 cd          enddo
7363 cd        enddo
7364 cd        endif
7365         call transpose2(EUgder(1,1,k),auxmat(1,1))
7366         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7367         call transpose2(EUg(1,1,k),auxmat(1,1))
7368         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7369         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7370         do iii=1,2
7371           do kkk=1,5
7372             do lll=1,3
7373               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7374      &          EAEAderx(1,1,lll,kkk,iii,1))
7375             enddo
7376           enddo
7377         enddo
7378 C A1T kernel(i+1) A2
7379         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7380      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7381      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7382 C Following matrices are needed only for 6-th order cumulants
7383         IF (wcorr6.gt.0.0d0) THEN
7384         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7385      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7386      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7387         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7388      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7389      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7390      &   ADtEAderx(1,1,1,1,1,2))
7391         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7392      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7393      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7394      &   ADtEA1derx(1,1,1,1,1,2))
7395         ENDIF
7396 C End 6-th order cumulants
7397         call transpose2(EUgder(1,1,l),auxmat(1,1))
7398         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7399         call transpose2(EUg(1,1,l),auxmat(1,1))
7400         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7401         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7402         do iii=1,2
7403           do kkk=1,5
7404             do lll=1,3
7405               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7406      &          EAEAderx(1,1,lll,kkk,iii,2))
7407             enddo
7408           enddo
7409         enddo
7410 C AEAb1 and AEAb2
7411 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7412 C They are needed only when the fifth- or the sixth-order cumulants are
7413 C indluded.
7414         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7415         call transpose2(AEA(1,1,1),auxmat(1,1))
7416         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7417         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7418         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7419         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7420         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7421         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7422         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7423         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7424         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7425         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7426         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7427         call transpose2(AEA(1,1,2),auxmat(1,1))
7428         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7429         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7430         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7431         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7432         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7433         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7434         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7435         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7436         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7437         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7438         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7439 C Calculate the Cartesian derivatives of the vectors.
7440         do iii=1,2
7441           do kkk=1,5
7442             do lll=1,3
7443               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7444               call matvec2(auxmat(1,1),b1(1,iti),
7445      &          AEAb1derx(1,lll,kkk,iii,1,1))
7446               call matvec2(auxmat(1,1),Ub2(1,i),
7447      &          AEAb2derx(1,lll,kkk,iii,1,1))
7448               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7449      &          AEAb1derx(1,lll,kkk,iii,2,1))
7450               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7451      &          AEAb2derx(1,lll,kkk,iii,2,1))
7452               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7453               call matvec2(auxmat(1,1),b1(1,itj),
7454      &          AEAb1derx(1,lll,kkk,iii,1,2))
7455               call matvec2(auxmat(1,1),Ub2(1,j),
7456      &          AEAb2derx(1,lll,kkk,iii,1,2))
7457               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7458      &          AEAb1derx(1,lll,kkk,iii,2,2))
7459               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7460      &          AEAb2derx(1,lll,kkk,iii,2,2))
7461             enddo
7462           enddo
7463         enddo
7464         ENDIF
7465 C End vectors
7466       else
7467 C Antiparallel orientation of the two CA-CA-CA frames.
7468         if (i.gt.1) then
7469           iti=itortyp(itype(i))
7470         else
7471           iti=ntortyp+1
7472         endif
7473         itk1=itortyp(itype(k+1))
7474         itl=itortyp(itype(l))
7475         itj=itortyp(itype(j))
7476         if (j.lt.nres-1) then
7477           itj1=itortyp(itype(j+1))
7478         else
7479           itj1=ntortyp+1
7480         endif
7481 C A2 kernel(j-1)T A1T
7482         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7483      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7484      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7485 C Following matrices are needed only for 6-th order cumulants
7486         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7487      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7488         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7489      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7490      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7491         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7492      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7493      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7494      &   ADtEAderx(1,1,1,1,1,1))
7495         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7496      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7497      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7498      &   ADtEA1derx(1,1,1,1,1,1))
7499         ENDIF
7500 C End 6-th order cumulants
7501         call transpose2(EUgder(1,1,k),auxmat(1,1))
7502         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7503         call transpose2(EUg(1,1,k),auxmat(1,1))
7504         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7505         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7506         do iii=1,2
7507           do kkk=1,5
7508             do lll=1,3
7509               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7510      &          EAEAderx(1,1,lll,kkk,iii,1))
7511             enddo
7512           enddo
7513         enddo
7514 C A2T kernel(i+1)T A1
7515         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7516      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7517      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7518 C Following matrices are needed only for 6-th order cumulants
7519         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7520      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7521         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7522      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7523      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7524         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7525      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7526      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7527      &   ADtEAderx(1,1,1,1,1,2))
7528         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7529      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7530      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7531      &   ADtEA1derx(1,1,1,1,1,2))
7532         ENDIF
7533 C End 6-th order cumulants
7534         call transpose2(EUgder(1,1,j),auxmat(1,1))
7535         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7536         call transpose2(EUg(1,1,j),auxmat(1,1))
7537         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7538         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7539         do iii=1,2
7540           do kkk=1,5
7541             do lll=1,3
7542               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7543      &          EAEAderx(1,1,lll,kkk,iii,2))
7544             enddo
7545           enddo
7546         enddo
7547 C AEAb1 and AEAb2
7548 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7549 C They are needed only when the fifth- or the sixth-order cumulants are
7550 C indluded.
7551         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7552      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7553         call transpose2(AEA(1,1,1),auxmat(1,1))
7554         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7555         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7556         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7557         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7558         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7559         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7560         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7561         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7562         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7563         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7564         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7565         call transpose2(AEA(1,1,2),auxmat(1,1))
7566         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7567         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7568         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7569         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7570         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7571         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7572         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7573         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7574         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7575         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7576         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7577 C Calculate the Cartesian derivatives of the vectors.
7578         do iii=1,2
7579           do kkk=1,5
7580             do lll=1,3
7581               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7582               call matvec2(auxmat(1,1),b1(1,iti),
7583      &          AEAb1derx(1,lll,kkk,iii,1,1))
7584               call matvec2(auxmat(1,1),Ub2(1,i),
7585      &          AEAb2derx(1,lll,kkk,iii,1,1))
7586               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7587      &          AEAb1derx(1,lll,kkk,iii,2,1))
7588               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7589      &          AEAb2derx(1,lll,kkk,iii,2,1))
7590               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7591               call matvec2(auxmat(1,1),b1(1,itl),
7592      &          AEAb1derx(1,lll,kkk,iii,1,2))
7593               call matvec2(auxmat(1,1),Ub2(1,l),
7594      &          AEAb2derx(1,lll,kkk,iii,1,2))
7595               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7596      &          AEAb1derx(1,lll,kkk,iii,2,2))
7597               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7598      &          AEAb2derx(1,lll,kkk,iii,2,2))
7599             enddo
7600           enddo
7601         enddo
7602         ENDIF
7603 C End vectors
7604       endif
7605       return
7606       end
7607 C---------------------------------------------------------------------------
7608       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7609      &  KK,KKderg,AKA,AKAderg,AKAderx)
7610       implicit none
7611       integer nderg
7612       logical transp
7613       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7614      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7615      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7616       integer iii,kkk,lll
7617       integer jjj,mmm
7618       logical lprn
7619       common /kutas/ lprn
7620       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7621       do iii=1,nderg
7622         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7623      &    AKAderg(1,1,iii))
7624       enddo
7625 cd      if (lprn) write (2,*) 'In kernel'
7626       do kkk=1,5
7627 cd        if (lprn) write (2,*) 'kkk=',kkk
7628         do lll=1,3
7629           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7630      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7631 cd          if (lprn) then
7632 cd            write (2,*) 'lll=',lll
7633 cd            write (2,*) 'iii=1'
7634 cd            do jjj=1,2
7635 cd              write (2,'(3(2f10.5),5x)')
7636 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7637 cd            enddo
7638 cd          endif
7639           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7640      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7641 cd          if (lprn) then
7642 cd            write (2,*) 'lll=',lll
7643 cd            write (2,*) 'iii=2'
7644 cd            do jjj=1,2
7645 cd              write (2,'(3(2f10.5),5x)')
7646 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7647 cd            enddo
7648 cd          endif
7649         enddo
7650       enddo
7651       return
7652       end
7653 C---------------------------------------------------------------------------
7654       double precision function eello4(i,j,k,l,jj,kk)
7655       implicit real*8 (a-h,o-z)
7656       include 'DIMENSIONS'
7657       include 'COMMON.IOUNITS'
7658       include 'COMMON.CHAIN'
7659       include 'COMMON.DERIV'
7660       include 'COMMON.INTERACT'
7661       include 'COMMON.CONTACTS'
7662       include 'COMMON.TORSION'
7663       include 'COMMON.VAR'
7664       include 'COMMON.GEO'
7665       double precision pizda(2,2),ggg1(3),ggg2(3)
7666 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7667 cd        eello4=0.0d0
7668 cd        return
7669 cd      endif
7670 cd      print *,'eello4:',i,j,k,l,jj,kk
7671 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7672 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7673 cold      eij=facont_hb(jj,i)
7674 cold      ekl=facont_hb(kk,k)
7675 cold      ekont=eij*ekl
7676       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7677 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7678       gcorr_loc(k-1)=gcorr_loc(k-1)
7679      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7680       if (l.eq.j+1) then
7681         gcorr_loc(l-1)=gcorr_loc(l-1)
7682      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7683       else
7684         gcorr_loc(j-1)=gcorr_loc(j-1)
7685      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7686       endif
7687       do iii=1,2
7688         do kkk=1,5
7689           do lll=1,3
7690             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7691      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7692 cd            derx(lll,kkk,iii)=0.0d0
7693           enddo
7694         enddo
7695       enddo
7696 cd      gcorr_loc(l-1)=0.0d0
7697 cd      gcorr_loc(j-1)=0.0d0
7698 cd      gcorr_loc(k-1)=0.0d0
7699 cd      eel4=1.0d0
7700 cd      write (iout,*)'Contacts have occurred for peptide groups',
7701 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7702 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7703       if (j.lt.nres-1) then
7704         j1=j+1
7705         j2=j-1
7706       else
7707         j1=j-1
7708         j2=j-2
7709       endif
7710       if (l.lt.nres-1) then
7711         l1=l+1
7712         l2=l-1
7713       else
7714         l1=l-1
7715         l2=l-2
7716       endif
7717       do ll=1,3
7718 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7719 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7720         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7721         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7722 cgrad        ghalf=0.5d0*ggg1(ll)
7723         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7724         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7725         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7726         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7727         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7728         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7729 cgrad        ghalf=0.5d0*ggg2(ll)
7730         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7731         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7732         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7733         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7734         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7735         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7736       enddo
7737 cgrad      do m=i+1,j-1
7738 cgrad        do ll=1,3
7739 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7740 cgrad        enddo
7741 cgrad      enddo
7742 cgrad      do m=k+1,l-1
7743 cgrad        do ll=1,3
7744 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7745 cgrad        enddo
7746 cgrad      enddo
7747 cgrad      do m=i+2,j2
7748 cgrad        do ll=1,3
7749 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7750 cgrad        enddo
7751 cgrad      enddo
7752 cgrad      do m=k+2,l2
7753 cgrad        do ll=1,3
7754 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7755 cgrad        enddo
7756 cgrad      enddo
7757 cd      do iii=1,nres-3
7758 cd        write (2,*) iii,gcorr_loc(iii)
7759 cd      enddo
7760       eello4=ekont*eel4
7761 cd      write (2,*) 'ekont',ekont
7762 cd      write (iout,*) 'eello4',ekont*eel4
7763       return
7764       end
7765 C---------------------------------------------------------------------------
7766       double precision function eello5(i,j,k,l,jj,kk)
7767       implicit real*8 (a-h,o-z)
7768       include 'DIMENSIONS'
7769       include 'COMMON.IOUNITS'
7770       include 'COMMON.CHAIN'
7771       include 'COMMON.DERIV'
7772       include 'COMMON.INTERACT'
7773       include 'COMMON.CONTACTS'
7774       include 'COMMON.TORSION'
7775       include 'COMMON.VAR'
7776       include 'COMMON.GEO'
7777       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7778       double precision ggg1(3),ggg2(3)
7779 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7780 C                                                                              C
7781 C                            Parallel chains                                   C
7782 C                                                                              C
7783 C          o             o                   o             o                   C
7784 C         /l\           / \             \   / \           / \   /              C
7785 C        /   \         /   \             \ /   \         /   \ /               C
7786 C       j| o |l1       | o |              o| o |         | o |o                C
7787 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7788 C      \i/   \         /   \ /             /   \         /   \                 C
7789 C       o    k1             o                                                  C
7790 C         (I)          (II)                (III)          (IV)                 C
7791 C                                                                              C
7792 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7793 C                                                                              C
7794 C                            Antiparallel chains                               C
7795 C                                                                              C
7796 C          o             o                   o             o                   C
7797 C         /j\           / \             \   / \           / \   /              C
7798 C        /   \         /   \             \ /   \         /   \ /               C
7799 C      j1| o |l        | o |              o| o |         | o |o                C
7800 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7801 C      \i/   \         /   \ /             /   \         /   \                 C
7802 C       o     k1            o                                                  C
7803 C         (I)          (II)                (III)          (IV)                 C
7804 C                                                                              C
7805 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7806 C                                                                              C
7807 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7808 C                                                                              C
7809 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7810 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7811 cd        eello5=0.0d0
7812 cd        return
7813 cd      endif
7814 cd      write (iout,*)
7815 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7816 cd     &   ' and',k,l
7817       itk=itortyp(itype(k))
7818       itl=itortyp(itype(l))
7819       itj=itortyp(itype(j))
7820       eello5_1=0.0d0
7821       eello5_2=0.0d0
7822       eello5_3=0.0d0
7823       eello5_4=0.0d0
7824 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7825 cd     &   eel5_3_num,eel5_4_num)
7826       do iii=1,2
7827         do kkk=1,5
7828           do lll=1,3
7829             derx(lll,kkk,iii)=0.0d0
7830           enddo
7831         enddo
7832       enddo
7833 cd      eij=facont_hb(jj,i)
7834 cd      ekl=facont_hb(kk,k)
7835 cd      ekont=eij*ekl
7836 cd      write (iout,*)'Contacts have occurred for peptide groups',
7837 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7838 cd      goto 1111
7839 C Contribution from the graph I.
7840 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7841 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7842       call transpose2(EUg(1,1,k),auxmat(1,1))
7843       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7844       vv(1)=pizda(1,1)-pizda(2,2)
7845       vv(2)=pizda(1,2)+pizda(2,1)
7846       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7847      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7848 C Explicit gradient in virtual-dihedral angles.
7849       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7850      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7851      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7852       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7853       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7854       vv(1)=pizda(1,1)-pizda(2,2)
7855       vv(2)=pizda(1,2)+pizda(2,1)
7856       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7857      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7858      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7859       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7860       vv(1)=pizda(1,1)-pizda(2,2)
7861       vv(2)=pizda(1,2)+pizda(2,1)
7862       if (l.eq.j+1) then
7863         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7864      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7865      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7866       else
7867         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7868      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7869      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7870       endif
7871 C Cartesian gradient
7872       do iii=1,2
7873         do kkk=1,5
7874           do lll=1,3
7875             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7876      &        pizda(1,1))
7877             vv(1)=pizda(1,1)-pizda(2,2)
7878             vv(2)=pizda(1,2)+pizda(2,1)
7879             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7880      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7881      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7882           enddo
7883         enddo
7884       enddo
7885 c      goto 1112
7886 c1111  continue
7887 C Contribution from graph II
7888       call transpose2(EE(1,1,itk),auxmat(1,1))
7889       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7890       vv(1)=pizda(1,1)+pizda(2,2)
7891       vv(2)=pizda(2,1)-pizda(1,2)
7892       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7893      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7894 C Explicit gradient in virtual-dihedral angles.
7895       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7896      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7897       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7898       vv(1)=pizda(1,1)+pizda(2,2)
7899       vv(2)=pizda(2,1)-pizda(1,2)
7900       if (l.eq.j+1) then
7901         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7902      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7903      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7904       else
7905         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7906      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7907      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7908       endif
7909 C Cartesian gradient
7910       do iii=1,2
7911         do kkk=1,5
7912           do lll=1,3
7913             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7914      &        pizda(1,1))
7915             vv(1)=pizda(1,1)+pizda(2,2)
7916             vv(2)=pizda(2,1)-pizda(1,2)
7917             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7918      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7919      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7920           enddo
7921         enddo
7922       enddo
7923 cd      goto 1112
7924 cd1111  continue
7925       if (l.eq.j+1) then
7926 cd        goto 1110
7927 C Parallel orientation
7928 C Contribution from graph III
7929         call transpose2(EUg(1,1,l),auxmat(1,1))
7930         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7931         vv(1)=pizda(1,1)-pizda(2,2)
7932         vv(2)=pizda(1,2)+pizda(2,1)
7933         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7934      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7935 C Explicit gradient in virtual-dihedral angles.
7936         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7937      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7938      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7939         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7940         vv(1)=pizda(1,1)-pizda(2,2)
7941         vv(2)=pizda(1,2)+pizda(2,1)
7942         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7943      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7944      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7945         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7946         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7947         vv(1)=pizda(1,1)-pizda(2,2)
7948         vv(2)=pizda(1,2)+pizda(2,1)
7949         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7950      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7951      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7952 C Cartesian gradient
7953         do iii=1,2
7954           do kkk=1,5
7955             do lll=1,3
7956               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7957      &          pizda(1,1))
7958               vv(1)=pizda(1,1)-pizda(2,2)
7959               vv(2)=pizda(1,2)+pizda(2,1)
7960               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7961      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7962      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7963             enddo
7964           enddo
7965         enddo
7966 cd        goto 1112
7967 C Contribution from graph IV
7968 cd1110    continue
7969         call transpose2(EE(1,1,itl),auxmat(1,1))
7970         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7971         vv(1)=pizda(1,1)+pizda(2,2)
7972         vv(2)=pizda(2,1)-pizda(1,2)
7973         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7974      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7975 C Explicit gradient in virtual-dihedral angles.
7976         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7977      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7978         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7979         vv(1)=pizda(1,1)+pizda(2,2)
7980         vv(2)=pizda(2,1)-pizda(1,2)
7981         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7982      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7983      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7984 C Cartesian gradient
7985         do iii=1,2
7986           do kkk=1,5
7987             do lll=1,3
7988               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7989      &          pizda(1,1))
7990               vv(1)=pizda(1,1)+pizda(2,2)
7991               vv(2)=pizda(2,1)-pizda(1,2)
7992               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7993      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7994      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7995             enddo
7996           enddo
7997         enddo
7998       else
7999 C Antiparallel orientation
8000 C Contribution from graph III
8001 c        goto 1110
8002         call transpose2(EUg(1,1,j),auxmat(1,1))
8003         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8004         vv(1)=pizda(1,1)-pizda(2,2)
8005         vv(2)=pizda(1,2)+pizda(2,1)
8006         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
8007      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8008 C Explicit gradient in virtual-dihedral angles.
8009         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8010      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
8011      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8012         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8013         vv(1)=pizda(1,1)-pizda(2,2)
8014         vv(2)=pizda(1,2)+pizda(2,1)
8015         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8016      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
8017      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8018         call transpose2(EUgder(1,1,j),auxmat1(1,1))
8019         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8020         vv(1)=pizda(1,1)-pizda(2,2)
8021         vv(2)=pizda(1,2)+pizda(2,1)
8022         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8023      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
8024      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8025 C Cartesian gradient
8026         do iii=1,2
8027           do kkk=1,5
8028             do lll=1,3
8029               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8030      &          pizda(1,1))
8031               vv(1)=pizda(1,1)-pizda(2,2)
8032               vv(2)=pizda(1,2)+pizda(2,1)
8033               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8034      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
8035      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8036             enddo
8037           enddo
8038         enddo
8039 cd        goto 1112
8040 C Contribution from graph IV
8041 1110    continue
8042         call transpose2(EE(1,1,itj),auxmat(1,1))
8043         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8044         vv(1)=pizda(1,1)+pizda(2,2)
8045         vv(2)=pizda(2,1)-pizda(1,2)
8046         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
8047      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
8048 C Explicit gradient in virtual-dihedral angles.
8049         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8050      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
8051         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8052         vv(1)=pizda(1,1)+pizda(2,2)
8053         vv(2)=pizda(2,1)-pizda(1,2)
8054         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8055      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
8056      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
8057 C Cartesian gradient
8058         do iii=1,2
8059           do kkk=1,5
8060             do lll=1,3
8061               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8062      &          pizda(1,1))
8063               vv(1)=pizda(1,1)+pizda(2,2)
8064               vv(2)=pizda(2,1)-pizda(1,2)
8065               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8066      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
8067      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
8068             enddo
8069           enddo
8070         enddo
8071       endif
8072 1112  continue
8073       eel5=eello5_1+eello5_2+eello5_3+eello5_4
8074 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
8075 cd        write (2,*) 'ijkl',i,j,k,l
8076 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
8077 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
8078 cd      endif
8079 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
8080 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
8081 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
8082 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
8083       if (j.lt.nres-1) then
8084         j1=j+1
8085         j2=j-1
8086       else
8087         j1=j-1
8088         j2=j-2
8089       endif
8090       if (l.lt.nres-1) then
8091         l1=l+1
8092         l2=l-1
8093       else
8094         l1=l-1
8095         l2=l-2
8096       endif
8097 cd      eij=1.0d0
8098 cd      ekl=1.0d0
8099 cd      ekont=1.0d0
8100 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
8101 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
8102 C        summed up outside the subrouine as for the other subroutines
8103 C        handling long-range interactions. The old code is commented out
8104 C        with "cgrad" to keep track of changes.
8105       do ll=1,3
8106 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
8107 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
8108         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
8109         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
8110 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
8111 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
8112 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
8113 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
8114 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
8115 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
8116 c     &   gradcorr5ij,
8117 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
8118 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
8119 cgrad        ghalf=0.5d0*ggg1(ll)
8120 cd        ghalf=0.0d0
8121         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
8122         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
8123         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
8124         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
8125         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
8126         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
8127 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
8128 cgrad        ghalf=0.5d0*ggg2(ll)
8129 cd        ghalf=0.0d0
8130         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
8131         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
8132         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
8133         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
8134         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
8135         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
8136       enddo
8137 cd      goto 1112
8138 cgrad      do m=i+1,j-1
8139 cgrad        do ll=1,3
8140 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
8141 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
8142 cgrad        enddo
8143 cgrad      enddo
8144 cgrad      do m=k+1,l-1
8145 cgrad        do ll=1,3
8146 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
8147 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
8148 cgrad        enddo
8149 cgrad      enddo
8150 c1112  continue
8151 cgrad      do m=i+2,j2
8152 cgrad        do ll=1,3
8153 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
8154 cgrad        enddo
8155 cgrad      enddo
8156 cgrad      do m=k+2,l2
8157 cgrad        do ll=1,3
8158 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
8159 cgrad        enddo
8160 cgrad      enddo
8161 cd      do iii=1,nres-3
8162 cd        write (2,*) iii,g_corr5_loc(iii)
8163 cd      enddo
8164       eello5=ekont*eel5
8165 cd      write (2,*) 'ekont',ekont
8166 cd      write (iout,*) 'eello5',ekont*eel5
8167       return
8168       end
8169 c--------------------------------------------------------------------------
8170       double precision function eello6(i,j,k,l,jj,kk)
8171       implicit real*8 (a-h,o-z)
8172       include 'DIMENSIONS'
8173       include 'COMMON.IOUNITS'
8174       include 'COMMON.CHAIN'
8175       include 'COMMON.DERIV'
8176       include 'COMMON.INTERACT'
8177       include 'COMMON.CONTACTS'
8178       include 'COMMON.TORSION'
8179       include 'COMMON.VAR'
8180       include 'COMMON.GEO'
8181       include 'COMMON.FFIELD'
8182       double precision ggg1(3),ggg2(3)
8183 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8184 cd        eello6=0.0d0
8185 cd        return
8186 cd      endif
8187 cd      write (iout,*)
8188 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8189 cd     &   ' and',k,l
8190       eello6_1=0.0d0
8191       eello6_2=0.0d0
8192       eello6_3=0.0d0
8193       eello6_4=0.0d0
8194       eello6_5=0.0d0
8195       eello6_6=0.0d0
8196 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8197 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8198       do iii=1,2
8199         do kkk=1,5
8200           do lll=1,3
8201             derx(lll,kkk,iii)=0.0d0
8202           enddo
8203         enddo
8204       enddo
8205 cd      eij=facont_hb(jj,i)
8206 cd      ekl=facont_hb(kk,k)
8207 cd      ekont=eij*ekl
8208 cd      eij=1.0d0
8209 cd      ekl=1.0d0
8210 cd      ekont=1.0d0
8211       if (l.eq.j+1) then
8212         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8213         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8214         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8215         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8216         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8217         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8218       else
8219         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8220         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8221         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8222         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8223         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8224           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8225         else
8226           eello6_5=0.0d0
8227         endif
8228         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8229       endif
8230 C If turn contributions are considered, they will be handled separately.
8231       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8232 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8233 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8234 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8235 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8236 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8237 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8238 cd      goto 1112
8239       if (j.lt.nres-1) then
8240         j1=j+1
8241         j2=j-1
8242       else
8243         j1=j-1
8244         j2=j-2
8245       endif
8246       if (l.lt.nres-1) then
8247         l1=l+1
8248         l2=l-1
8249       else
8250         l1=l-1
8251         l2=l-2
8252       endif
8253       do ll=1,3
8254 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8255 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8256 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8257 cgrad        ghalf=0.5d0*ggg1(ll)
8258 cd        ghalf=0.0d0
8259         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8260         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8261         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8262         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8263         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8264         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8265         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8266         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8267 cgrad        ghalf=0.5d0*ggg2(ll)
8268 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8269 cd        ghalf=0.0d0
8270         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8271         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8272         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8273         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8274         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8275         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8276       enddo
8277 cd      goto 1112
8278 cgrad      do m=i+1,j-1
8279 cgrad        do ll=1,3
8280 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8281 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8282 cgrad        enddo
8283 cgrad      enddo
8284 cgrad      do m=k+1,l-1
8285 cgrad        do ll=1,3
8286 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8287 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8288 cgrad        enddo
8289 cgrad      enddo
8290 cgrad1112  continue
8291 cgrad      do m=i+2,j2
8292 cgrad        do ll=1,3
8293 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8294 cgrad        enddo
8295 cgrad      enddo
8296 cgrad      do m=k+2,l2
8297 cgrad        do ll=1,3
8298 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8299 cgrad        enddo
8300 cgrad      enddo
8301 cd      do iii=1,nres-3
8302 cd        write (2,*) iii,g_corr6_loc(iii)
8303 cd      enddo
8304       eello6=ekont*eel6
8305 cd      write (2,*) 'ekont',ekont
8306 cd      write (iout,*) 'eello6',ekont*eel6
8307       return
8308       end
8309 c--------------------------------------------------------------------------
8310       double precision function eello6_graph1(i,j,k,l,imat,swap)
8311       implicit real*8 (a-h,o-z)
8312       include 'DIMENSIONS'
8313       include 'COMMON.IOUNITS'
8314       include 'COMMON.CHAIN'
8315       include 'COMMON.DERIV'
8316       include 'COMMON.INTERACT'
8317       include 'COMMON.CONTACTS'
8318       include 'COMMON.TORSION'
8319       include 'COMMON.VAR'
8320       include 'COMMON.GEO'
8321       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8322       logical swap
8323       logical lprn
8324       common /kutas/ lprn
8325 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8326 C
8327 C      Parallel       Antiparallel
8328 C
8329 C          o             o
8330 C         /l\           /j\
8331 C        /   \         /   \
8332 C       /| o |         | o |\
8333 C     \ j|/k\|  /   \  |/k\|l /
8334 C      \ /   \ /     \ /   \ /
8335 C       o     o       o     o
8336 C       i             i
8337 C
8338 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8339       itk=itortyp(itype(k))
8340       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8341       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8342       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8343       call transpose2(EUgC(1,1,k),auxmat(1,1))
8344       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8345       vv1(1)=pizda1(1,1)-pizda1(2,2)
8346       vv1(2)=pizda1(1,2)+pizda1(2,1)
8347       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8348       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8349       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8350       s5=scalar2(vv(1),Dtobr2(1,i))
8351 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8352       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8353       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8354      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8355      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8356      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8357      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8358      & +scalar2(vv(1),Dtobr2der(1,i)))
8359       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8360       vv1(1)=pizda1(1,1)-pizda1(2,2)
8361       vv1(2)=pizda1(1,2)+pizda1(2,1)
8362       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8363       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8364       if (l.eq.j+1) then
8365         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8366      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8367      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8368      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8369      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8370       else
8371         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8372      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8373      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8374      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8375      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8376       endif
8377       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8378       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8379       vv1(1)=pizda1(1,1)-pizda1(2,2)
8380       vv1(2)=pizda1(1,2)+pizda1(2,1)
8381       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8382      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8383      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8384      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8385       do iii=1,2
8386         if (swap) then
8387           ind=3-iii
8388         else
8389           ind=iii
8390         endif
8391         do kkk=1,5
8392           do lll=1,3
8393             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8394             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8395             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8396             call transpose2(EUgC(1,1,k),auxmat(1,1))
8397             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8398      &        pizda1(1,1))
8399             vv1(1)=pizda1(1,1)-pizda1(2,2)
8400             vv1(2)=pizda1(1,2)+pizda1(2,1)
8401             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8402             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8403      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8404             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8405      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8406             s5=scalar2(vv(1),Dtobr2(1,i))
8407             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8408           enddo
8409         enddo
8410       enddo
8411       return
8412       end
8413 c----------------------------------------------------------------------------
8414       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8415       implicit real*8 (a-h,o-z)
8416       include 'DIMENSIONS'
8417       include 'COMMON.IOUNITS'
8418       include 'COMMON.CHAIN'
8419       include 'COMMON.DERIV'
8420       include 'COMMON.INTERACT'
8421       include 'COMMON.CONTACTS'
8422       include 'COMMON.TORSION'
8423       include 'COMMON.VAR'
8424       include 'COMMON.GEO'
8425       logical swap
8426       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8427      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8428       logical lprn
8429       common /kutas/ lprn
8430 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8431 C                                                                              C
8432 C      Parallel       Antiparallel                                             C
8433 C                                                                              C
8434 C          o             o                                                     C
8435 C     \   /l\           /j\   /                                                C
8436 C      \ /   \         /   \ /                                                 C
8437 C       o| o |         | o |o                                                  C
8438 C     \ j|/k\|      \  |/k\|l                                                  C
8439 C      \ /   \       \ /   \                                                   C
8440 C       o             o                                                        C
8441 C       i             i                                                        C
8442 C                                                                              C
8443 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8444 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8445 C AL 7/4/01 s1 would occur in the sixth-order moment,
8446 C           but not in a cluster cumulant
8447 #ifdef MOMENT
8448       s1=dip(1,jj,i)*dip(1,kk,k)
8449 #endif
8450       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8451       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8452       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8453       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8454       call transpose2(EUg(1,1,k),auxmat(1,1))
8455       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8456       vv(1)=pizda(1,1)-pizda(2,2)
8457       vv(2)=pizda(1,2)+pizda(2,1)
8458       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8459 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8460 #ifdef MOMENT
8461       eello6_graph2=-(s1+s2+s3+s4)
8462 #else
8463       eello6_graph2=-(s2+s3+s4)
8464 #endif
8465 c      eello6_graph2=-s3
8466 C Derivatives in gamma(i-1)
8467       if (i.gt.1) then
8468 #ifdef MOMENT
8469         s1=dipderg(1,jj,i)*dip(1,kk,k)
8470 #endif
8471         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8472         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8473         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8474         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8475 #ifdef MOMENT
8476         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8477 #else
8478         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8479 #endif
8480 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8481       endif
8482 C Derivatives in gamma(k-1)
8483 #ifdef MOMENT
8484       s1=dip(1,jj,i)*dipderg(1,kk,k)
8485 #endif
8486       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8487       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8488       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8489       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8490       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8491       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8492       vv(1)=pizda(1,1)-pizda(2,2)
8493       vv(2)=pizda(1,2)+pizda(2,1)
8494       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8495 #ifdef MOMENT
8496       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8497 #else
8498       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8499 #endif
8500 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8501 C Derivatives in gamma(j-1) or gamma(l-1)
8502       if (j.gt.1) then
8503 #ifdef MOMENT
8504         s1=dipderg(3,jj,i)*dip(1,kk,k)
8505 #endif
8506         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8507         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8508         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8509         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8510         vv(1)=pizda(1,1)-pizda(2,2)
8511         vv(2)=pizda(1,2)+pizda(2,1)
8512         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8513 #ifdef MOMENT
8514         if (swap) then
8515           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8516         else
8517           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8518         endif
8519 #endif
8520         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8521 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8522       endif
8523 C Derivatives in gamma(l-1) or gamma(j-1)
8524       if (l.gt.1) then
8525 #ifdef MOMENT
8526         s1=dip(1,jj,i)*dipderg(3,kk,k)
8527 #endif
8528         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8529         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8530         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8531         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8532         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8533         vv(1)=pizda(1,1)-pizda(2,2)
8534         vv(2)=pizda(1,2)+pizda(2,1)
8535         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8536 #ifdef MOMENT
8537         if (swap) then
8538           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8539         else
8540           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8541         endif
8542 #endif
8543         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8544 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8545       endif
8546 C Cartesian derivatives.
8547       if (lprn) then
8548         write (2,*) 'In eello6_graph2'
8549         do iii=1,2
8550           write (2,*) 'iii=',iii
8551           do kkk=1,5
8552             write (2,*) 'kkk=',kkk
8553             do jjj=1,2
8554               write (2,'(3(2f10.5),5x)')
8555      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8556             enddo
8557           enddo
8558         enddo
8559       endif
8560       do iii=1,2
8561         do kkk=1,5
8562           do lll=1,3
8563 #ifdef MOMENT
8564             if (iii.eq.1) then
8565               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8566             else
8567               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8568             endif
8569 #endif
8570             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8571      &        auxvec(1))
8572             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8573             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8574      &        auxvec(1))
8575             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8576             call transpose2(EUg(1,1,k),auxmat(1,1))
8577             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8578      &        pizda(1,1))
8579             vv(1)=pizda(1,1)-pizda(2,2)
8580             vv(2)=pizda(1,2)+pizda(2,1)
8581             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8582 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8583 #ifdef MOMENT
8584             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8585 #else
8586             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8587 #endif
8588             if (swap) then
8589               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8590             else
8591               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8592             endif
8593           enddo
8594         enddo
8595       enddo
8596       return
8597       end
8598 c----------------------------------------------------------------------------
8599       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8600       implicit real*8 (a-h,o-z)
8601       include 'DIMENSIONS'
8602       include 'COMMON.IOUNITS'
8603       include 'COMMON.CHAIN'
8604       include 'COMMON.DERIV'
8605       include 'COMMON.INTERACT'
8606       include 'COMMON.CONTACTS'
8607       include 'COMMON.TORSION'
8608       include 'COMMON.VAR'
8609       include 'COMMON.GEO'
8610       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8611       logical swap
8612 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8613 C                                                                              C
8614 C      Parallel       Antiparallel                                             C
8615 C                                                                              C
8616 C          o             o                                                     C
8617 C         /l\   /   \   /j\                                                    C
8618 C        /   \ /     \ /   \                                                   C
8619 C       /| o |o       o| o |\                                                  C
8620 C       j|/k\|  /      |/k\|l /                                                C
8621 C        /   \ /       /   \ /                                                 C
8622 C       /     o       /     o                                                  C
8623 C       i             i                                                        C
8624 C                                                                              C
8625 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8626 C
8627 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8628 C           energy moment and not to the cluster cumulant.
8629       iti=itortyp(itype(i))
8630       if (j.lt.nres-1) then
8631         itj1=itortyp(itype(j+1))
8632       else
8633         itj1=ntortyp+1
8634       endif
8635       itk=itortyp(itype(k))
8636       itk1=itortyp(itype(k+1))
8637       if (l.lt.nres-1) then
8638         itl1=itortyp(itype(l+1))
8639       else
8640         itl1=ntortyp+1
8641       endif
8642 #ifdef MOMENT
8643       s1=dip(4,jj,i)*dip(4,kk,k)
8644 #endif
8645       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8646       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8647       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8648       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8649       call transpose2(EE(1,1,itk),auxmat(1,1))
8650       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8651       vv(1)=pizda(1,1)+pizda(2,2)
8652       vv(2)=pizda(2,1)-pizda(1,2)
8653       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8654 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8655 cd     & "sum",-(s2+s3+s4)
8656 #ifdef MOMENT
8657       eello6_graph3=-(s1+s2+s3+s4)
8658 #else
8659       eello6_graph3=-(s2+s3+s4)
8660 #endif
8661 c      eello6_graph3=-s4
8662 C Derivatives in gamma(k-1)
8663       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8664       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8665       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8666       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8667 C Derivatives in gamma(l-1)
8668       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8669       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8670       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8671       vv(1)=pizda(1,1)+pizda(2,2)
8672       vv(2)=pizda(2,1)-pizda(1,2)
8673       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8674       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8675 C Cartesian derivatives.
8676       do iii=1,2
8677         do kkk=1,5
8678           do lll=1,3
8679 #ifdef MOMENT
8680             if (iii.eq.1) then
8681               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8682             else
8683               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8684             endif
8685 #endif
8686             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8687      &        auxvec(1))
8688             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8689             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8690      &        auxvec(1))
8691             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8692             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8693      &        pizda(1,1))
8694             vv(1)=pizda(1,1)+pizda(2,2)
8695             vv(2)=pizda(2,1)-pizda(1,2)
8696             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8697 #ifdef MOMENT
8698             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8699 #else
8700             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8701 #endif
8702             if (swap) then
8703               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8704             else
8705               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8706             endif
8707 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8708           enddo
8709         enddo
8710       enddo
8711       return
8712       end
8713 c----------------------------------------------------------------------------
8714       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8715       implicit real*8 (a-h,o-z)
8716       include 'DIMENSIONS'
8717       include 'COMMON.IOUNITS'
8718       include 'COMMON.CHAIN'
8719       include 'COMMON.DERIV'
8720       include 'COMMON.INTERACT'
8721       include 'COMMON.CONTACTS'
8722       include 'COMMON.TORSION'
8723       include 'COMMON.VAR'
8724       include 'COMMON.GEO'
8725       include 'COMMON.FFIELD'
8726       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8727      & auxvec1(2),auxmat1(2,2)
8728       logical swap
8729 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8730 C                                                                              C
8731 C      Parallel       Antiparallel                                             C
8732 C                                                                              C
8733 C          o             o                                                     C
8734 C         /l\   /   \   /j\                                                    C
8735 C        /   \ /     \ /   \                                                   C
8736 C       /| o |o       o| o |\                                                  C
8737 C     \ j|/k\|      \  |/k\|l                                                  C
8738 C      \ /   \       \ /   \                                                   C
8739 C       o     \       o     \                                                  C
8740 C       i             i                                                        C
8741 C                                                                              C
8742 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8743 C
8744 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8745 C           energy moment and not to the cluster cumulant.
8746 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8747       iti=itortyp(itype(i))
8748       itj=itortyp(itype(j))
8749       if (j.lt.nres-1) then
8750         itj1=itortyp(itype(j+1))
8751       else
8752         itj1=ntortyp+1
8753       endif
8754       itk=itortyp(itype(k))
8755       if (k.lt.nres-1) then
8756         itk1=itortyp(itype(k+1))
8757       else
8758         itk1=ntortyp+1
8759       endif
8760       itl=itortyp(itype(l))
8761       if (l.lt.nres-1) then
8762         itl1=itortyp(itype(l+1))
8763       else
8764         itl1=ntortyp+1
8765       endif
8766 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8767 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8768 cd     & ' itl',itl,' itl1',itl1
8769 #ifdef MOMENT
8770       if (imat.eq.1) then
8771         s1=dip(3,jj,i)*dip(3,kk,k)
8772       else
8773         s1=dip(2,jj,j)*dip(2,kk,l)
8774       endif
8775 #endif
8776       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8777       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8778       if (j.eq.l+1) then
8779         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8780         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8781       else
8782         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8783         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8784       endif
8785       call transpose2(EUg(1,1,k),auxmat(1,1))
8786       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8787       vv(1)=pizda(1,1)-pizda(2,2)
8788       vv(2)=pizda(2,1)+pizda(1,2)
8789       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8790 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8791 #ifdef MOMENT
8792       eello6_graph4=-(s1+s2+s3+s4)
8793 #else
8794       eello6_graph4=-(s2+s3+s4)
8795 #endif
8796 C Derivatives in gamma(i-1)
8797       if (i.gt.1) then
8798 #ifdef MOMENT
8799         if (imat.eq.1) then
8800           s1=dipderg(2,jj,i)*dip(3,kk,k)
8801         else
8802           s1=dipderg(4,jj,j)*dip(2,kk,l)
8803         endif
8804 #endif
8805         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8806         if (j.eq.l+1) then
8807           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8808           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8809         else
8810           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8811           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8812         endif
8813         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8814         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8815 cd          write (2,*) 'turn6 derivatives'
8816 #ifdef MOMENT
8817           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8818 #else
8819           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8820 #endif
8821         else
8822 #ifdef MOMENT
8823           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8824 #else
8825           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8826 #endif
8827         endif
8828       endif
8829 C Derivatives in gamma(k-1)
8830 #ifdef MOMENT
8831       if (imat.eq.1) then
8832         s1=dip(3,jj,i)*dipderg(2,kk,k)
8833       else
8834         s1=dip(2,jj,j)*dipderg(4,kk,l)
8835       endif
8836 #endif
8837       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8838       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8839       if (j.eq.l+1) then
8840         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8841         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8842       else
8843         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8844         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8845       endif
8846       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8847       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8848       vv(1)=pizda(1,1)-pizda(2,2)
8849       vv(2)=pizda(2,1)+pizda(1,2)
8850       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8851       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8852 #ifdef MOMENT
8853         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8854 #else
8855         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8856 #endif
8857       else
8858 #ifdef MOMENT
8859         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8860 #else
8861         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8862 #endif
8863       endif
8864 C Derivatives in gamma(j-1) or gamma(l-1)
8865       if (l.eq.j+1 .and. l.gt.1) then
8866         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8867         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8868         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8869         vv(1)=pizda(1,1)-pizda(2,2)
8870         vv(2)=pizda(2,1)+pizda(1,2)
8871         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8872         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8873       else if (j.gt.1) then
8874         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8875         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8876         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8877         vv(1)=pizda(1,1)-pizda(2,2)
8878         vv(2)=pizda(2,1)+pizda(1,2)
8879         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8880         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8881           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8882         else
8883           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8884         endif
8885       endif
8886 C Cartesian derivatives.
8887       do iii=1,2
8888         do kkk=1,5
8889           do lll=1,3
8890 #ifdef MOMENT
8891             if (iii.eq.1) then
8892               if (imat.eq.1) then
8893                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8894               else
8895                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8896               endif
8897             else
8898               if (imat.eq.1) then
8899                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8900               else
8901                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8902               endif
8903             endif
8904 #endif
8905             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8906      &        auxvec(1))
8907             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8908             if (j.eq.l+1) then
8909               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8910      &          b1(1,itj1),auxvec(1))
8911               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8912             else
8913               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8914      &          b1(1,itl1),auxvec(1))
8915               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8916             endif
8917             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8918      &        pizda(1,1))
8919             vv(1)=pizda(1,1)-pizda(2,2)
8920             vv(2)=pizda(2,1)+pizda(1,2)
8921             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8922             if (swap) then
8923               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8924 #ifdef MOMENT
8925                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8926      &             -(s1+s2+s4)
8927 #else
8928                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8929      &             -(s2+s4)
8930 #endif
8931                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8932               else
8933 #ifdef MOMENT
8934                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8935 #else
8936                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8937 #endif
8938                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8939               endif
8940             else
8941 #ifdef MOMENT
8942               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8943 #else
8944               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8945 #endif
8946               if (l.eq.j+1) then
8947                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8948               else
8949                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8950               endif
8951             endif
8952           enddo
8953         enddo
8954       enddo
8955       return
8956       end
8957 c----------------------------------------------------------------------------
8958       double precision function eello_turn6(i,jj,kk)
8959       implicit real*8 (a-h,o-z)
8960       include 'DIMENSIONS'
8961       include 'COMMON.IOUNITS'
8962       include 'COMMON.CHAIN'
8963       include 'COMMON.DERIV'
8964       include 'COMMON.INTERACT'
8965       include 'COMMON.CONTACTS'
8966       include 'COMMON.TORSION'
8967       include 'COMMON.VAR'
8968       include 'COMMON.GEO'
8969       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8970      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8971      &  ggg1(3),ggg2(3)
8972       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8973      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8974 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8975 C           the respective energy moment and not to the cluster cumulant.
8976       s1=0.0d0
8977       s8=0.0d0
8978       s13=0.0d0
8979 c
8980       eello_turn6=0.0d0
8981       j=i+4
8982       k=i+1
8983       l=i+3
8984       iti=itortyp(itype(i))
8985       itk=itortyp(itype(k))
8986       itk1=itortyp(itype(k+1))
8987       itl=itortyp(itype(l))
8988       itj=itortyp(itype(j))
8989 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8990 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8991 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8992 cd        eello6=0.0d0
8993 cd        return
8994 cd      endif
8995 cd      write (iout,*)
8996 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8997 cd     &   ' and',k,l
8998 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8999       do iii=1,2
9000         do kkk=1,5
9001           do lll=1,3
9002             derx_turn(lll,kkk,iii)=0.0d0
9003           enddo
9004         enddo
9005       enddo
9006 cd      eij=1.0d0
9007 cd      ekl=1.0d0
9008 cd      ekont=1.0d0
9009       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9010 cd      eello6_5=0.0d0
9011 cd      write (2,*) 'eello6_5',eello6_5
9012 #ifdef MOMENT
9013       call transpose2(AEA(1,1,1),auxmat(1,1))
9014       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
9015       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
9016       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
9017 #endif
9018       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9019       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
9020       s2 = scalar2(b1(1,itk),vtemp1(1))
9021 #ifdef MOMENT
9022       call transpose2(AEA(1,1,2),atemp(1,1))
9023       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
9024       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
9025       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9026 #endif
9027       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
9028       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
9029       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
9030 #ifdef MOMENT
9031       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
9032       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
9033       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
9034       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
9035       ss13 = scalar2(b1(1,itk),vtemp4(1))
9036       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
9037 #endif
9038 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
9039 c      s1=0.0d0
9040 c      s2=0.0d0
9041 c      s8=0.0d0
9042 c      s12=0.0d0
9043 c      s13=0.0d0
9044       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
9045 C Derivatives in gamma(i+2)
9046       s1d =0.0d0
9047       s8d =0.0d0
9048 #ifdef MOMENT
9049       call transpose2(AEA(1,1,1),auxmatd(1,1))
9050       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9051       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9052       call transpose2(AEAderg(1,1,2),atempd(1,1))
9053       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9054       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9055 #endif
9056       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
9057       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9058       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9059 c      s1d=0.0d0
9060 c      s2d=0.0d0
9061 c      s8d=0.0d0
9062 c      s12d=0.0d0
9063 c      s13d=0.0d0
9064       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
9065 C Derivatives in gamma(i+3)
9066 #ifdef MOMENT
9067       call transpose2(AEA(1,1,1),auxmatd(1,1))
9068       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9069       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
9070       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
9071 #endif
9072       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
9073       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
9074       s2d = scalar2(b1(1,itk),vtemp1d(1))
9075 #ifdef MOMENT
9076       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
9077       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
9078 #endif
9079       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
9080 #ifdef MOMENT
9081       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
9082       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9083       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9084 #endif
9085 c      s1d=0.0d0
9086 c      s2d=0.0d0
9087 c      s8d=0.0d0
9088 c      s12d=0.0d0
9089 c      s13d=0.0d0
9090 #ifdef MOMENT
9091       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9092      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9093 #else
9094       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9095      &               -0.5d0*ekont*(s2d+s12d)
9096 #endif
9097 C Derivatives in gamma(i+4)
9098       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
9099       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9100       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9101 #ifdef MOMENT
9102       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
9103       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
9104       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9105 #endif
9106 c      s1d=0.0d0
9107 c      s2d=0.0d0
9108 c      s8d=0.0d0
9109 C      s12d=0.0d0
9110 c      s13d=0.0d0
9111 #ifdef MOMENT
9112       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
9113 #else
9114       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
9115 #endif
9116 C Derivatives in gamma(i+5)
9117 #ifdef MOMENT
9118       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
9119       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9120       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9121 #endif
9122       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
9123       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
9124       s2d = scalar2(b1(1,itk),vtemp1d(1))
9125 #ifdef MOMENT
9126       call transpose2(AEA(1,1,2),atempd(1,1))
9127       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
9128       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9129 #endif
9130       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
9131       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9132 #ifdef MOMENT
9133       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
9134       ss13d = scalar2(b1(1,itk),vtemp4d(1))
9135       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9136 #endif
9137 c      s1d=0.0d0
9138 c      s2d=0.0d0
9139 c      s8d=0.0d0
9140 c      s12d=0.0d0
9141 c      s13d=0.0d0
9142 #ifdef MOMENT
9143       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9144      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9145 #else
9146       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9147      &               -0.5d0*ekont*(s2d+s12d)
9148 #endif
9149 C Cartesian derivatives
9150       do iii=1,2
9151         do kkk=1,5
9152           do lll=1,3
9153 #ifdef MOMENT
9154             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
9155             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9156             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9157 #endif
9158             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9159             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
9160      &          vtemp1d(1))
9161             s2d = scalar2(b1(1,itk),vtemp1d(1))
9162 #ifdef MOMENT
9163             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
9164             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9165             s8d = -(atempd(1,1)+atempd(2,2))*
9166      &           scalar2(cc(1,1,itl),vtemp2(1))
9167 #endif
9168             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
9169      &           auxmatd(1,1))
9170             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9171             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9172 c      s1d=0.0d0
9173 c      s2d=0.0d0
9174 c      s8d=0.0d0
9175 c      s12d=0.0d0
9176 c      s13d=0.0d0
9177 #ifdef MOMENT
9178             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9179      &        - 0.5d0*(s1d+s2d)
9180 #else
9181             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9182      &        - 0.5d0*s2d
9183 #endif
9184 #ifdef MOMENT
9185             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9186      &        - 0.5d0*(s8d+s12d)
9187 #else
9188             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9189      &        - 0.5d0*s12d
9190 #endif
9191           enddo
9192         enddo
9193       enddo
9194 #ifdef MOMENT
9195       do kkk=1,5
9196         do lll=1,3
9197           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9198      &      achuj_tempd(1,1))
9199           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9200           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9201           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9202           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9203           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9204      &      vtemp4d(1))
9205           ss13d = scalar2(b1(1,itk),vtemp4d(1))
9206           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9207           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9208         enddo
9209       enddo
9210 #endif
9211 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9212 cd     &  16*eel_turn6_num
9213 cd      goto 1112
9214       if (j.lt.nres-1) then
9215         j1=j+1
9216         j2=j-1
9217       else
9218         j1=j-1
9219         j2=j-2
9220       endif
9221       if (l.lt.nres-1) then
9222         l1=l+1
9223         l2=l-1
9224       else
9225         l1=l-1
9226         l2=l-2
9227       endif
9228       do ll=1,3
9229 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9230 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9231 cgrad        ghalf=0.5d0*ggg1(ll)
9232 cd        ghalf=0.0d0
9233         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9234         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9235         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9236      &    +ekont*derx_turn(ll,2,1)
9237         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9238         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9239      &    +ekont*derx_turn(ll,4,1)
9240         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9241         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9242         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9243 cgrad        ghalf=0.5d0*ggg2(ll)
9244 cd        ghalf=0.0d0
9245         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9246      &    +ekont*derx_turn(ll,2,2)
9247         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9248         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9249      &    +ekont*derx_turn(ll,4,2)
9250         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9251         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9252         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9253       enddo
9254 cd      goto 1112
9255 cgrad      do m=i+1,j-1
9256 cgrad        do ll=1,3
9257 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9258 cgrad        enddo
9259 cgrad      enddo
9260 cgrad      do m=k+1,l-1
9261 cgrad        do ll=1,3
9262 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9263 cgrad        enddo
9264 cgrad      enddo
9265 cgrad1112  continue
9266 cgrad      do m=i+2,j2
9267 cgrad        do ll=1,3
9268 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9269 cgrad        enddo
9270 cgrad      enddo
9271 cgrad      do m=k+2,l2
9272 cgrad        do ll=1,3
9273 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9274 cgrad        enddo
9275 cgrad      enddo
9276 cd      do iii=1,nres-3
9277 cd        write (2,*) iii,g_corr6_loc(iii)
9278 cd      enddo
9279       eello_turn6=ekont*eel_turn6
9280 cd      write (2,*) 'ekont',ekont
9281 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9282       return
9283       end
9284
9285 C-----------------------------------------------------------------------------
9286       double precision function scalar(u,v)
9287 !DIR$ INLINEALWAYS scalar
9288 #ifndef OSF
9289 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9290 #endif
9291       implicit none
9292       double precision u(3),v(3)
9293 cd      double precision sc
9294 cd      integer i
9295 cd      sc=0.0d0
9296 cd      do i=1,3
9297 cd        sc=sc+u(i)*v(i)
9298 cd      enddo
9299 cd      scalar=sc
9300
9301       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9302       return
9303       end
9304 crc-------------------------------------------------
9305       SUBROUTINE MATVEC2(A1,V1,V2)
9306 !DIR$ INLINEALWAYS MATVEC2
9307 #ifndef OSF
9308 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9309 #endif
9310       implicit real*8 (a-h,o-z)
9311       include 'DIMENSIONS'
9312       DIMENSION A1(2,2),V1(2),V2(2)
9313 c      DO 1 I=1,2
9314 c        VI=0.0
9315 c        DO 3 K=1,2
9316 c    3     VI=VI+A1(I,K)*V1(K)
9317 c        Vaux(I)=VI
9318 c    1 CONTINUE
9319
9320       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9321       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9322
9323       v2(1)=vaux1
9324       v2(2)=vaux2
9325       END
9326 C---------------------------------------
9327       SUBROUTINE MATMAT2(A1,A2,A3)
9328 #ifndef OSF
9329 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9330 #endif
9331       implicit real*8 (a-h,o-z)
9332       include 'DIMENSIONS'
9333       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9334 c      DIMENSION AI3(2,2)
9335 c        DO  J=1,2
9336 c          A3IJ=0.0
9337 c          DO K=1,2
9338 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9339 c          enddo
9340 c          A3(I,J)=A3IJ
9341 c       enddo
9342 c      enddo
9343
9344       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9345       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9346       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9347       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9348
9349       A3(1,1)=AI3_11
9350       A3(2,1)=AI3_21
9351       A3(1,2)=AI3_12
9352       A3(2,2)=AI3_22
9353       END
9354
9355 c-------------------------------------------------------------------------
9356       double precision function scalar2(u,v)
9357 !DIR$ INLINEALWAYS scalar2
9358       implicit none
9359       double precision u(2),v(2)
9360       double precision sc
9361       integer i
9362       scalar2=u(1)*v(1)+u(2)*v(2)
9363       return
9364       end
9365
9366 C-----------------------------------------------------------------------------
9367
9368       subroutine transpose2(a,at)
9369 !DIR$ INLINEALWAYS transpose2
9370 #ifndef OSF
9371 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9372 #endif
9373       implicit none
9374       double precision a(2,2),at(2,2)
9375       at(1,1)=a(1,1)
9376       at(1,2)=a(2,1)
9377       at(2,1)=a(1,2)
9378       at(2,2)=a(2,2)
9379       return
9380       end
9381 c--------------------------------------------------------------------------
9382       subroutine transpose(n,a,at)
9383       implicit none
9384       integer n,i,j
9385       double precision a(n,n),at(n,n)
9386       do i=1,n
9387         do j=1,n
9388           at(j,i)=a(i,j)
9389         enddo
9390       enddo
9391       return
9392       end
9393 C---------------------------------------------------------------------------
9394       subroutine prodmat3(a1,a2,kk,transp,prod)
9395 !DIR$ INLINEALWAYS prodmat3
9396 #ifndef OSF
9397 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9398 #endif
9399       implicit none
9400       integer i,j
9401       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9402       logical transp
9403 crc      double precision auxmat(2,2),prod_(2,2)
9404
9405       if (transp) then
9406 crc        call transpose2(kk(1,1),auxmat(1,1))
9407 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9408 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9409
9410            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9411      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9412            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9413      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9414            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9415      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9416            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9417      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9418
9419       else
9420 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9421 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9422
9423            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9424      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9425            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9426      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9427            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9428      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9429            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9430      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9431
9432       endif
9433 c      call transpose2(a2(1,1),a2t(1,1))
9434
9435 crc      print *,transp
9436 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9437 crc      print *,((prod(i,j),i=1,2),j=1,2)
9438
9439       return
9440       end
9441