source/unres/src_MIN/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         time00=MPI_Wtime()
  32 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  33         if (fg_rank.eq.0) then
  34           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  35 c          print *,"Processor",myrank," BROADCAST iorder"
  36 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  37 C FG slaves as WEIGHTS array.
  38           weights_(1)=wsc
  39           weights_(2)=wscp
  40           weights_(3)=welec
  41           weights_(4)=wcorr
  42           weights_(5)=wcorr5
  43           weights_(6)=wcorr6
  44           weights_(7)=wel_loc
  45           weights_(8)=wturn3
  46           weights_(9)=wturn4
  47           weights_(10)=wturn6
  48           weights_(11)=wang
  49           weights_(12)=wscloc
  50           weights_(13)=wtor
  51           weights_(14)=wtor_d
  52           weights_(15)=wstrain
  53           weights_(16)=wvdwpp
  54           weights_(17)=wbond
  55           weights_(18)=scal14
  56           weights_(21)=wsccor
  57           weights_(22)=wsct
  58 C FG Master broadcasts the WEIGHTS_ array
  59           call MPI_Bcast(weights_(1),n_ene,
  60      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  61         else
  62 C FG slaves receive the WEIGHTS array
  63           call MPI_Bcast(weights(1),n_ene,
  64      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  65           wsc=weights(1)
  66           wscp=weights(2)
  67           welec=weights(3)
  68           wcorr=weights(4)
  69           wcorr5=weights(5)
  70           wcorr6=weights(6)
  71           wel_loc=weights(7)
  72           wturn3=weights(8)
  73           wturn4=weights(9)
  74           wturn6=weights(10)
  75           wang=weights(11)
  76           wscloc=weights(12)
  77           wtor=weights(13)
  78           wtor_d=weights(14)
  79           wstrain=weights(15)
  80           wvdwpp=weights(16)
  81           wbond=weights(17)
  82           scal14=weights(18)
  83           wsccor=weights(21)
  84           wsct=weights(22)
  85         endif
  86         time_Bcast=time_Bcast+MPI_Wtime()-time00
  87         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  88 c        call chainbuild_cart
  89       endif
  90 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
  91 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  92 #else
  93 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  94 c        call int_from_cart1(.false.)
  95 c      endif
  96 #endif
  97 #ifdef TIMING
  98       time00=MPI_Wtime()
  99 #endif
 100 C
 101 C Compute the side-chain and electrostatic interaction energy
 102 C
 103       goto (101,102,103,104,105,106) ipot
 104 C Lennard-Jones potential.
 105   101 call elj(evdw,evdw_p,evdw_m)
 106 cd    print '(a)','Exit ELJ'
 107       goto 107
 108 C Lennard-Jones-Kihara potential (shifted).
 109   102 call eljk(evdw,evdw_p,evdw_m)
 110       goto 107
 111 C Berne-Pechukas potential (dilated LJ, angular dependence).
 112   103 call ebp(evdw,evdw_p,evdw_m)
 113       goto 107
 114 C Gay-Berne potential (shifted LJ, angular dependence).
 115   104 call egb(evdw,evdw_p,evdw_m)
 116       goto 107
 117 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 118   105 call egbv(evdw,evdw_p,evdw_m)
 119       goto 107
 120 C Soft-sphere potential
 121   106 call e_softsphere(evdw)
 122 C
 123 C Calculate electrostatic (H-bonding) energy of the main chain.
 124 C
 125   107 continue
 126 c      print *,"Processor",myrank," computed USCSC"
 127 #ifdef TIMING
 128       time01=MPI_Wtime()
 129 #endif
 130       call vec_and_deriv
 131 #ifdef TIMING
 132       time_vec=time_vec+MPI_Wtime()-time01
 133 #endif
 134 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 135       if (ipot.lt.6) then
 136 #ifdef SPLITELE
 137          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 138      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 139      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 140      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 141 #else
 142          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 143      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 144      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 145      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 146 #endif
 147             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 148          else
 149             ees=0.0d0
 150             evdw1=0.0d0
 151             eel_loc=0.0d0
 152             eello_turn3=0.0d0
 153             eello_turn4=0.0d0
 154          endif
 155       else
 156 c        write (iout,*) "Soft-spheer ELEC potential"
 157         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 158      &   eello_turn4)
 159       endif
 160 c      print *,"Processor",myrank," computed UELEC"
 161 C
 162 C Calculate excluded-volume interaction energy between peptide groups
 163 C and side chains.
 164 C
 165       if (ipot.lt.6) then
 166        if(wscp.gt.0d0) then
 167         call escp(evdw2,evdw2_14)
 168        else
 169         evdw2=0
 170         evdw2_14=0
 171        endif
 172       else
 173 c        write (iout,*) "Soft-sphere SCP potential"
 174         call escp_soft_sphere(evdw2,evdw2_14)
 175       endif
 176 c
 177 c Calculate the bond-stretching energy
 178 c
 179       call ebond(estr)
 180 C
 181 C Calculate the disulfide-bridge and other energy and the contributions
 182 C from other distance constraints.
 183 cd    print *,'Calling EHPB'
 184       call edis(ehpb)
 185 cd    print *,'EHPB exitted succesfully.'
 186 C
 187 C Calculate the virtual-bond-angle energy.
 188 C
 189       if (wang.gt.0d0) then
 190         call ebend(ebe)
 191       else
 192         ebe=0
 193       endif
 194 c      print *,"Processor",myrank," computed UB"
 195 C
 196 C Calculate the SC local energy.
 197 C
 198       call esc(escloc)
 199 c      print *,"Processor",myrank," computed USC"
 200 C
 201 C Calculate the virtual-bond torsional energy.
 202 C
 203 cd    print *,'nterm=',nterm
 204       if (wtor.gt.0) then
 205        call etor(etors,edihcnstr)
 206       else
 207        etors=0
 208        edihcnstr=0
 209       endif
 210 c      print *,"Processor",myrank," computed Utor"
 211 C
 212 C 6/23/01 Calculate double-torsional energy
 213 C
 214       if (wtor_d.gt.0) then
 215        call etor_d(etors_d)
 216       else
 217        etors_d=0
 218       endif
 219 c      print *,"Processor",myrank," computed Utord"
 220 C
 221 C 21/5/07 Calculate local sicdechain correlation energy
 222 C
 223       if (wsccor.gt.0.0d0) then
 224         call eback_sc_corr(esccor)
 225       else
 226         esccor=0.0d0
 227       endif
 228 c      print *,"Processor",myrank," computed Usccorr"
 229 C
 230 C 12/1/95 Multi-body terms
 231 C
 232       n_corr=0
 233       n_corr1=0
 234       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 235      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 236          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 237 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 238 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 239       else
 240          ecorr=0.0d0
 241          ecorr5=0.0d0
 242          ecorr6=0.0d0
 243          eturn6=0.0d0
 244       endif
 245       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 246          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 247 cd         write (iout,*) "multibody_hb ecorr",ecorr
 248       endif
 249 c      print *,"Processor",myrank," computed Ucorr"
 250 C
 251 C If performing constraint dynamics, call the constraint energy
 252 C  after the equilibration time
 253       if(usampl.and.totT.gt.eq_time) then
 254 c         call EconstrQ
 255          call Econstr_back
 256       else
 257          Uconst=0.0d0
 258          Uconst_back=0.0d0
 259       endif
 260 #ifdef TIMING
 261       time_enecalc=time_enecalc+MPI_Wtime()-time00
 262 #endif
 263 c      print *,"Processor",myrank," computed Uconstr"
 264 #ifdef TIMING
 265       time00=MPI_Wtime()
 266 #endif
 267 c
 268 C Sum the energies
 269 C
 270       energia(1)=evdw
 271 #ifdef SCP14
 272       energia(2)=evdw2-evdw2_14
 273       energia(18)=evdw2_14
 274 #else
 275       energia(2)=evdw2
 276       energia(18)=0.0d0
 277 #endif
 278 #ifdef SPLITELE
 279       energia(3)=ees
 280       energia(16)=evdw1
 281 #else
 282       energia(3)=ees+evdw1
 283       energia(16)=0.0d0
 284 #endif
 285       energia(4)=ecorr
 286       energia(5)=ecorr5
 287       energia(6)=ecorr6
 288       energia(7)=eel_loc
 289       energia(8)=eello_turn3
 290       energia(9)=eello_turn4
 291       energia(10)=eturn6
 292       energia(11)=ebe
 293       energia(12)=escloc
 294       energia(13)=etors
 295       energia(14)=etors_d
 296       energia(15)=ehpb
 297       energia(19)=edihcnstr
 298       energia(17)=estr
 299       energia(20)=Uconst+Uconst_back
 300       energia(21)=esccor
 301       energia(22)=evdw_p
 302       energia(23)=evdw_m
 303 c      print *," Processor",myrank," calls SUM_ENERGY"
 304       call sum_energy(energia,.true.)
 305 c      print *," Processor",myrank," left SUM_ENERGY"
 306 #ifdef TIMING
 307       time_sumene=time_sumene+MPI_Wtime()-time00
 308 #endif
 309       return
 310       end
 311 c-------------------------------------------------------------------------------
 312       subroutine sum_energy(energia,reduce)
 313       implicit real*8 (a-h,o-z)
 314       include 'DIMENSIONS'
 315 #ifndef ISNAN
 316       external proc_proc
 317 #ifdef WINPGI
 318 cMS$ATTRIBUTES C ::  proc_proc
 319 #endif
 320 #endif
 321 #ifdef MPI
 322       include "mpif.h"
 323 #endif
 324       include 'COMMON.SETUP'
 325       include 'COMMON.IOUNITS'
 326       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 327       include 'COMMON.FFIELD'
 328       include 'COMMON.DERIV'
 329       include 'COMMON.INTERACT'
 330       include 'COMMON.SBRIDGE'
 331       include 'COMMON.CHAIN'
 332       include 'COMMON.VAR'
 333       include 'COMMON.CONTROL'
 334       include 'COMMON.TIME1'
 335       logical reduce
 336 #ifdef MPI
 337       if (nfgtasks.gt.1 .and. reduce) then
 338 #ifdef DEBUG
 339         write (iout,*) "energies before REDUCE"
 340         call enerprint(energia)
 341         call flush(iout)
 342 #endif
 343         do i=0,n_ene
 344           enebuff(i)=energia(i)
 345         enddo
 346         time00=MPI_Wtime()
 347         call MPI_Barrier(FG_COMM,IERR)
 348         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 349         time00=MPI_Wtime()
 350         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 351      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 352 #ifdef DEBUG
 353         write (iout,*) "energies after REDUCE"
 354         call enerprint(energia)
 355         call flush(iout)
 356 #endif
 357         time_Reduce=time_Reduce+MPI_Wtime()-time00
 358       endif
 359       if (fg_rank.eq.0) then
 360 #endif
 361 #ifdef TSCSC
 362       evdw=energia(22)+wsct*energia(23)
 363 #else
 364       evdw=energia(1)
 365 #endif
 366 #ifdef SCP14
 367       evdw2=energia(2)+energia(18)
 368       evdw2_14=energia(18)
 369 #else
 370       evdw2=energia(2)
 371 #endif
 372 #ifdef SPLITELE
 373       ees=energia(3)
 374       evdw1=energia(16)
 375 #else
 376       ees=energia(3)
 377       evdw1=0.0d0
 378 #endif
 379       ecorr=energia(4)
 380       ecorr5=energia(5)
 381       ecorr6=energia(6)
 382       eel_loc=energia(7)
 383       eello_turn3=energia(8)
 384       eello_turn4=energia(9)
 385       eturn6=energia(10)
 386       ebe=energia(11)
 387       escloc=energia(12)
 388       etors=energia(13)
 389       etors_d=energia(14)
 390       ehpb=energia(15)
 391       edihcnstr=energia(19)
 392       estr=energia(17)
 393       Uconst=energia(20)
 394       esccor=energia(21)
 395 #ifdef SPLITELE
 396       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 397      & +wang*ebe+wtor*etors+wscloc*escloc
 398      & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5
 399      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 400      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 401      & +wbond*estr+Uconst+wsccor*esccor
 402 #else
 403       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 404      & +wang*ebe+wtor*etors+wscloc*escloc
 405      & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5
 406      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 407      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 408      & +wbond*estr+Uconst+wsccor*esccor
 409 #endif
 410       energia(0)=etot
 411 c detecting NaNQ
 412 #ifdef ISNAN
 413 #ifdef AIX
 414       if (isnan(etot).ne.0) energia(0)=1.0d+99
 415 #else
 416       if (isnan(etot)) energia(0)=1.0d+99
 417 #endif
 418 #else
 419       i=0
 420 #ifdef WINPGI
 421       idumm=proc_proc(etot,i)
 422 #else
 423       call proc_proc(etot,i)
 424 #endif
 425       if(i.eq.1)energia(0)=1.0d+99
 426 #endif
 427 #ifdef MPI
 428       endif
 429 #endif
 430       return
 431       end
 432 c-------------------------------------------------------------------------------
 433       subroutine sum_gradient
 434       implicit real*8 (a-h,o-z)
 435       include 'DIMENSIONS'
 436 #ifndef ISNAN
 437       external proc_proc
 438 #ifdef WINPGI
 439 cMS$ATTRIBUTES C ::  proc_proc
 440 #endif
 441 #endif
 442 #ifdef MPI
 443       include 'mpif.h'
 444       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 445      &  glocbuf(4*maxres),gradbufc_sum(3,maxres)
 446 #else
 447       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 448      &  glocbuf(4*maxres),gradbufc_sum(3,maxres)
 449 #endif
 450       include 'COMMON.SETUP'
 451       include 'COMMON.IOUNITS'
 452       include 'COMMON.FFIELD'
 453       include 'COMMON.DERIV'
 454       include 'COMMON.INTERACT'
 455       include 'COMMON.SBRIDGE'
 456       include 'COMMON.CHAIN'
 457       include 'COMMON.VAR'
 458       include 'COMMON.CONTROL'
 459       include 'COMMON.TIME1'
 460       include 'COMMON.MAXGRAD'
 461 #ifdef TIMING
 462       time01=MPI_Wtime()
 463 #endif
 464 #ifdef DEBUG
 465       write (iout,*) "sum_gradient gvdwc, gvdwx"
 466       do i=1,nres
 467         write (iout,'(i3,3f10.5,5x,3f10.5,5x,3f10.5,5x,3f10.5)')
 468      &   i,(gvdwx(j,i),j=1,3),(gvdwcT(j,i),j=1,3),(gvdwc(j,i),j=1,3),
 469      &   (gvdwcT(j,i),j=1,3)
 470       enddo
 471       call flush(iout)
 472 #endif
 473 #ifdef MPI
 474 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 475         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 476      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 477 #endif
 478 C
 479 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 480 C            in virtual-bond-vector coordinates
 481 C
 482 #ifdef DEBUG
 483 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 484 c      do i=1,nres-1
 485 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 486 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 487 c      enddo
 488 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 489 c      do i=1,nres-1
 490 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 491 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 492 c      enddo
 493       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 494       do i=1,nres
 495         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 496      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 497      &   g_corr5_loc(i)
 498       enddo
 499       call flush(iout)
 500 #endif
 501 #ifdef SPLITELE
 502 #ifdef TSCSC
 503       do i=1,nct
 504         do j=1,3
 505           gradbufc(j,i)=wsc*gvdwc(j,i)+wsc*wscT*gvdwcT(j,i)+
 506      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 507      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 508      &                wel_loc*gel_loc_long(j,i)+
 509      &                wcorr*gradcorr_long(j,i)+
 510      &                wcorr5*gradcorr5_long(j,i)+
 511      &                wcorr6*gradcorr6_long(j,i)+
 512      &                wturn6*gcorr6_turn_long(j,i)+
 513      &                wstrain*ghpbc(j,i)
 514         enddo
 515       enddo
 516 #else
 517       do i=1,nct
 518         do j=1,3
 519           gradbufc(j,i)=wsc*gvdwc(j,i)+
 520      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 521      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 522      &                wel_loc*gel_loc_long(j,i)+
 523      &                wcorr*gradcorr_long(j,i)+
 524      &                wcorr5*gradcorr5_long(j,i)+
 525      &                wcorr6*gradcorr6_long(j,i)+
 526      &                wturn6*gcorr6_turn_long(j,i)+
 527      &                wstrain*ghpbc(j,i)
 528         enddo
 529       enddo
 530 #endif
 531 #else
 532       do i=1,nct
 533         do j=1,3
 534           gradbufc(j,i)=wsc*gvdwc(j,i)+
 535      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 536      &                welec*gelc_long(j,i)+
 537      &                wbond*gradb(j,i)+
 538      &                wel_loc*gel_loc_long(j,i)+
 539      &                wcorr*gradcorr_long(j,i)+
 540      &                wcorr5*gradcorr5_long(j,i)+
 541      &                wcorr6*gradcorr6_long(j,i)+
 542      &                wturn6*gcorr6_turn_long(j,i)+
 543      &                wstrain*ghpbc(j,i)
 544         enddo
 545       enddo
 546 #endif
 547 #ifdef MPI
 548       if (nfgtasks.gt.1) then
 549       time00=MPI_Wtime()
 550 #ifdef DEBUG
 551       write (iout,*) "gradbufc before allreduce"
 552       do i=1,nres
 553         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 554       enddo
 555       call flush(iout)
 556 #endif
 557       call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 558      &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 559       time_reduce=time_reduce+MPI_Wtime()-time00
 560 #ifdef DEBUG
 561       write (iout,*) "gradbufc_sum after allreduce"
 562       do i=1,nres
 563         write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 564       enddo
 565       call flush(iout)
 566 #endif
 567 #ifdef TIMING
 568       time_allreduce=time_allreduce+MPI_Wtime()-time00
 569 #endif
 570       do i=nnt,nres
 571         do k=1,3
 572           gradbufc(k,i)=0.0d0
 573         enddo
 574       enddo
 575       do i=igrad_start,igrad_end
 576         do j=jgrad_start(i),jgrad_end(i)
 577           do k=1,3
 578             gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 579           enddo
 580         enddo
 581       enddo
 582       else
 583 #endif
 584 #ifdef DEBUG
 585       write (iout,*) "gradbufc"
 586       do i=1,nres
 587         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 588       enddo
 589       call flush(iout)
 590 #endif
 591       do i=nnt,nres-1
 592         do k=1,3
 593           gradbufc(k,i)=0.0d0
 594         enddo
 595         do j=i+1,nres
 596           do k=1,3
 597             gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 598           enddo
 599         enddo
 600       enddo
 601 #ifdef MPI
 602       endif
 603 #endif
 604       do k=1,3
 605         gradbufc(k,nres)=0.0d0
 606       enddo
 607       do i=1,nct
 608         do j=1,3
 609 #ifdef SPLITELE
 610           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 611      &                wel_loc*gel_loc(j,i)+
 612      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 613      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 614      &                wel_loc*gel_loc_long(j,i)+
 615      &                wcorr*gradcorr_long(j,i)+
 616      &                wcorr5*gradcorr5_long(j,i)+
 617      &                wcorr6*gradcorr6_long(j,i)+
 618      &                wturn6*gcorr6_turn_long(j,i))+
 619      &                wbond*gradb(j,i)+
 620      &                wcorr*gradcorr(j,i)+
 621      &                wturn3*gcorr3_turn(j,i)+
 622      &                wturn4*gcorr4_turn(j,i)+
 623      &                wcorr5*gradcorr5(j,i)+
 624      &                wcorr6*gradcorr6(j,i)+
 625      &                wturn6*gcorr6_turn(j,i)+
 626      &                wsccor*gsccorc(j,i)
 627      &               +wscloc*gscloc(j,i)
 628 #else
 629           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 630      &                wel_loc*gel_loc(j,i)+
 631      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 632      &                welec*gelc_long(j,i)+
 633      &                wel_loc*gel_loc_long(j,i)+
 634      &                wcorr*gcorr_long(j,i)+
 635      &                wcorr5*gradcorr5_long(j,i)+
 636      &                wcorr6*gradcorr6_long(j,i)+
 637      &                wturn6*gcorr6_turn_long(j,i))+
 638      &                wbond*gradb(j,i)+
 639      &                wcorr*gradcorr(j,i)+
 640      &                wturn3*gcorr3_turn(j,i)+
 641      &                wturn4*gcorr4_turn(j,i)+
 642      &                wcorr5*gradcorr5(j,i)+
 643      &                wcorr6*gradcorr6(j,i)+
 644      &                wturn6*gcorr6_turn(j,i)+
 645      &                wsccor*gsccorc(j,i)
 646      &               +wscloc*gscloc(j,i)
 647 #endif
 648 #ifdef TSCSC
 649           gradx(j,i,icg)=wsc*gvdwx(j,i)+wsc*wscT*gvdwxT(j,i)+
 650      &                  wscp*gradx_scp(j,i)+
 651      &                  wbond*gradbx(j,i)+
 652      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 653      &                  wsccor*gsccorx(j,i)
 654      &                 +wscloc*gsclocx(j,i)
 655 #else
 656           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 657      &                  wbond*gradbx(j,i)+
 658      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 659      &                  wsccor*gsccorx(j,i)
 660      &                 +wscloc*gsclocx(j,i)
 661 #endif
 662         enddo
 663       enddo
 664 #ifdef DEBUG
 665       write (iout,*) "gloc before adding corr"
 666       do i=1,4*nres
 667         write (iout,*) i,gloc(i,icg)
 668       enddo
 669 #endif
 670       do i=1,nres-3
 671         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 672      &   +wcorr5*g_corr5_loc(i)
 673      &   +wcorr6*g_corr6_loc(i)
 674      &   +wturn4*gel_loc_turn4(i)
 675      &   +wturn3*gel_loc_turn3(i)
 676      &   +wturn6*gel_loc_turn6(i)
 677      &   +wel_loc*gel_loc_loc(i)
 678      &   +wsccor*gsccor_loc(i)
 679       enddo
 680 #ifdef DEBUG
 681       write (iout,*) "gloc after adding corr"
 682       do i=1,4*nres
 683         write (iout,*) i,gloc(i,icg)
 684       enddo
 685 #endif
 686 #ifdef MPI
 687       if (nfgtasks.gt.1) then
 688         do j=1,3
 689           do i=1,nres
 690             gradbufc(j,i)=gradc(j,i,icg)
 691             gradbufx(j,i)=gradx(j,i,icg)
 692           enddo
 693         enddo
 694         do i=1,4*nres
 695           glocbuf(i)=gloc(i,icg)
 696         enddo
 697         time00=MPI_Wtime()
 698         call MPI_Barrier(FG_COMM,IERR)
 699         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 700         time00=MPI_Wtime()
 701         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 702      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 703         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 704      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 705         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 706      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 707         time_reduce=time_reduce+MPI_Wtime()-time00
 708 #ifdef DEBUG
 709       write (iout,*) "gloc after reduce"
 710       do i=1,4*nres
 711         write (iout,*) i,gloc(i,icg)
 712       enddo
 713 #endif
 714       endif
 715 #endif
 716       if (gnorm_check) then
 717 c
 718 c Compute the maximum elements of the gradient
 719 c
 720       gvdwc_max=0.0d0
 721       gvdwc_scp_max=0.0d0
 722       gelc_max=0.0d0
 723       gvdwpp_max=0.0d0
 724       gradb_max=0.0d0
 725       ghpbc_max=0.0d0
 726       gradcorr_max=0.0d0
 727       gel_loc_max=0.0d0
 728       gcorr3_turn_max=0.0d0
 729       gcorr4_turn_max=0.0d0
 730       gradcorr5_max=0.0d0
 731       gradcorr6_max=0.0d0
 732       gcorr6_turn_max=0.0d0
 733       gsccorc_max=0.0d0
 734       gscloc_max=0.0d0
 735       gvdwx_max=0.0d0
 736       gradx_scp_max=0.0d0
 737       ghpbx_max=0.0d0
 738       gradxorr_max=0.0d0
 739       gsccorx_max=0.0d0
 740       gsclocx_max=0.0d0
 741       do i=1,nct
 742         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 743         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 744 #ifdef TSCSC
 745         gvdwc_norm=dsqrt(scalar(gvdwcT(1,i),gvdwcT(1,i)))
 746         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 747 #endif
 748         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 749         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 750      &   gvdwc_scp_max=gvdwc_scp_norm
 751         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 752         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 753         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 754         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 755         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 756         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 757         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 758         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 759         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 760         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 761         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 762         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 763         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 764      &    gcorr3_turn(1,i)))
 765         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 766      &    gcorr3_turn_max=gcorr3_turn_norm
 767         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 768      &    gcorr4_turn(1,i)))
 769         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 770      &    gcorr4_turn_max=gcorr4_turn_norm
 771         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 772         if (gradcorr5_norm.gt.gradcorr5_max)
 773      &    gradcorr5_max=gradcorr5_norm
 774         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 775         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 776         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 777      &    gcorr6_turn(1,i)))
 778         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 779      &    gcorr6_turn_max=gcorr6_turn_norm
 780         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 781         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 782         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 783         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 784         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 785         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 786 #ifdef TSCSC
 787         gvdwx_norm=dsqrt(scalar(gvdwxT(1,i),gvdwxT(1,i)))
 788         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 789 #endif
 790         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 791         if (gradx_scp_norm.gt.gradx_scp_max)
 792      &    gradx_scp_max=gradx_scp_norm
 793         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 794         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 795         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 796         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 797         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 798         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 799         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 800         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 801       enddo
 802       if (gradout) then
 803 #ifdef AIX
 804         open(istat,file=statname,position="append")
 805 #else
 806         open(istat,file=statname,access="append")
 807 #endif
 808         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 809      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 810      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 811      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 812      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 813      &     gsccorx_max,gsclocx_max
 814         close(istat)
 815         if (gvdwc_max.gt.1.0d4) then
 816           write (iout,*) "gvdwc gvdwx gradb gradbx"
 817           do i=nnt,nct
 818             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 819      &        gradb(j,i),gradbx(j,i),j=1,3)
 820           enddo
 821           call pdbout(0.0d0,'cipiszcze',iout)
 822           call flush(iout)
 823         endif
 824       endif
 825       endif
 826 #ifdef DEBUG
 827       write (iout,*) "gradc gradx gloc"
 828       do i=1,nres
 829         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 830      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 831       enddo
 832 #endif
 833 #ifdef TIMING
 834       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 835 #endif
 836       return
 837       end
 838 c-------------------------------------------------------------------------------
 839       subroutine rescale_weights(t_bath)
 840       implicit real*8 (a-h,o-z)
 841       include 'DIMENSIONS'
 842       include 'COMMON.IOUNITS'
 843       include 'COMMON.FFIELD'
 844       include 'COMMON.SBRIDGE'
 845       double precision kfac /2.4d0/
 846       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 847 c      facT=temp0/t_bath
 848 c      facT=2*temp0/(t_bath+temp0)
 849       if (rescale_mode.eq.0) then
 850         facT=1.0d0
 851         facT2=1.0d0
 852         facT3=1.0d0
 853         facT4=1.0d0
 854         facT5=1.0d0
 855       else if (rescale_mode.eq.1) then
 856         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 857         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 858         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 859         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 860         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 861       else if (rescale_mode.eq.2) then
 862         x=t_bath/temp0
 863         x2=x*x
 864         x3=x2*x
 865         x4=x3*x
 866         x5=x4*x
 867         facT=licznik/dlog(dexp(x)+dexp(-x))
 868         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 869         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 870         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 871         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 872       else
 873         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 874         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 875 #ifdef MPI
 876        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 877 #endif
 878        stop 555
 879       endif
 880       welec=weights(3)*fact
 881       wcorr=weights(4)*fact3
 882       wcorr5=weights(5)*fact4
 883       wcorr6=weights(6)*fact5
 884       wel_loc=weights(7)*fact2
 885       wturn3=weights(8)*fact2
 886       wturn4=weights(9)*fact3
 887       wturn6=weights(10)*fact5
 888       wtor=weights(13)*fact
 889       wtor_d=weights(14)*fact2
 890       wsccor=weights(21)*fact
 891 #ifdef TSCSC
 892 c      wsct=t_bath/temp0
 893       wsct=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
 894 #endif
 895       return
 896       end
 897 C------------------------------------------------------------------------
 898       subroutine enerprint(energia)
 899       implicit real*8 (a-h,o-z)
 900       include 'DIMENSIONS'
 901       include 'COMMON.IOUNITS'
 902       include 'COMMON.FFIELD'
 903       include 'COMMON.SBRIDGE'
 904       include 'COMMON.MD_'
 905       double precision energia(0:n_ene)
 906       etot=energia(0)
 907 #ifdef TSCSC
 908       evdw=energia(22)+wsct*energia(23)
 909 #else
 910       evdw=energia(1)
 911 #endif
 912       evdw2=energia(2)
 913 #ifdef SCP14
 914       evdw2=energia(2)+energia(18)
 915 #else
 916       evdw2=energia(2)
 917 #endif
 918       ees=energia(3)
 919 #ifdef SPLITELE
 920       evdw1=energia(16)
 921 #endif
 922       ecorr=energia(4)
 923       ecorr5=energia(5)
 924       ecorr6=energia(6)
 925       eel_loc=energia(7)
 926       eello_turn3=energia(8)
 927       eello_turn4=energia(9)
 928       eello_turn6=energia(10)
 929       ebe=energia(11)
 930       escloc=energia(12)
 931       etors=energia(13)
 932       etors_d=energia(14)
 933       ehpb=energia(15)
 934       edihcnstr=energia(19)
 935       estr=energia(17)
 936       Uconst=energia(20)
 937       esccor=energia(21)
 938 #ifdef SPLITELE
 939       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
 940      &  estr,wbond,ebe,wang,
 941      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 942      &  ecorr,wcorr,
 943      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 944      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
 945      &  edihcnstr,ebr*nss,
 946      &  Uconst,etot
 947    10 format (/'Virtual-chain energies:'//
 948      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 949      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 950      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 951      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 952      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 953      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 954      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 955      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 956      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 957      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 958      & ' (SS bridges & dist. cnstr.)'/
 959      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 960      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 961      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 962      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 963      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 964      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 965      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 966      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 967      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 968      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 969      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
 970      & 'ETOT=  ',1pE16.6,' (total)')
 971 #else
 972       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
 973      &  estr,wbond,ebe,wang,
 974      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 975      &  ecorr,wcorr,
 976      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 977      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
 978      &  ebr*nss,Uconst,etot
 979    10 format (/'Virtual-chain energies:'//
 980      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 981      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 982      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 983      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 984      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 985      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 986      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 987      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 988      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 989      & ' (SS bridges & dist. cnstr.)'/
 990      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 991      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 992      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 993      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 994      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 995      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 996      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 997      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 998      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 999      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1000      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1001      & 'ETOT=  ',1pE16.6,' (total)')
1002 #endif
1003       return
1004       end
1005 C-----------------------------------------------------------------------
1006       subroutine elj(evdw,evdw_p,evdw_m)
1007 C
1008 C This subroutine calculates the interaction energy of nonbonded side chains
1009 C assuming the LJ potential of interaction.
1010 C
1011       implicit real*8 (a-h,o-z)
1012       include 'DIMENSIONS'
1013       parameter (accur=1.0d-10)
1014       include 'COMMON.GEO'
1015       include 'COMMON.VAR'
1016       include 'COMMON.LOCAL'
1017       include 'COMMON.CHAIN'
1018       include 'COMMON.DERIV'
1019       include 'COMMON.INTERACT'
1020       include 'COMMON.TORSION'
1021       include 'COMMON.SBRIDGE'
1022       include 'COMMON.NAMES'
1023       include 'COMMON.IOUNITS'
1024       include 'COMMON.CONTACTS'
1025       dimension gg(3)
1026 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1027       evdw=0.0D0
1028       do i=iatsc_s,iatsc_e
1029         itypi=itype(i)
1030         itypi1=itype(i+1)
1031         xi=c(1,nres+i)
1032         yi=c(2,nres+i)
1033         zi=c(3,nres+i)
1034 C Change 12/1/95
1035         num_conti=0
1036 C
1037 C Calculate SC interaction energy.
1038 C
1039         do iint=1,nint_gr(i)
1040 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1041 cd   &                  'iend=',iend(i,iint)
1042           do j=istart(i,iint),iend(i,iint)
1043             itypj=itype(j)
1044             xj=c(1,nres+j)-xi
1045             yj=c(2,nres+j)-yi
1046             zj=c(3,nres+j)-zi
1047 C Change 12/1/95 to calculate four-body interactions
1048             rij=xj*xj+yj*yj+zj*zj
1049             rrij=1.0D0/rij
1050 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1051             eps0ij=eps(itypi,itypj)
1052             fac=rrij**expon2
1053             e1=fac*fac*aa(itypi,itypj)
1054             e2=fac*bb(itypi,itypj)
1055             evdwij=e1+e2
1056 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1057 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1058 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1059 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1060 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1061 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1062 #ifdef TSCSC
1063             if (bb(itypi,itypj).gt.0) then
1064                evdw_p=evdw_p+evdwij
1065             else
1066                evdw_m=evdw_m+evdwij
1067             endif
1068 #else
1069             evdw=evdw+evdwij
1070 #endif
1071 C
1072 C Calculate the components of the gradient in DC and X
1073 C
1074             fac=-rrij*(e1+evdwij)
1075             gg(1)=xj*fac
1076             gg(2)=yj*fac
1077             gg(3)=zj*fac
1078 #ifdef TSCSC
1079             if (bb(itypi,itypj).gt.0.0d0) then
1080               do k=1,3
1081                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1082                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1083                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1084                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1085               enddo
1086             else
1087               do k=1,3
1088                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1089                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1090                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1091                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1092               enddo
1093             endif
1094 #else
1095             do k=1,3
1096               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1097               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1098               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1099               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1100             enddo
1101 #endif
1102 cgrad            do k=i,j-1
1103 cgrad              do l=1,3
1104 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1105 cgrad              enddo
1106 cgrad            enddo
1107 C
1108 C 12/1/95, revised on 5/20/97
1109 C
1110 C Calculate the contact function. The ith column of the array JCONT will
1111 C contain the numbers of atoms that make contacts with the atom I (of numbers
1112 C greater than I). The arrays FACONT and GACONT will contain the values of
1113 C the contact function and its derivative.
1114 C
1115 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1116 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1117 C Uncomment next line, if the correlation interactions are contact function only
1118             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1119               rij=dsqrt(rij)
1120               sigij=sigma(itypi,itypj)
1121               r0ij=rs0(itypi,itypj)
1122 C
1123 C Check whether the SC's are not too far to make a contact.
1124 C
1125               rcut=1.5d0*r0ij
1126               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1127 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1128 C
1129               if (fcont.gt.0.0D0) then
1130 C If the SC-SC distance if close to sigma, apply spline.
1131 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1132 cAdam &             fcont1,fprimcont1)
1133 cAdam           fcont1=1.0d0-fcont1
1134 cAdam           if (fcont1.gt.0.0d0) then
1135 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1136 cAdam             fcont=fcont*fcont1
1137 cAdam           endif
1138 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1139 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1140 cga             do k=1,3
1141 cga               gg(k)=gg(k)*eps0ij
1142 cga             enddo
1143 cga             eps0ij=-evdwij*eps0ij
1144 C Uncomment for AL's type of SC correlation interactions.
1145 cadam           eps0ij=-evdwij
1146                 num_conti=num_conti+1
1147                 jcont(num_conti,i)=j
1148                 facont(num_conti,i)=fcont*eps0ij
1149                 fprimcont=eps0ij*fprimcont/rij
1150                 fcont=expon*fcont
1151 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1152 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1153 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1154 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1155                 gacont(1,num_conti,i)=-fprimcont*xj
1156                 gacont(2,num_conti,i)=-fprimcont*yj
1157                 gacont(3,num_conti,i)=-fprimcont*zj
1158 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1159 cd              write (iout,'(2i3,3f10.5)')
1160 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1161               endif
1162             endif
1163           enddo      ! j
1164         enddo        ! iint
1165 C Change 12/1/95
1166         num_cont(i)=num_conti
1167       enddo          ! i
1168       do i=1,nct
1169         do j=1,3
1170           gvdwc(j,i)=expon*gvdwc(j,i)
1171           gvdwx(j,i)=expon*gvdwx(j,i)
1172         enddo
1173       enddo
1174 C******************************************************************************
1175 C
1176 C                              N O T E !!!
1177 C
1178 C To save time, the factor of EXPON has been extracted from ALL components
1179 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1180 C use!
1181 C
1182 C******************************************************************************
1183       return
1184       end
1185 C-----------------------------------------------------------------------------
1186       subroutine eljk(evdw,evdw_p,evdw_m)
1187 C
1188 C This subroutine calculates the interaction energy of nonbonded side chains
1189 C assuming the LJK potential of interaction.
1190 C
1191       implicit real*8 (a-h,o-z)
1192       include 'DIMENSIONS'
1193       include 'COMMON.GEO'
1194       include 'COMMON.VAR'
1195       include 'COMMON.LOCAL'
1196       include 'COMMON.CHAIN'
1197       include 'COMMON.DERIV'
1198       include 'COMMON.INTERACT'
1199       include 'COMMON.IOUNITS'
1200       include 'COMMON.NAMES'
1201       dimension gg(3)
1202       logical scheck
1203 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1204       evdw=0.0D0
1205       do i=iatsc_s,iatsc_e
1206         itypi=itype(i)
1207         itypi1=itype(i+1)
1208         xi=c(1,nres+i)
1209         yi=c(2,nres+i)
1210         zi=c(3,nres+i)
1211 C
1212 C Calculate SC interaction energy.
1213 C
1214         do iint=1,nint_gr(i)
1215           do j=istart(i,iint),iend(i,iint)
1216             itypj=itype(j)
1217             xj=c(1,nres+j)-xi
1218             yj=c(2,nres+j)-yi
1219             zj=c(3,nres+j)-zi
1220             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1221             fac_augm=rrij**expon
1222             e_augm=augm(itypi,itypj)*fac_augm
1223             r_inv_ij=dsqrt(rrij)
1224             rij=1.0D0/r_inv_ij
1225             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1226             fac=r_shift_inv**expon
1227             e1=fac*fac*aa(itypi,itypj)
1228             e2=fac*bb(itypi,itypj)
1229             evdwij=e_augm+e1+e2
1230 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1231 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1232 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1233 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1234 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1235 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1236 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1237 #ifdef TSCSC
1238             if (bb(itypi,itypj).gt.0) then
1239                evdw_p=evdw_p+evdwij
1240             else
1241                evdw_m=evdw_m+evdwij
1242             endif
1243 #else
1244             evdw=evdw+evdwij
1245 #endif
1246 C
1247 C Calculate the components of the gradient in DC and X
1248 C
1249             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1250             gg(1)=xj*fac
1251             gg(2)=yj*fac
1252             gg(3)=zj*fac
1253 #ifdef TSCSC
1254             if (bb(itypi,itypj).gt.0.0d0) then
1255               do k=1,3
1256                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1257                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1258                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1259                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1260               enddo
1261             else
1262               do k=1,3
1263                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1264                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1265                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1266                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1267               enddo
1268             endif
1269 #else
1270             do k=1,3
1271               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1272               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1273               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1274               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1275             enddo
1276 #endif
1277 cgrad            do k=i,j-1
1278 cgrad              do l=1,3
1279 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1280 cgrad              enddo
1281 cgrad            enddo
1282           enddo      ! j
1283         enddo        ! iint
1284       enddo          ! i
1285       do i=1,nct
1286         do j=1,3
1287           gvdwc(j,i)=expon*gvdwc(j,i)
1288           gvdwx(j,i)=expon*gvdwx(j,i)
1289         enddo
1290       enddo
1291       return
1292       end
1293 C-----------------------------------------------------------------------------
1294       subroutine ebp(evdw,evdw_p,evdw_m)
1295 C
1296 C This subroutine calculates the interaction energy of nonbonded side chains
1297 C assuming the Berne-Pechukas potential of interaction.
1298 C
1299       implicit real*8 (a-h,o-z)
1300       include 'DIMENSIONS'
1301       include 'COMMON.GEO'
1302       include 'COMMON.VAR'
1303       include 'COMMON.LOCAL'
1304       include 'COMMON.CHAIN'
1305       include 'COMMON.DERIV'
1306       include 'COMMON.NAMES'
1307       include 'COMMON.INTERACT'
1308       include 'COMMON.IOUNITS'
1309       include 'COMMON.CALC'
1310       common /srutu/ icall
1311 c     double precision rrsave(maxdim)
1312       logical lprn
1313       evdw=0.0D0
1314 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1315       evdw=0.0D0
1316 c     if (icall.eq.0) then
1317 c       lprn=.true.
1318 c     else
1319         lprn=.false.
1320 c     endif
1321       ind=0
1322       do i=iatsc_s,iatsc_e
1323         itypi=itype(i)
1324         itypi1=itype(i+1)
1325         xi=c(1,nres+i)
1326         yi=c(2,nres+i)
1327         zi=c(3,nres+i)
1328         dxi=dc_norm(1,nres+i)
1329         dyi=dc_norm(2,nres+i)
1330         dzi=dc_norm(3,nres+i)
1331 c        dsci_inv=dsc_inv(itypi)
1332         dsci_inv=vbld_inv(i+nres)
1333 C
1334 C Calculate SC interaction energy.
1335 C
1336         do iint=1,nint_gr(i)
1337           do j=istart(i,iint),iend(i,iint)
1338             ind=ind+1
1339             itypj=itype(j)
1340 c            dscj_inv=dsc_inv(itypj)
1341             dscj_inv=vbld_inv(j+nres)
1342             chi1=chi(itypi,itypj)
1343             chi2=chi(itypj,itypi)
1344             chi12=chi1*chi2
1345             chip1=chip(itypi)
1346             chip2=chip(itypj)
1347             chip12=chip1*chip2
1348             alf1=alp(itypi)
1349             alf2=alp(itypj)
1350             alf12=0.5D0*(alf1+alf2)
1351 C For diagnostics only!!!
1352 c           chi1=0.0D0
1353 c           chi2=0.0D0
1354 c           chi12=0.0D0
1355 c           chip1=0.0D0
1356 c           chip2=0.0D0
1357 c           chip12=0.0D0
1358 c           alf1=0.0D0
1359 c           alf2=0.0D0
1360 c           alf12=0.0D0
1361             xj=c(1,nres+j)-xi
1362             yj=c(2,nres+j)-yi
1363             zj=c(3,nres+j)-zi
1364             dxj=dc_norm(1,nres+j)
1365             dyj=dc_norm(2,nres+j)
1366             dzj=dc_norm(3,nres+j)
1367             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1368 cd          if (icall.eq.0) then
1369 cd            rrsave(ind)=rrij
1370 cd          else
1371 cd            rrij=rrsave(ind)
1372 cd          endif
1373             rij=dsqrt(rrij)
1374 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1375             call sc_angular
1376 C Calculate whole angle-dependent part of epsilon and contributions
1377 C to its derivatives
1378             fac=(rrij*sigsq)**expon2
1379             e1=fac*fac*aa(itypi,itypj)
1380             e2=fac*bb(itypi,itypj)
1381             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1382             eps2der=evdwij*eps3rt
1383             eps3der=evdwij*eps2rt
1384             evdwij=evdwij*eps2rt*eps3rt
1385 #ifdef TSCSC
1386             if (bb(itypi,itypj).gt.0) then
1387                evdw_p=evdw_p+evdwij
1388             else
1389                evdw_m=evdw_m+evdwij
1390             endif
1391 #else
1392             evdw=evdw+evdwij
1393 #endif
1394             if (lprn) then
1395             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1396             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1397 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1398 cd     &        restyp(itypi),i,restyp(itypj),j,
1399 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1400 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1401 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1402 cd     &        evdwij
1403             endif
1404 C Calculate gradient components.
1405             e1=e1*eps1*eps2rt**2*eps3rt**2
1406             fac=-expon*(e1+evdwij)
1407             sigder=fac/sigsq
1408             fac=rrij*fac
1409 C Calculate radial part of the gradient
1410             gg(1)=xj*fac
1411             gg(2)=yj*fac
1412             gg(3)=zj*fac
1413 C Calculate the angular part of the gradient and sum add the contributions
1414 C to the appropriate components of the Cartesian gradient.
1415 #ifdef TSCSC
1416             if (bb(itypi,itypj).gt.0) then
1417                call sc_grad
1418             else
1419                call sc_grad_T
1420             endif
1421 #else
1422             call sc_grad
1423 #endif
1424           enddo      ! j
1425         enddo        ! iint
1426       enddo          ! i
1427 c     stop
1428       return
1429       end
1430 C-----------------------------------------------------------------------------
1431       subroutine egb(evdw,evdw_p,evdw_m)
1432 C
1433 C This subroutine calculates the interaction energy of nonbonded side chains
1434 C assuming the Gay-Berne potential of interaction.
1435 C
1436       implicit real*8 (a-h,o-z)
1437       include 'DIMENSIONS'
1438       include 'COMMON.GEO'
1439       include 'COMMON.VAR'
1440       include 'COMMON.LOCAL'
1441       include 'COMMON.CHAIN'
1442       include 'COMMON.DERIV'
1443       include 'COMMON.NAMES'
1444       include 'COMMON.INTERACT'
1445       include 'COMMON.IOUNITS'
1446       include 'COMMON.CALC'
1447       include 'COMMON.CONTROL'
1448       logical lprn
1449       evdw=0.0D0
1450 ccccc      energy_dec=.false.
1451 c      write(iout,*) 'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1452       evdw=0.0D0
1453       evdw_p=0.0D0
1454       evdw_m=0.0D0
1455       lprn=.false.
1456 c     if (icall.eq.0) lprn=.false.
1457       ind=0
1458       do i=iatsc_s,iatsc_e
1459         itypi=itype(i)
1460         itypi1=itype(i+1)
1461         xi=c(1,nres+i)
1462         yi=c(2,nres+i)
1463         zi=c(3,nres+i)
1464         dxi=dc_norm(1,nres+i)
1465         dyi=dc_norm(2,nres+i)
1466         dzi=dc_norm(3,nres+i)
1467 c        dsci_inv=dsc_inv(itypi)
1468         dsci_inv=vbld_inv(i+nres)
1469 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1470 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1471 C
1472 C Calculate SC interaction energy.
1473 C
1474         do iint=1,nint_gr(i)
1475           do j=istart(i,iint),iend(i,iint)
1476             ind=ind+1
1477             itypj=itype(j)
1478 c            dscj_inv=dsc_inv(itypj)
1479             dscj_inv=vbld_inv(j+nres)
1480 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1481 c     &       1.0d0/vbld(j+nres)
1482 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1483             sig0ij=sigma(itypi,itypj)
1484             chi1=chi(itypi,itypj)
1485             chi2=chi(itypj,itypi)
1486             chi12=chi1*chi2
1487             chip1=chip(itypi)
1488             chip2=chip(itypj)
1489             chip12=chip1*chip2
1490             alf1=alp(itypi)
1491             alf2=alp(itypj)
1492             alf12=0.5D0*(alf1+alf2)
1493 C For diagnostics only!!!
1494 c           chi1=0.0D0
1495 c           chi2=0.0D0
1496 c           chi12=0.0D0
1497 c           chip1=0.0D0
1498 c           chip2=0.0D0
1499 c           chip12=0.0D0
1500 c           alf1=0.0D0
1501 c           alf2=0.0D0
1502 c           alf12=0.0D0
1503             xj=c(1,nres+j)-xi
1504             yj=c(2,nres+j)-yi
1505             zj=c(3,nres+j)-zi
1506             dxj=dc_norm(1,nres+j)
1507             dyj=dc_norm(2,nres+j)
1508             dzj=dc_norm(3,nres+j)
1509 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1510 c            write (iout,*) "j",j," dc_norm",
1511 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1512             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1513             rij=dsqrt(rrij)
1514 C Calculate angle-dependent terms of energy and contributions to their
1515 C derivatives.
1516             call sc_angular
1517             sigsq=1.0D0/sigsq
1518             sig=sig0ij*dsqrt(sigsq)
1519             rij_shift=1.0D0/rij-sig+sig0ij
1520 c for diagnostics; uncomment
1521 c            rij_shift=1.2*sig0ij
1522 C I hate to put IF's in the loops, but here don't have another choice!!!!
1523             if (rij_shift.le.0.0D0) then
1524               evdw=1.0D20
1525 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1526 cd     &        restyp(itypi),i,restyp(itypj),j,
1527 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1528               return
1529             endif
1530             sigder=-sig*sigsq
1531 c---------------------------------------------------------------
1532             rij_shift=1.0D0/rij_shift
1533             fac=rij_shift**expon
1534             e1=fac*fac*aa(itypi,itypj)
1535             e2=fac*bb(itypi,itypj)
1536             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1537             eps2der=evdwij*eps3rt
1538             eps3der=evdwij*eps2rt
1539 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1540 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1541             evdwij=evdwij*eps2rt*eps3rt
1542 #ifdef TSCSC
1543             if (bb(itypi,itypj).gt.0) then
1544                evdw_p=evdw_p+evdwij
1545             else
1546                evdw_m=evdw_m+evdwij
1547             endif
1548 #else
1549             evdw=evdw+evdwij
1550 #endif
1551             if (lprn) then
1552             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1553             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1554             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1555      &        restyp(itypi),i,restyp(itypj),j,
1556      &        epsi,sigm,chi1,chi2,chip1,chip2,
1557      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1558      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1559      &        evdwij
1560             endif
1561
1562             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1563      &                        'evdw',i,j,evdwij
1564
1565 C Calculate gradient components.
1566             e1=e1*eps1*eps2rt**2*eps3rt**2
1567             fac=-expon*(e1+evdwij)*rij_shift
1568             sigder=fac*sigder
1569             fac=rij*fac
1570 c            fac=0.0d0
1571 C Calculate the radial part of the gradient
1572             gg(1)=xj*fac
1573             gg(2)=yj*fac
1574             gg(3)=zj*fac
1575 C Calculate angular part of the gradient.
1576 #ifdef TSCSC
1577             if (bb(itypi,itypj).gt.0) then
1578                call sc_grad
1579             else
1580                call sc_grad_T
1581             endif
1582 #else
1583             call sc_grad
1584 #endif
1585           enddo      ! j
1586         enddo        ! iint
1587       enddo          ! i
1588 c      write (iout,*) "Number of loop steps in EGB:",ind
1589 cccc      energy_dec=.false.
1590       return
1591       end
1592 C-----------------------------------------------------------------------------
1593       subroutine egbv(evdw,evdw_p,evdw_m)
1594 C
1595 C This subroutine calculates the interaction energy of nonbonded side chains
1596 C assuming the Gay-Berne-Vorobjev potential of interaction.
1597 C
1598       implicit real*8 (a-h,o-z)
1599       include 'DIMENSIONS'
1600       include 'COMMON.GEO'
1601       include 'COMMON.VAR'
1602       include 'COMMON.LOCAL'
1603       include 'COMMON.CHAIN'
1604       include 'COMMON.DERIV'
1605       include 'COMMON.NAMES'
1606       include 'COMMON.INTERACT'
1607       include 'COMMON.IOUNITS'
1608       include 'COMMON.CALC'
1609       common /srutu/ icall
1610       logical lprn
1611       evdw=0.0D0
1612 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1613       evdw=0.0D0
1614       lprn=.false.
1615 c     if (icall.eq.0) lprn=.true.
1616       ind=0
1617       do i=iatsc_s,iatsc_e
1618         itypi=itype(i)
1619         itypi1=itype(i+1)
1620         xi=c(1,nres+i)
1621         yi=c(2,nres+i)
1622         zi=c(3,nres+i)
1623         dxi=dc_norm(1,nres+i)
1624         dyi=dc_norm(2,nres+i)
1625         dzi=dc_norm(3,nres+i)
1626 c        dsci_inv=dsc_inv(itypi)
1627         dsci_inv=vbld_inv(i+nres)
1628 C
1629 C Calculate SC interaction energy.
1630 C
1631         do iint=1,nint_gr(i)
1632           do j=istart(i,iint),iend(i,iint)
1633             ind=ind+1
1634             itypj=itype(j)
1635 c            dscj_inv=dsc_inv(itypj)
1636             dscj_inv=vbld_inv(j+nres)
1637             sig0ij=sigma(itypi,itypj)
1638             r0ij=r0(itypi,itypj)
1639             chi1=chi(itypi,itypj)
1640             chi2=chi(itypj,itypi)
1641             chi12=chi1*chi2
1642             chip1=chip(itypi)
1643             chip2=chip(itypj)
1644             chip12=chip1*chip2
1645             alf1=alp(itypi)
1646             alf2=alp(itypj)
1647             alf12=0.5D0*(alf1+alf2)
1648 C For diagnostics only!!!
1649 c           chi1=0.0D0
1650 c           chi2=0.0D0
1651 c           chi12=0.0D0
1652 c           chip1=0.0D0
1653 c           chip2=0.0D0
1654 c           chip12=0.0D0
1655 c           alf1=0.0D0
1656 c           alf2=0.0D0
1657 c           alf12=0.0D0
1658             xj=c(1,nres+j)-xi
1659             yj=c(2,nres+j)-yi
1660             zj=c(3,nres+j)-zi
1661             dxj=dc_norm(1,nres+j)
1662             dyj=dc_norm(2,nres+j)
1663             dzj=dc_norm(3,nres+j)
1664             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1665             rij=dsqrt(rrij)
1666 C Calculate angle-dependent terms of energy and contributions to their
1667 C derivatives.
1668             call sc_angular
1669             sigsq=1.0D0/sigsq
1670             sig=sig0ij*dsqrt(sigsq)
1671             rij_shift=1.0D0/rij-sig+r0ij
1672 C I hate to put IF's in the loops, but here don't have another choice!!!!
1673             if (rij_shift.le.0.0D0) then
1674               evdw=1.0D20
1675               return
1676             endif
1677             sigder=-sig*sigsq
1678 c---------------------------------------------------------------
1679             rij_shift=1.0D0/rij_shift
1680             fac=rij_shift**expon
1681             e1=fac*fac*aa(itypi,itypj)
1682             e2=fac*bb(itypi,itypj)
1683             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1684             eps2der=evdwij*eps3rt
1685             eps3der=evdwij*eps2rt
1686             fac_augm=rrij**expon
1687             e_augm=augm(itypi,itypj)*fac_augm
1688             evdwij=evdwij*eps2rt*eps3rt
1689 #ifdef TSCSC
1690             if (bb(itypi,itypj).gt.0) then
1691                evdw_p=evdw_p+evdwij+e_augm
1692             else
1693                evdw_m=evdw_m+evdwij+e_augm
1694             endif
1695 #else
1696             evdw=evdw+evdwij+e_augm
1697 #endif
1698             if (lprn) then
1699             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1700             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1701             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1702      &        restyp(itypi),i,restyp(itypj),j,
1703      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1704      &        chi1,chi2,chip1,chip2,
1705      &        eps1,eps2rt**2,eps3rt**2,
1706      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1707      &        evdwij+e_augm
1708             endif
1709 C Calculate gradient components.
1710             e1=e1*eps1*eps2rt**2*eps3rt**2
1711             fac=-expon*(e1+evdwij)*rij_shift
1712             sigder=fac*sigder
1713             fac=rij*fac-2*expon*rrij*e_augm
1714 C Calculate the radial part of the gradient
1715             gg(1)=xj*fac
1716             gg(2)=yj*fac
1717             gg(3)=zj*fac
1718 C Calculate angular part of the gradient.
1719 #ifdef TSCSC
1720             if (bb(itypi,itypj).gt.0) then
1721                call sc_grad
1722             else
1723                call sc_grad_T
1724             endif
1725 #else
1726             call sc_grad
1727 #endif
1728           enddo      ! j
1729         enddo        ! iint
1730       enddo          ! i
1731       end
1732 C-----------------------------------------------------------------------------
1733       subroutine sc_angular
1734 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1735 C om12. Called by ebp, egb, and egbv.
1736       implicit none
1737       include 'COMMON.CALC'
1738       include 'COMMON.IOUNITS'
1739       erij(1)=xj*rij
1740       erij(2)=yj*rij
1741       erij(3)=zj*rij
1742       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1743       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1744       om12=dxi*dxj+dyi*dyj+dzi*dzj
1745       chiom12=chi12*om12
1746 C Calculate eps1(om12) and its derivative in om12
1747       faceps1=1.0D0-om12*chiom12
1748       faceps1_inv=1.0D0/faceps1
1749       eps1=dsqrt(faceps1_inv)
1750 C Following variable is eps1*deps1/dom12
1751       eps1_om12=faceps1_inv*chiom12
1752 c diagnostics only
1753 c      faceps1_inv=om12
1754 c      eps1=om12
1755 c      eps1_om12=1.0d0
1756 c      write (iout,*) "om12",om12," eps1",eps1
1757 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1758 C and om12.
1759       om1om2=om1*om2
1760       chiom1=chi1*om1
1761       chiom2=chi2*om2
1762       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1763       sigsq=1.0D0-facsig*faceps1_inv
1764       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1765       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1766       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1767 c diagnostics only
1768 c      sigsq=1.0d0
1769 c      sigsq_om1=0.0d0
1770 c      sigsq_om2=0.0d0
1771 c      sigsq_om12=0.0d0
1772 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1773 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1774 c     &    " eps1",eps1
1775 C Calculate eps2 and its derivatives in om1, om2, and om12.
1776       chipom1=chip1*om1
1777       chipom2=chip2*om2
1778       chipom12=chip12*om12
1779       facp=1.0D0-om12*chipom12
1780       facp_inv=1.0D0/facp
1781       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1782 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1783 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1784 C Following variable is the square root of eps2
1785       eps2rt=1.0D0-facp1*facp_inv
1786 C Following three variables are the derivatives of the square root of eps
1787 C in om1, om2, and om12.
1788       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1789       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1790       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1791 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1792       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1793 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1794 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1795 c     &  " eps2rt_om12",eps2rt_om12
1796 C Calculate whole angle-dependent part of epsilon and contributions
1797 C to its derivatives
1798       return
1799       end
1800
1801 C----------------------------------------------------------------------------
1802       subroutine sc_grad_T
1803       implicit real*8 (a-h,o-z)
1804       include 'DIMENSIONS'
1805       include 'COMMON.CHAIN'
1806       include 'COMMON.DERIV'
1807       include 'COMMON.CALC'
1808       include 'COMMON.IOUNITS'
1809       double precision dcosom1(3),dcosom2(3)
1810       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1811       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1812       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1813      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1814 c diagnostics only
1815 c      eom1=0.0d0
1816 c      eom2=0.0d0
1817 c      eom12=evdwij*eps1_om12
1818 c end diagnostics
1819 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1820 c     &  " sigder",sigder
1821 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1822 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1823       do k=1,3
1824         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1825         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1826       enddo
1827       do k=1,3
1828         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1829       enddo
1830 c      write (iout,*) "gg",(gg(k),k=1,3)
1831       do k=1,3
1832         gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1833      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1834      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1835         gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1836      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1837      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1838 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1839 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1840 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1841 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1842       enddo
1843 C
1844 C Calculate the components of the gradient in DC and X
1845 C
1846 cgrad      do k=i,j-1
1847 cgrad        do l=1,3
1848 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1849 cgrad        enddo
1850 cgrad      enddo
1851       do l=1,3
1852         gvdwcT(l,i)=gvdwcT(l,i)-gg(l)
1853         gvdwcT(l,j)=gvdwcT(l,j)+gg(l)
1854       enddo
1855       return
1856       end
1857
1858 C----------------------------------------------------------------------------
1859       subroutine sc_grad
1860       implicit real*8 (a-h,o-z)
1861       include 'DIMENSIONS'
1862       include 'COMMON.CHAIN'
1863       include 'COMMON.DERIV'
1864       include 'COMMON.CALC'
1865       include 'COMMON.IOUNITS'
1866       double precision dcosom1(3),dcosom2(3)
1867       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1868       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1869       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1870      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1871 c diagnostics only
1872 c      eom1=0.0d0
1873 c      eom2=0.0d0
1874 c      eom12=evdwij*eps1_om12
1875 c end diagnostics
1876 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1877 c     &  " sigder",sigder
1878 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1879 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1880       do k=1,3
1881         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1882         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1883       enddo
1884       do k=1,3
1885         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1886       enddo
1887 c      write (iout,*) "gg",(gg(k),k=1,3)
1888       do k=1,3
1889         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1890      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1891      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1892         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1893      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1894      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1895 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1896 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1897 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1898 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1899       enddo
1900 C
1901 C Calculate the components of the gradient in DC and X
1902 C
1903 cgrad      do k=i,j-1
1904 cgrad        do l=1,3
1905 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1906 cgrad        enddo
1907 cgrad      enddo
1908       do l=1,3
1909         gvdwc(l,i)=gvdwc(l,i)-gg(l)
1910         gvdwc(l,j)=gvdwc(l,j)+gg(l)
1911       enddo
1912       return
1913       end
1914 C-----------------------------------------------------------------------
1915       subroutine e_softsphere(evdw)
1916 C
1917 C This subroutine calculates the interaction energy of nonbonded side chains
1918 C assuming the LJ potential of interaction.
1919 C
1920       implicit real*8 (a-h,o-z)
1921       include 'DIMENSIONS'
1922       parameter (accur=1.0d-10)
1923       include 'COMMON.GEO'
1924       include 'COMMON.VAR'
1925       include 'COMMON.LOCAL'
1926       include 'COMMON.CHAIN'
1927       include 'COMMON.DERIV'
1928       include 'COMMON.INTERACT'
1929       include 'COMMON.TORSION'
1930       include 'COMMON.SBRIDGE'
1931       include 'COMMON.NAMES'
1932       include 'COMMON.IOUNITS'
1933       include 'COMMON.CONTACTS'
1934       dimension gg(3)
1935 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1936       evdw=0.0D0
1937       do i=iatsc_s,iatsc_e
1938         itypi=itype(i)
1939         itypi1=itype(i+1)
1940         xi=c(1,nres+i)
1941         yi=c(2,nres+i)
1942         zi=c(3,nres+i)
1943 C
1944 C Calculate SC interaction energy.
1945 C
1946         do iint=1,nint_gr(i)
1947 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1948 cd   &                  'iend=',iend(i,iint)
1949           do j=istart(i,iint),iend(i,iint)
1950             itypj=itype(j)
1951             xj=c(1,nres+j)-xi
1952             yj=c(2,nres+j)-yi
1953             zj=c(3,nres+j)-zi
1954             rij=xj*xj+yj*yj+zj*zj
1955 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1956             r0ij=r0(itypi,itypj)
1957             r0ijsq=r0ij*r0ij
1958 c            print *,i,j,r0ij,dsqrt(rij)
1959             if (rij.lt.r0ijsq) then
1960               evdwij=0.25d0*(rij-r0ijsq)**2
1961               fac=rij-r0ijsq
1962             else
1963               evdwij=0.0d0
1964               fac=0.0d0
1965             endif
1966             evdw=evdw+evdwij
1967 C
1968 C Calculate the components of the gradient in DC and X
1969 C
1970             gg(1)=xj*fac
1971             gg(2)=yj*fac
1972             gg(3)=zj*fac
1973             do k=1,3
1974               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1975               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1976               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1977               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1978             enddo
1979 cgrad            do k=i,j-1
1980 cgrad              do l=1,3
1981 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1982 cgrad              enddo
1983 cgrad            enddo
1984           enddo ! j
1985         enddo ! iint
1986       enddo ! i
1987       return
1988       end
1989 C--------------------------------------------------------------------------
1990       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
1991      &              eello_turn4)
1992 C
1993 C Soft-sphere potential of p-p interaction
1994 C
1995       implicit real*8 (a-h,o-z)
1996       include 'DIMENSIONS'
1997       include 'COMMON.CONTROL'
1998       include 'COMMON.IOUNITS'
1999       include 'COMMON.GEO'
2000       include 'COMMON.VAR'
2001       include 'COMMON.LOCAL'
2002       include 'COMMON.CHAIN'
2003       include 'COMMON.DERIV'
2004       include 'COMMON.INTERACT'
2005       include 'COMMON.CONTACTS'
2006       include 'COMMON.TORSION'
2007       include 'COMMON.VECTORS'
2008       include 'COMMON.FFIELD'
2009       dimension ggg(3)
2010 cd      write(iout,*) 'In EELEC_soft_sphere'
2011       ees=0.0D0
2012       evdw1=0.0D0
2013       eel_loc=0.0d0
2014       eello_turn3=0.0d0
2015       eello_turn4=0.0d0
2016       ind=0
2017       do i=iatel_s,iatel_e
2018         dxi=dc(1,i)
2019         dyi=dc(2,i)
2020         dzi=dc(3,i)
2021         xmedi=c(1,i)+0.5d0*dxi
2022         ymedi=c(2,i)+0.5d0*dyi
2023         zmedi=c(3,i)+0.5d0*dzi
2024         num_conti=0
2025 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2026         do j=ielstart(i),ielend(i)
2027           ind=ind+1
2028           iteli=itel(i)
2029           itelj=itel(j)
2030           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2031           r0ij=rpp(iteli,itelj)
2032           r0ijsq=r0ij*r0ij
2033           dxj=dc(1,j)
2034           dyj=dc(2,j)
2035           dzj=dc(3,j)
2036           xj=c(1,j)+0.5D0*dxj-xmedi
2037           yj=c(2,j)+0.5D0*dyj-ymedi
2038           zj=c(3,j)+0.5D0*dzj-zmedi
2039           rij=xj*xj+yj*yj+zj*zj
2040           if (rij.lt.r0ijsq) then
2041             evdw1ij=0.25d0*(rij-r0ijsq)**2
2042             fac=rij-r0ijsq
2043           else
2044             evdw1ij=0.0d0
2045             fac=0.0d0
2046           endif
2047           evdw1=evdw1+evdw1ij
2048 C
2049 C Calculate contributions to the Cartesian gradient.
2050 C
2051           ggg(1)=fac*xj
2052           ggg(2)=fac*yj
2053           ggg(3)=fac*zj
2054           do k=1,3
2055             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2056             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2057           enddo
2058 *
2059 * Loop over residues i+1 thru j-1.
2060 *
2061 cgrad          do k=i+1,j-1
2062 cgrad            do l=1,3
2063 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2064 cgrad            enddo
2065 cgrad          enddo
2066         enddo ! j
2067       enddo   ! i
2068 cgrad      do i=nnt,nct-1
2069 cgrad        do k=1,3
2070 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2071 cgrad        enddo
2072 cgrad        do j=i+1,nct-1
2073 cgrad          do k=1,3
2074 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2075 cgrad          enddo
2076 cgrad        enddo
2077 cgrad      enddo
2078       return
2079       end
2080 c------------------------------------------------------------------------------
2081       subroutine vec_and_deriv
2082       implicit real*8 (a-h,o-z)
2083       include 'DIMENSIONS'
2084 #ifdef MPI
2085       include 'mpif.h'
2086 #endif
2087       include 'COMMON.IOUNITS'
2088       include 'COMMON.GEO'
2089       include 'COMMON.VAR'
2090       include 'COMMON.LOCAL'
2091       include 'COMMON.CHAIN'
2092       include 'COMMON.VECTORS'
2093       include 'COMMON.SETUP'
2094       include 'COMMON.TIME1'
2095       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2096 C Compute the local reference systems. For reference system (i), the
2097 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2098 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2099 #ifdef PARVEC
2100       do i=ivec_start,ivec_end
2101 #else
2102       do i=1,nres-1
2103 #endif
2104           if (i.eq.nres-1) then
2105 C Case of the last full residue
2106 C Compute the Z-axis
2107             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2108             costh=dcos(pi-theta(nres))
2109             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2110             do k=1,3
2111               uz(k,i)=fac*uz(k,i)
2112             enddo
2113 C Compute the derivatives of uz
2114             uzder(1,1,1)= 0.0d0
2115             uzder(2,1,1)=-dc_norm(3,i-1)
2116             uzder(3,1,1)= dc_norm(2,i-1)
2117             uzder(1,2,1)= dc_norm(3,i-1)
2118             uzder(2,2,1)= 0.0d0
2119             uzder(3,2,1)=-dc_norm(1,i-1)
2120             uzder(1,3,1)=-dc_norm(2,i-1)
2121             uzder(2,3,1)= dc_norm(1,i-1)
2122             uzder(3,3,1)= 0.0d0
2123             uzder(1,1,2)= 0.0d0
2124             uzder(2,1,2)= dc_norm(3,i)
2125             uzder(3,1,2)=-dc_norm(2,i)
2126             uzder(1,2,2)=-dc_norm(3,i)
2127             uzder(2,2,2)= 0.0d0
2128             uzder(3,2,2)= dc_norm(1,i)
2129             uzder(1,3,2)= dc_norm(2,i)
2130             uzder(2,3,2)=-dc_norm(1,i)
2131             uzder(3,3,2)= 0.0d0
2132 C Compute the Y-axis
2133             facy=fac
2134             do k=1,3
2135               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2136             enddo
2137 C Compute the derivatives of uy
2138             do j=1,3
2139               do k=1,3
2140                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2141      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2142                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2143               enddo
2144               uyder(j,j,1)=uyder(j,j,1)-costh
2145               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2146             enddo
2147             do j=1,2
2148               do k=1,3
2149                 do l=1,3
2150                   uygrad(l,k,j,i)=uyder(l,k,j)
2151                   uzgrad(l,k,j,i)=uzder(l,k,j)
2152                 enddo
2153               enddo
2154             enddo
2155             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2156             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2157             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2158             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2159           else
2160 C Other residues
2161 C Compute the Z-axis
2162             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2163             costh=dcos(pi-theta(i+2))
2164             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2165             do k=1,3
2166               uz(k,i)=fac*uz(k,i)
2167             enddo
2168 C Compute the derivatives of uz
2169             uzder(1,1,1)= 0.0d0
2170             uzder(2,1,1)=-dc_norm(3,i+1)
2171             uzder(3,1,1)= dc_norm(2,i+1)
2172             uzder(1,2,1)= dc_norm(3,i+1)
2173             uzder(2,2,1)= 0.0d0
2174             uzder(3,2,1)=-dc_norm(1,i+1)
2175             uzder(1,3,1)=-dc_norm(2,i+1)
2176             uzder(2,3,1)= dc_norm(1,i+1)
2177             uzder(3,3,1)= 0.0d0
2178             uzder(1,1,2)= 0.0d0
2179             uzder(2,1,2)= dc_norm(3,i)
2180             uzder(3,1,2)=-dc_norm(2,i)
2181             uzder(1,2,2)=-dc_norm(3,i)
2182             uzder(2,2,2)= 0.0d0
2183             uzder(3,2,2)= dc_norm(1,i)
2184             uzder(1,3,2)= dc_norm(2,i)
2185             uzder(2,3,2)=-dc_norm(1,i)
2186             uzder(3,3,2)= 0.0d0
2187 C Compute the Y-axis
2188             facy=fac
2189             do k=1,3
2190               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2191             enddo
2192 C Compute the derivatives of uy
2193             do j=1,3
2194               do k=1,3
2195                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2196      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2197                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2198               enddo
2199               uyder(j,j,1)=uyder(j,j,1)-costh
2200               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2201             enddo
2202             do j=1,2
2203               do k=1,3
2204                 do l=1,3
2205                   uygrad(l,k,j,i)=uyder(l,k,j)
2206                   uzgrad(l,k,j,i)=uzder(l,k,j)
2207                 enddo
2208               enddo
2209             enddo
2210             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2211             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2212             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2213             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2214           endif
2215       enddo
2216       do i=1,nres-1
2217         vbld_inv_temp(1)=vbld_inv(i+1)
2218         if (i.lt.nres-1) then
2219           vbld_inv_temp(2)=vbld_inv(i+2)
2220           else
2221           vbld_inv_temp(2)=vbld_inv(i)
2222           endif
2223         do j=1,2
2224           do k=1,3
2225             do l=1,3
2226               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2227               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2228             enddo
2229           enddo
2230         enddo
2231       enddo
2232 #if defined(PARVEC) && defined(MPI)
2233       if (nfgtasks1.gt.1) then
2234         time00=MPI_Wtime()
2235 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2236 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2237 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2238         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2239      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2240      &   FG_COMM1,IERR)
2241         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2242      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2243      &   FG_COMM1,IERR)
2244         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2245      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2246      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2247         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2248      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2249      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2250         time_gather=time_gather+MPI_Wtime()-time00
2251       endif
2252 c      if (fg_rank.eq.0) then
2253 c        write (iout,*) "Arrays UY and UZ"
2254 c        do i=1,nres-1
2255 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2256 c     &     (uz(k,i),k=1,3)
2257 c        enddo
2258 c      endif
2259 #endif
2260       return
2261       end
2262 C-----------------------------------------------------------------------------
2263       subroutine check_vecgrad
2264       implicit real*8 (a-h,o-z)
2265       include 'DIMENSIONS'
2266       include 'COMMON.IOUNITS'
2267       include 'COMMON.GEO'
2268       include 'COMMON.VAR'
2269       include 'COMMON.LOCAL'
2270       include 'COMMON.CHAIN'
2271       include 'COMMON.VECTORS'
2272       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2273       dimension uyt(3,maxres),uzt(3,maxres)
2274       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2275       double precision delta /1.0d-7/
2276       call vec_and_deriv
2277 cd      do i=1,nres
2278 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2279 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2280 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2281 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2282 cd     &     (dc_norm(if90,i),if90=1,3)
2283 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2284 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2285 cd          write(iout,'(a)')
2286 cd      enddo
2287       do i=1,nres
2288         do j=1,2
2289           do k=1,3
2290             do l=1,3
2291               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2292               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2293             enddo
2294           enddo
2295         enddo
2296       enddo
2297       call vec_and_deriv
2298       do i=1,nres
2299         do j=1,3
2300           uyt(j,i)=uy(j,i)
2301           uzt(j,i)=uz(j,i)
2302         enddo
2303       enddo
2304       do i=1,nres
2305 cd        write (iout,*) 'i=',i
2306         do k=1,3
2307           erij(k)=dc_norm(k,i)
2308         enddo
2309         do j=1,3
2310           do k=1,3
2311             dc_norm(k,i)=erij(k)
2312           enddo
2313           dc_norm(j,i)=dc_norm(j,i)+delta
2314 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2315 c          do k=1,3
2316 c            dc_norm(k,i)=dc_norm(k,i)/fac
2317 c          enddo
2318 c          write (iout,*) (dc_norm(k,i),k=1,3)
2319 c          write (iout,*) (erij(k),k=1,3)
2320           call vec_and_deriv
2321           do k=1,3
2322             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2323             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2324             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2325             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2326           enddo
2327 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2328 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2329 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2330         enddo
2331         do k=1,3
2332           dc_norm(k,i)=erij(k)
2333         enddo
2334 cd        do k=1,3
2335 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2336 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2337 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2338 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2339 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2340 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2341 cd          write (iout,'(a)')
2342 cd        enddo
2343       enddo
2344       return
2345       end
2346 C--------------------------------------------------------------------------
2347       subroutine set_matrices
2348       implicit real*8 (a-h,o-z)
2349       include 'DIMENSIONS'
2350 #ifdef MPI
2351       include "mpif.h"
2352       include "COMMON.SETUP"
2353       integer IERR
2354       integer status(MPI_STATUS_SIZE)
2355 #endif
2356       include 'COMMON.IOUNITS'
2357       include 'COMMON.GEO'
2358       include 'COMMON.VAR'
2359       include 'COMMON.LOCAL'
2360       include 'COMMON.CHAIN'
2361       include 'COMMON.DERIV'
2362       include 'COMMON.INTERACT'
2363       include 'COMMON.CONTACTS'
2364       include 'COMMON.TORSION'
2365       include 'COMMON.VECTORS'
2366       include 'COMMON.FFIELD'
2367       double precision auxvec(2),auxmat(2,2)
2368 C
2369 C Compute the virtual-bond-torsional-angle dependent quantities needed
2370 C to calculate the el-loc multibody terms of various order.
2371 C
2372 #ifdef PARMAT
2373       do i=ivec_start+2,ivec_end+2
2374 #else
2375       do i=3,nres+1
2376 #endif
2377         if (i .lt. nres+1) then
2378           sin1=dsin(phi(i))
2379           cos1=dcos(phi(i))
2380           sintab(i-2)=sin1
2381           costab(i-2)=cos1
2382           obrot(1,i-2)=cos1
2383           obrot(2,i-2)=sin1
2384           sin2=dsin(2*phi(i))
2385           cos2=dcos(2*phi(i))
2386           sintab2(i-2)=sin2
2387           costab2(i-2)=cos2
2388           obrot2(1,i-2)=cos2
2389           obrot2(2,i-2)=sin2
2390           Ug(1,1,i-2)=-cos1
2391           Ug(1,2,i-2)=-sin1
2392           Ug(2,1,i-2)=-sin1
2393           Ug(2,2,i-2)= cos1
2394           Ug2(1,1,i-2)=-cos2
2395           Ug2(1,2,i-2)=-sin2
2396           Ug2(2,1,i-2)=-sin2
2397           Ug2(2,2,i-2)= cos2
2398         else
2399           costab(i-2)=1.0d0
2400           sintab(i-2)=0.0d0
2401           obrot(1,i-2)=1.0d0
2402           obrot(2,i-2)=0.0d0
2403           obrot2(1,i-2)=0.0d0
2404           obrot2(2,i-2)=0.0d0
2405           Ug(1,1,i-2)=1.0d0
2406           Ug(1,2,i-2)=0.0d0
2407           Ug(2,1,i-2)=0.0d0
2408           Ug(2,2,i-2)=1.0d0
2409           Ug2(1,1,i-2)=0.0d0
2410           Ug2(1,2,i-2)=0.0d0
2411           Ug2(2,1,i-2)=0.0d0
2412           Ug2(2,2,i-2)=0.0d0
2413         endif
2414         if (i .gt. 3 .and. i .lt. nres+1) then
2415           obrot_der(1,i-2)=-sin1
2416           obrot_der(2,i-2)= cos1
2417           Ugder(1,1,i-2)= sin1
2418           Ugder(1,2,i-2)=-cos1
2419           Ugder(2,1,i-2)=-cos1
2420           Ugder(2,2,i-2)=-sin1
2421           dwacos2=cos2+cos2
2422           dwasin2=sin2+sin2
2423           obrot2_der(1,i-2)=-dwasin2
2424           obrot2_der(2,i-2)= dwacos2
2425           Ug2der(1,1,i-2)= dwasin2
2426           Ug2der(1,2,i-2)=-dwacos2
2427           Ug2der(2,1,i-2)=-dwacos2
2428           Ug2der(2,2,i-2)=-dwasin2
2429         else
2430           obrot_der(1,i-2)=0.0d0
2431           obrot_der(2,i-2)=0.0d0
2432           Ugder(1,1,i-2)=0.0d0
2433           Ugder(1,2,i-2)=0.0d0
2434           Ugder(2,1,i-2)=0.0d0
2435           Ugder(2,2,i-2)=0.0d0
2436           obrot2_der(1,i-2)=0.0d0
2437           obrot2_der(2,i-2)=0.0d0
2438           Ug2der(1,1,i-2)=0.0d0
2439           Ug2der(1,2,i-2)=0.0d0
2440           Ug2der(2,1,i-2)=0.0d0
2441           Ug2der(2,2,i-2)=0.0d0
2442         endif
2443 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2444         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2445           iti = itortyp(itype(i-2))
2446         else
2447           iti=ntortyp+1
2448         endif
2449 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2450         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2451           iti1 = itortyp(itype(i-1))
2452         else
2453           iti1=ntortyp+1
2454         endif
2455 cd        write (iout,*) '*******i',i,' iti1',iti
2456 cd        write (iout,*) 'b1',b1(:,iti)
2457 cd        write (iout,*) 'b2',b2(:,iti)
2458 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2459 c        if (i .gt. iatel_s+2) then
2460         if (i .gt. nnt+2) then
2461           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2462           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2463           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2464      &    then
2465           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2466           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2467           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2468           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2469           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2470           endif
2471         else
2472           do k=1,2
2473             Ub2(k,i-2)=0.0d0
2474             Ctobr(k,i-2)=0.0d0
2475             Dtobr2(k,i-2)=0.0d0
2476             do l=1,2
2477               EUg(l,k,i-2)=0.0d0
2478               CUg(l,k,i-2)=0.0d0
2479               DUg(l,k,i-2)=0.0d0
2480               DtUg2(l,k,i-2)=0.0d0
2481             enddo
2482           enddo
2483         endif
2484         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2485         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2486         do k=1,2
2487           muder(k,i-2)=Ub2der(k,i-2)
2488         enddo
2489 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2490         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2491           iti1 = itortyp(itype(i-1))
2492         else
2493           iti1=ntortyp+1
2494         endif
2495         do k=1,2
2496           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2497         enddo
2498 cd        write (iout,*) 'mu ',mu(:,i-2)
2499 cd        write (iout,*) 'mu1',mu1(:,i-2)
2500 cd        write (iout,*) 'mu2',mu2(:,i-2)
2501         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2502      &  then
2503         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2504         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2505         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2506         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2507         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2508 C Vectors and matrices dependent on a single virtual-bond dihedral.
2509         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2510         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2511         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2512         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2513         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2514         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2515         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2516         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2517         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2518         endif
2519       enddo
2520 C Matrices dependent on two consecutive virtual-bond dihedrals.
2521 C The order of matrices is from left to right.
2522       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2523      &then
2524 c      do i=max0(ivec_start,2),ivec_end
2525       do i=2,nres-1
2526         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2527         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2528         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2529         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2530         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2531         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2532         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2533         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2534       enddo
2535       endif
2536 #if defined(MPI) && defined(PARMAT)
2537 #ifdef DEBUG
2538 c      if (fg_rank.eq.0) then
2539         write (iout,*) "Arrays UG and UGDER before GATHER"
2540         do i=1,nres-1
2541           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2542      &     ((ug(l,k,i),l=1,2),k=1,2),
2543      &     ((ugder(l,k,i),l=1,2),k=1,2)
2544         enddo
2545         write (iout,*) "Arrays UG2 and UG2DER"
2546         do i=1,nres-1
2547           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2548      &     ((ug2(l,k,i),l=1,2),k=1,2),
2549      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2550         enddo
2551         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2552         do i=1,nres-1
2553           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2554      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2555      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2556         enddo
2557         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2558         do i=1,nres-1
2559           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2560      &     costab(i),sintab(i),costab2(i),sintab2(i)
2561         enddo
2562         write (iout,*) "Array MUDER"
2563         do i=1,nres-1
2564           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2565         enddo
2566 c      endif
2567 #endif
2568       if (nfgtasks.gt.1) then
2569         time00=MPI_Wtime()
2570 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2571 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2572 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2573 #ifdef MATGATHER
2574         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2575      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2576      &   FG_COMM1,IERR)
2577         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2578      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2579      &   FG_COMM1,IERR)
2580         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2581      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2582      &   FG_COMM1,IERR)
2583         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2584      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2585      &   FG_COMM1,IERR)
2586         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2587      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2588      &   FG_COMM1,IERR)
2589         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2590      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2591      &   FG_COMM1,IERR)
2592         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2593      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2594      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2595         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2596      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2597      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2598         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2599      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2600      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2601         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2602      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2603      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2604         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2605      &  then
2606         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2607      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2608      &   FG_COMM1,IERR)
2609         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2610      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2611      &   FG_COMM1,IERR)
2612         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2613      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2614      &   FG_COMM1,IERR)
2615        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2616      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2617      &   FG_COMM1,IERR)
2618         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2619      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2620      &   FG_COMM1,IERR)
2621         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2622      &   ivec_count(fg_rank1),
2623      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2624      &   FG_COMM1,IERR)
2625         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2626      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2627      &   FG_COMM1,IERR)
2628         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2629      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2630      &   FG_COMM1,IERR)
2631         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2632      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2633      &   FG_COMM1,IERR)
2634         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2635      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2636      &   FG_COMM1,IERR)
2637         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2638      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2639      &   FG_COMM1,IERR)
2640         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2641      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2642      &   FG_COMM1,IERR)
2643         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2644      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2645      &   FG_COMM1,IERR)
2646         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2647      &   ivec_count(fg_rank1),
2648      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2649      &   FG_COMM1,IERR)
2650         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2651      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2652      &   FG_COMM1,IERR)
2653        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2654      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2655      &   FG_COMM1,IERR)
2656         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2657      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2658      &   FG_COMM1,IERR)
2659        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2660      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2661      &   FG_COMM1,IERR)
2662         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2663      &   ivec_count(fg_rank1),
2664      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2665      &   FG_COMM1,IERR)
2666         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2667      &   ivec_count(fg_rank1),
2668      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2669      &   FG_COMM1,IERR)
2670         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2671      &   ivec_count(fg_rank1),
2672      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2673      &   MPI_MAT2,FG_COMM1,IERR)
2674         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2675      &   ivec_count(fg_rank1),
2676      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2677      &   MPI_MAT2,FG_COMM1,IERR)
2678         endif
2679 #else
2680 c Passes matrix info through the ring
2681       isend=fg_rank1
2682       irecv=fg_rank1-1
2683       if (irecv.lt.0) irecv=nfgtasks1-1
2684       iprev=irecv
2685       inext=fg_rank1+1
2686       if (inext.ge.nfgtasks1) inext=0
2687       do i=1,nfgtasks1-1
2688 c        write (iout,*) "isend",isend," irecv",irecv
2689 c        call flush(iout)
2690         lensend=lentyp(isend)
2691         lenrecv=lentyp(irecv)
2692 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2693 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2694 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2695 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2696 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2697 c        write (iout,*) "Gather ROTAT1"
2698 c        call flush(iout)
2699 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2700 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2701 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2702 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2703 c        write (iout,*) "Gather ROTAT2"
2704 c        call flush(iout)
2705         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2706      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2707      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2708      &   iprev,4400+irecv,FG_COMM,status,IERR)
2709 c        write (iout,*) "Gather ROTAT_OLD"
2710 c        call flush(iout)
2711         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2712      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2713      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2714      &   iprev,5500+irecv,FG_COMM,status,IERR)
2715 c        write (iout,*) "Gather PRECOMP11"
2716 c        call flush(iout)
2717         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2718      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2719      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2720      &   iprev,6600+irecv,FG_COMM,status,IERR)
2721 c        write (iout,*) "Gather PRECOMP12"
2722 c        call flush(iout)
2723         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2724      &  then
2725         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2726      &   MPI_ROTAT2(lensend),inext,7700+isend,
2727      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2728      &   iprev,7700+irecv,FG_COMM,status,IERR)
2729 c        write (iout,*) "Gather PRECOMP21"
2730 c        call flush(iout)
2731         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2732      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2733      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2734      &   iprev,8800+irecv,FG_COMM,status,IERR)
2735 c        write (iout,*) "Gather PRECOMP22"
2736 c        call flush(iout)
2737         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2738      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2739      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2740      &   MPI_PRECOMP23(lenrecv),
2741      &   iprev,9900+irecv,FG_COMM,status,IERR)
2742 c        write (iout,*) "Gather PRECOMP23"
2743 c        call flush(iout)
2744         endif
2745         isend=irecv
2746         irecv=irecv-1
2747         if (irecv.lt.0) irecv=nfgtasks1-1
2748       enddo
2749 #endif
2750         time_gather=time_gather+MPI_Wtime()-time00
2751       endif
2752 #ifdef DEBUG
2753 c      if (fg_rank.eq.0) then
2754         write (iout,*) "Arrays UG and UGDER"
2755         do i=1,nres-1
2756           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2757      &     ((ug(l,k,i),l=1,2),k=1,2),
2758      &     ((ugder(l,k,i),l=1,2),k=1,2)
2759         enddo
2760         write (iout,*) "Arrays UG2 and UG2DER"
2761         do i=1,nres-1
2762           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2763      &     ((ug2(l,k,i),l=1,2),k=1,2),
2764      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2765         enddo
2766         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2767         do i=1,nres-1
2768           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2769      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2770      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2771         enddo
2772         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2773         do i=1,nres-1
2774           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2775      &     costab(i),sintab(i),costab2(i),sintab2(i)
2776         enddo
2777         write (iout,*) "Array MUDER"
2778         do i=1,nres-1
2779           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2780         enddo
2781 c      endif
2782 #endif
2783 #endif
2784 cd      do i=1,nres
2785 cd        iti = itortyp(itype(i))
2786 cd        write (iout,*) i
2787 cd        do j=1,2
2788 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2789 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2790 cd        enddo
2791 cd      enddo
2792       return
2793       end
2794 C--------------------------------------------------------------------------
2795       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2796 C
2797 C This subroutine calculates the average interaction energy and its gradient
2798 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2799 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2800 C The potential depends both on the distance of peptide-group centers and on
2801 C the orientation of the CA-CA virtual bonds.
2802 C
2803       implicit real*8 (a-h,o-z)
2804 #ifdef MPI
2805       include 'mpif.h'
2806 #endif
2807       include 'DIMENSIONS'
2808       include 'COMMON.CONTROL'
2809       include 'COMMON.SETUP'
2810       include 'COMMON.IOUNITS'
2811       include 'COMMON.GEO'
2812       include 'COMMON.VAR'
2813       include 'COMMON.LOCAL'
2814       include 'COMMON.CHAIN'
2815       include 'COMMON.DERIV'
2816       include 'COMMON.INTERACT'
2817       include 'COMMON.CONTACTS'
2818       include 'COMMON.TORSION'
2819       include 'COMMON.VECTORS'
2820       include 'COMMON.FFIELD'
2821       include 'COMMON.TIME1'
2822       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2823      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2824       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2825      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2826       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2827      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2828      &    num_conti,j1,j2
2829 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2830 #ifdef MOMENT
2831       double precision scal_el /1.0d0/
2832 #else
2833       double precision scal_el /0.5d0/
2834 #endif
2835 C 12/13/98
2836 C 13-go grudnia roku pamietnego...
2837       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2838      &                   0.0d0,1.0d0,0.0d0,
2839      &                   0.0d0,0.0d0,1.0d0/
2840 cd      write(iout,*) 'In EELEC'
2841 cd      do i=1,nloctyp
2842 cd        write(iout,*) 'Type',i
2843 cd        write(iout,*) 'B1',B1(:,i)
2844 cd        write(iout,*) 'B2',B2(:,i)
2845 cd        write(iout,*) 'CC',CC(:,:,i)
2846 cd        write(iout,*) 'DD',DD(:,:,i)
2847 cd        write(iout,*) 'EE',EE(:,:,i)
2848 cd      enddo
2849 cd      call check_vecgrad
2850 cd      stop
2851       if (icheckgrad.eq.1) then
2852         do i=1,nres-1
2853           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2854           do k=1,3
2855             dc_norm(k,i)=dc(k,i)*fac
2856           enddo
2857 c          write (iout,*) 'i',i,' fac',fac
2858         enddo
2859       endif
2860       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2861      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2862      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2863 c        call vec_and_deriv
2864 #ifdef TIMING
2865         time01=MPI_Wtime()
2866 #endif
2867         call set_matrices
2868 #ifdef TIMING
2869         time_mat=time_mat+MPI_Wtime()-time01
2870 #endif
2871       endif
2872 cd      do i=1,nres-1
2873 cd        write (iout,*) 'i=',i
2874 cd        do k=1,3
2875 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2876 cd        enddo
2877 cd        do k=1,3
2878 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2879 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2880 cd        enddo
2881 cd      enddo
2882       t_eelecij=0.0d0
2883       ees=0.0D0
2884       evdw1=0.0D0
2885       eel_loc=0.0d0
2886       eello_turn3=0.0d0
2887       eello_turn4=0.0d0
2888       ind=0
2889       do i=1,nres
2890         num_cont_hb(i)=0
2891       enddo
2892 cd      print '(a)','Enter EELEC'
2893 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2894       do i=1,nres
2895         gel_loc_loc(i)=0.0d0
2896         gcorr_loc(i)=0.0d0
2897       enddo
2898 c
2899 c
2900 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2901 C
2902 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2903 C
2904       do i=iturn3_start,iturn3_end
2905         dxi=dc(1,i)
2906         dyi=dc(2,i)
2907         dzi=dc(3,i)
2908         dx_normi=dc_norm(1,i)
2909         dy_normi=dc_norm(2,i)
2910         dz_normi=dc_norm(3,i)
2911         xmedi=c(1,i)+0.5d0*dxi
2912         ymedi=c(2,i)+0.5d0*dyi
2913         zmedi=c(3,i)+0.5d0*dzi
2914         num_conti=0
2915         call eelecij(i,i+2,ees,evdw1,eel_loc)
2916         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2917         num_cont_hb(i)=num_conti
2918       enddo
2919       do i=iturn4_start,iturn4_end
2920         dxi=dc(1,i)
2921         dyi=dc(2,i)
2922         dzi=dc(3,i)
2923         dx_normi=dc_norm(1,i)
2924         dy_normi=dc_norm(2,i)
2925         dz_normi=dc_norm(3,i)
2926         xmedi=c(1,i)+0.5d0*dxi
2927         ymedi=c(2,i)+0.5d0*dyi
2928         zmedi=c(3,i)+0.5d0*dzi
2929         num_conti=num_cont_hb(i)
2930         call eelecij(i,i+3,ees,evdw1,eel_loc)
2931         if (wturn4.gt.0.0d0) call eturn4(i,eello_turn4)
2932         num_cont_hb(i)=num_conti
2933       enddo   ! i
2934 c
2935 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2936 c
2937       do i=iatel_s,iatel_e
2938         dxi=dc(1,i)
2939         dyi=dc(2,i)
2940         dzi=dc(3,i)
2941         dx_normi=dc_norm(1,i)
2942         dy_normi=dc_norm(2,i)
2943         dz_normi=dc_norm(3,i)
2944         xmedi=c(1,i)+0.5d0*dxi
2945         ymedi=c(2,i)+0.5d0*dyi
2946         zmedi=c(3,i)+0.5d0*dzi
2947 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2948         num_conti=num_cont_hb(i)
2949         do j=ielstart(i),ielend(i)
2950           call eelecij(i,j,ees,evdw1,eel_loc)
2951         enddo ! j
2952         num_cont_hb(i)=num_conti
2953       enddo   ! i
2954 c      write (iout,*) "Number of loop steps in EELEC:",ind
2955 cd      do i=1,nres
2956 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2957 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2958 cd      enddo
2959 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2960 ccc      eel_loc=eel_loc+eello_turn3
2961 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2962       return
2963       end
2964 C-------------------------------------------------------------------------------
2965       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2966       implicit real*8 (a-h,o-z)
2967       include 'DIMENSIONS'
2968 #ifdef MPI
2969       include "mpif.h"
2970 #endif
2971       include 'COMMON.CONTROL'
2972       include 'COMMON.IOUNITS'
2973       include 'COMMON.GEO'
2974       include 'COMMON.VAR'
2975       include 'COMMON.LOCAL'
2976       include 'COMMON.CHAIN'
2977       include 'COMMON.DERIV'
2978       include 'COMMON.INTERACT'
2979       include 'COMMON.CONTACTS'
2980       include 'COMMON.TORSION'
2981       include 'COMMON.VECTORS'
2982       include 'COMMON.FFIELD'
2983       include 'COMMON.TIME1'
2984       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2985      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2986       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2987      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2988       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2989      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2990      &    num_conti,j1,j2
2991 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2992 #ifdef MOMENT
2993       double precision scal_el /1.0d0/
2994 #else
2995       double precision scal_el /0.5d0/
2996 #endif
2997 C 12/13/98
2998 C 13-go grudnia roku pamietnego...
2999       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3000      &                   0.0d0,1.0d0,0.0d0,
3001      &                   0.0d0,0.0d0,1.0d0/
3002 c          time00=MPI_Wtime()
3003 cd      write (iout,*) "eelecij",i,j
3004 c          ind=ind+1
3005           iteli=itel(i)
3006           itelj=itel(j)
3007           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3008           aaa=app(iteli,itelj)
3009           bbb=bpp(iteli,itelj)
3010           ael6i=ael6(iteli,itelj)
3011           ael3i=ael3(iteli,itelj)
3012           dxj=dc(1,j)
3013           dyj=dc(2,j)
3014           dzj=dc(3,j)
3015           dx_normj=dc_norm(1,j)
3016           dy_normj=dc_norm(2,j)
3017           dz_normj=dc_norm(3,j)
3018           xj=c(1,j)+0.5D0*dxj-xmedi
3019           yj=c(2,j)+0.5D0*dyj-ymedi
3020           zj=c(3,j)+0.5D0*dzj-zmedi
3021           rij=xj*xj+yj*yj+zj*zj
3022           rrmij=1.0D0/rij
3023           rij=dsqrt(rij)
3024           rmij=1.0D0/rij
3025           r3ij=rrmij*rmij
3026           r6ij=r3ij*r3ij
3027           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3028           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3029           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3030           fac=cosa-3.0D0*cosb*cosg
3031           ev1=aaa*r6ij*r6ij
3032 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3033           if (j.eq.i+2) ev1=scal_el*ev1
3034           ev2=bbb*r6ij
3035           fac3=ael6i*r6ij
3036           fac4=ael3i*r3ij
3037           evdwij=ev1+ev2
3038           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3039           el2=fac4*fac
3040           eesij=el1+el2
3041 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3042           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3043           ees=ees+eesij
3044           evdw1=evdw1+evdwij
3045 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3046 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3047 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3048 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3049
3050           if (energy_dec) then
3051               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3052               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3053           endif
3054
3055 C
3056 C Calculate contributions to the Cartesian gradient.
3057 C
3058 #ifdef SPLITELE
3059           facvdw=-6*rrmij*(ev1+evdwij)
3060           facel=-3*rrmij*(el1+eesij)
3061           fac1=fac
3062           erij(1)=xj*rmij
3063           erij(2)=yj*rmij
3064           erij(3)=zj*rmij
3065 *
3066 * Radial derivatives. First process both termini of the fragment (i,j)
3067 *
3068           ggg(1)=facel*xj
3069           ggg(2)=facel*yj
3070           ggg(3)=facel*zj
3071 c          do k=1,3
3072 c            ghalf=0.5D0*ggg(k)
3073 c            gelc(k,i)=gelc(k,i)+ghalf
3074 c            gelc(k,j)=gelc(k,j)+ghalf
3075 c          enddo
3076 c 9/28/08 AL Gradient compotents will be summed only at the end
3077           do k=1,3
3078             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3079             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3080           enddo
3081 *
3082 * Loop over residues i+1 thru j-1.
3083 *
3084 cgrad          do k=i+1,j-1
3085 cgrad            do l=1,3
3086 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3087 cgrad            enddo
3088 cgrad          enddo
3089           ggg(1)=facvdw*xj
3090           ggg(2)=facvdw*yj
3091           ggg(3)=facvdw*zj
3092 c          do k=1,3
3093 c            ghalf=0.5D0*ggg(k)
3094 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3095 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3096 c          enddo
3097 c 9/28/08 AL Gradient compotents will be summed only at the end
3098           do k=1,3
3099             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3100             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3101           enddo
3102 *
3103 * Loop over residues i+1 thru j-1.
3104 *
3105 cgrad          do k=i+1,j-1
3106 cgrad            do l=1,3
3107 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3108 cgrad            enddo
3109 cgrad          enddo
3110 #else
3111           facvdw=ev1+evdwij
3112           facel=el1+eesij
3113           fac1=fac
3114           fac=-3*rrmij*(facvdw+facvdw+facel)
3115           erij(1)=xj*rmij
3116           erij(2)=yj*rmij
3117           erij(3)=zj*rmij
3118 *
3119 * Radial derivatives. First process both termini of the fragment (i,j)
3120 *
3121           ggg(1)=fac*xj
3122           ggg(2)=fac*yj
3123           ggg(3)=fac*zj
3124 c          do k=1,3
3125 c            ghalf=0.5D0*ggg(k)
3126 c            gelc(k,i)=gelc(k,i)+ghalf
3127 c            gelc(k,j)=gelc(k,j)+ghalf
3128 c          enddo
3129 c 9/28/08 AL Gradient compotents will be summed only at the end
3130           do k=1,3
3131             gelc_long(k,j)=gelc(k,j)+ggg(k)
3132             gelc_long(k,i)=gelc(k,i)-ggg(k)
3133           enddo
3134 *
3135 * Loop over residues i+1 thru j-1.
3136 *
3137 cgrad          do k=i+1,j-1
3138 cgrad            do l=1,3
3139 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3140 cgrad            enddo
3141 cgrad          enddo
3142 c 9/28/08 AL Gradient compotents will be summed only at the end
3143           ggg(1)=facvdw*xj
3144           ggg(2)=facvdw*yj
3145           ggg(3)=facvdw*zj
3146           do k=1,3
3147             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3148             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3149           enddo
3150 #endif
3151 *
3152 * Angular part
3153 *
3154           ecosa=2.0D0*fac3*fac1+fac4
3155           fac4=-3.0D0*fac4
3156           fac3=-6.0D0*fac3
3157           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3158           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3159           do k=1,3
3160             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3161             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3162           enddo
3163 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3164 cd   &          (dcosg(k),k=1,3)
3165           do k=1,3
3166             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3167           enddo
3168 c          do k=1,3
3169 c            ghalf=0.5D0*ggg(k)
3170 c            gelc(k,i)=gelc(k,i)+ghalf
3171 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3172 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3173 c            gelc(k,j)=gelc(k,j)+ghalf
3174 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3175 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3176 c          enddo
3177 cgrad          do k=i+1,j-1
3178 cgrad            do l=1,3
3179 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3180 cgrad            enddo
3181 cgrad          enddo
3182           do k=1,3
3183             gelc(k,i)=gelc(k,i)
3184      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3185      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3186             gelc(k,j)=gelc(k,j)
3187      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3188      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3189             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3190             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3191           enddo
3192           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3193      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3194      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3195 C
3196 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3197 C   energy of a peptide unit is assumed in the form of a second-order
3198 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3199 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3200 C   are computed for EVERY pair of non-contiguous peptide groups.
3201 C
3202           if (j.lt.nres-1) then
3203             j1=j+1
3204             j2=j-1
3205           else
3206             j1=j-1
3207             j2=j-2
3208           endif
3209           kkk=0
3210           do k=1,2
3211             do l=1,2
3212               kkk=kkk+1
3213               muij(kkk)=mu(k,i)*mu(l,j)
3214             enddo
3215           enddo
3216 cd         write (iout,*) 'EELEC: i',i,' j',j
3217 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3218 cd          write(iout,*) 'muij',muij
3219           ury=scalar(uy(1,i),erij)
3220           urz=scalar(uz(1,i),erij)
3221           vry=scalar(uy(1,j),erij)
3222           vrz=scalar(uz(1,j),erij)
3223           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3224           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3225           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3226           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3227           fac=dsqrt(-ael6i)*r3ij
3228           a22=a22*fac
3229           a23=a23*fac
3230           a32=a32*fac
3231           a33=a33*fac
3232 cd          write (iout,'(4i5,4f10.5)')
3233 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3234 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3235 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3236 cd     &      uy(:,j),uz(:,j)
3237 cd          write (iout,'(4f10.5)')
3238 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3239 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3240 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3241 cd           write (iout,'(9f10.5/)')
3242 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3243 C Derivatives of the elements of A in virtual-bond vectors
3244           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3245           do k=1,3
3246             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3247             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3248             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3249             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3250             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3251             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3252             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3253             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3254             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3255             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3256             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3257             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3258           enddo
3259 C Compute radial contributions to the gradient
3260           facr=-3.0d0*rrmij
3261           a22der=a22*facr
3262           a23der=a23*facr
3263           a32der=a32*facr
3264           a33der=a33*facr
3265           agg(1,1)=a22der*xj
3266           agg(2,1)=a22der*yj
3267           agg(3,1)=a22der*zj
3268           agg(1,2)=a23der*xj
3269           agg(2,2)=a23der*yj
3270           agg(3,2)=a23der*zj
3271           agg(1,3)=a32der*xj
3272           agg(2,3)=a32der*yj
3273           agg(3,3)=a32der*zj
3274           agg(1,4)=a33der*xj
3275           agg(2,4)=a33der*yj
3276           agg(3,4)=a33der*zj
3277 C Add the contributions coming from er
3278           fac3=-3.0d0*fac
3279           do k=1,3
3280             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3281             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3282             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3283             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3284           enddo
3285           do k=1,3
3286 C Derivatives in DC(i)
3287 cgrad            ghalf1=0.5d0*agg(k,1)
3288 cgrad            ghalf2=0.5d0*agg(k,2)
3289 cgrad            ghalf3=0.5d0*agg(k,3)
3290 cgrad            ghalf4=0.5d0*agg(k,4)
3291             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3292      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3293             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3294      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3295             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3296      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3297             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3298      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3299 C Derivatives in DC(i+1)
3300             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3301      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3302             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3303      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3304             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3305      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3306             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3307      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3308 C Derivatives in DC(j)
3309             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3310      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3311             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3312      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3313             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3314      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3315             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3316      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3317 C Derivatives in DC(j+1) or DC(nres-1)
3318             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3319      &      -3.0d0*vryg(k,3)*ury)
3320             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3321      &      -3.0d0*vrzg(k,3)*ury)
3322             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3323      &      -3.0d0*vryg(k,3)*urz)
3324             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3325      &      -3.0d0*vrzg(k,3)*urz)
3326 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3327 cgrad              do l=1,4
3328 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3329 cgrad              enddo
3330 cgrad            endif
3331           enddo
3332           acipa(1,1)=a22
3333           acipa(1,2)=a23
3334           acipa(2,1)=a32
3335           acipa(2,2)=a33
3336           a22=-a22
3337           a23=-a23
3338           do l=1,2
3339             do k=1,3
3340               agg(k,l)=-agg(k,l)
3341               aggi(k,l)=-aggi(k,l)
3342               aggi1(k,l)=-aggi1(k,l)
3343               aggj(k,l)=-aggj(k,l)
3344               aggj1(k,l)=-aggj1(k,l)
3345             enddo
3346           enddo
3347           if (j.lt.nres-1) then
3348             a22=-a22
3349             a32=-a32
3350             do l=1,3,2
3351               do k=1,3
3352                 agg(k,l)=-agg(k,l)
3353                 aggi(k,l)=-aggi(k,l)
3354                 aggi1(k,l)=-aggi1(k,l)
3355                 aggj(k,l)=-aggj(k,l)
3356                 aggj1(k,l)=-aggj1(k,l)
3357               enddo
3358             enddo
3359           else
3360             a22=-a22
3361             a23=-a23
3362             a32=-a32
3363             a33=-a33
3364             do l=1,4
3365               do k=1,3
3366                 agg(k,l)=-agg(k,l)
3367                 aggi(k,l)=-aggi(k,l)
3368                 aggi1(k,l)=-aggi1(k,l)
3369                 aggj(k,l)=-aggj(k,l)
3370                 aggj1(k,l)=-aggj1(k,l)
3371               enddo
3372             enddo
3373           endif
3374           ENDIF ! WCORR
3375           IF (wel_loc.gt.0.0d0) THEN
3376 C Contribution to the local-electrostatic energy coming from the i-j pair
3377           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3378      &     +a33*muij(4)
3379 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3380
3381           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3382      &            'eelloc',i,j,eel_loc_ij
3383
3384           eel_loc=eel_loc+eel_loc_ij
3385 C Partial derivatives in virtual-bond dihedral angles gamma
3386           if (i.gt.1)
3387      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3388      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3389      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3390           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3391      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3392      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3393 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3394           do l=1,3
3395             ggg(l)=agg(l,1)*muij(1)+
3396      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3397             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3398             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3399 cgrad            ghalf=0.5d0*ggg(l)
3400 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3401 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3402           enddo
3403 cgrad          do k=i+1,j2
3404 cgrad            do l=1,3
3405 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3406 cgrad            enddo
3407 cgrad          enddo
3408 C Remaining derivatives of eello
3409           do l=1,3
3410             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3411      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3412             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3413      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3414             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3415      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3416             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3417      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3418           enddo
3419           ENDIF
3420 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3421 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3422           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3423      &       .and. num_conti.le.maxconts) then
3424 c            write (iout,*) i,j," entered corr"
3425 C
3426 C Calculate the contact function. The ith column of the array JCONT will
3427 C contain the numbers of atoms that make contacts with the atom I (of numbers
3428 C greater than I). The arrays FACONT and GACONT will contain the values of
3429 C the contact function and its derivative.
3430 c           r0ij=1.02D0*rpp(iteli,itelj)
3431 c           r0ij=1.11D0*rpp(iteli,itelj)
3432             r0ij=2.20D0*rpp(iteli,itelj)
3433 c           r0ij=1.55D0*rpp(iteli,itelj)
3434             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3435             if (fcont.gt.0.0D0) then
3436               num_conti=num_conti+1
3437               if (num_conti.gt.maxconts) then
3438                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3439      &                         ' will skip next contacts for this conf.'
3440               else
3441                 jcont_hb(num_conti,i)=j
3442 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3443 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3444                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3445      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3446 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3447 C  terms.
3448                 d_cont(num_conti,i)=rij
3449 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3450 C     --- Electrostatic-interaction matrix ---
3451                 a_chuj(1,1,num_conti,i)=a22
3452                 a_chuj(1,2,num_conti,i)=a23
3453                 a_chuj(2,1,num_conti,i)=a32
3454                 a_chuj(2,2,num_conti,i)=a33
3455 C     --- Gradient of rij
3456                 do kkk=1,3
3457                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3458                 enddo
3459                 kkll=0
3460                 do k=1,2
3461                   do l=1,2
3462                     kkll=kkll+1
3463                     do m=1,3
3464                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3465                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3466                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3467                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3468                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3469                     enddo
3470                   enddo
3471                 enddo
3472                 ENDIF
3473                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3474 C Calculate contact energies
3475                 cosa4=4.0D0*cosa
3476                 wij=cosa-3.0D0*cosb*cosg
3477                 cosbg1=cosb+cosg
3478                 cosbg2=cosb-cosg
3479 c               fac3=dsqrt(-ael6i)/r0ij**3
3480                 fac3=dsqrt(-ael6i)*r3ij
3481 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3482                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3483                 if (ees0tmp.gt.0) then
3484                   ees0pij=dsqrt(ees0tmp)
3485                 else
3486                   ees0pij=0
3487                 endif
3488 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3489                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3490                 if (ees0tmp.gt.0) then
3491                   ees0mij=dsqrt(ees0tmp)
3492                 else
3493                   ees0mij=0
3494                 endif
3495 c               ees0mij=0.0D0
3496                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3497                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3498 C Diagnostics. Comment out or remove after debugging!
3499 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3500 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3501 c               ees0m(num_conti,i)=0.0D0
3502 C End diagnostics.
3503 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3504 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3505 C Angular derivatives of the contact function
3506                 ees0pij1=fac3/ees0pij
3507                 ees0mij1=fac3/ees0mij
3508                 fac3p=-3.0D0*fac3*rrmij
3509                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3510                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3511 c               ees0mij1=0.0D0
3512                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3513                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3514                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3515                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3516                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3517                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3518                 ecosap=ecosa1+ecosa2
3519                 ecosbp=ecosb1+ecosb2
3520                 ecosgp=ecosg1+ecosg2
3521                 ecosam=ecosa1-ecosa2
3522                 ecosbm=ecosb1-ecosb2
3523                 ecosgm=ecosg1-ecosg2
3524 C Diagnostics
3525 c               ecosap=ecosa1
3526 c               ecosbp=ecosb1
3527 c               ecosgp=ecosg1
3528 c               ecosam=0.0D0
3529 c               ecosbm=0.0D0
3530 c               ecosgm=0.0D0
3531 C End diagnostics
3532                 facont_hb(num_conti,i)=fcont
3533                 fprimcont=fprimcont/rij
3534 cd              facont_hb(num_conti,i)=1.0D0
3535 C Following line is for diagnostics.
3536 cd              fprimcont=0.0D0
3537                 do k=1,3
3538                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3539                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3540                 enddo
3541                 do k=1,3
3542                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3543                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3544                 enddo
3545                 gggp(1)=gggp(1)+ees0pijp*xj
3546                 gggp(2)=gggp(2)+ees0pijp*yj
3547                 gggp(3)=gggp(3)+ees0pijp*zj
3548                 gggm(1)=gggm(1)+ees0mijp*xj
3549                 gggm(2)=gggm(2)+ees0mijp*yj
3550                 gggm(3)=gggm(3)+ees0mijp*zj
3551 C Derivatives due to the contact function
3552                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3553                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3554                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3555                 do k=1,3
3556 c
3557 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3558 c          following the change of gradient-summation algorithm.
3559 c
3560 cgrad                  ghalfp=0.5D0*gggp(k)
3561 cgrad                  ghalfm=0.5D0*gggm(k)
3562                   gacontp_hb1(k,num_conti,i)=!ghalfp
3563      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3564      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3565                   gacontp_hb2(k,num_conti,i)=!ghalfp
3566      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3567      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3568                   gacontp_hb3(k,num_conti,i)=gggp(k)
3569                   gacontm_hb1(k,num_conti,i)=!ghalfm
3570      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3571      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3572                   gacontm_hb2(k,num_conti,i)=!ghalfm
3573      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3574      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3575                   gacontm_hb3(k,num_conti,i)=gggm(k)
3576                 enddo
3577 C Diagnostics. Comment out or remove after debugging!
3578 cdiag           do k=1,3
3579 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3580 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3581 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3582 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3583 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3584 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3585 cdiag           enddo
3586               ENDIF ! wcorr
3587               endif  ! num_conti.le.maxconts
3588             endif  ! fcont.gt.0
3589           endif    ! j.gt.i+1
3590           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3591             do k=1,4
3592               do l=1,3
3593                 ghalf=0.5d0*agg(l,k)
3594                 aggi(l,k)=aggi(l,k)+ghalf
3595                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3596                 aggj(l,k)=aggj(l,k)+ghalf
3597               enddo
3598             enddo
3599             if (j.eq.nres-1 .and. i.lt.j-2) then
3600               do k=1,4
3601                 do l=1,3
3602                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3603                 enddo
3604               enddo
3605             endif
3606           endif
3607 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3608       return
3609       end
3610 C-----------------------------------------------------------------------------
3611       subroutine eturn3(i,eello_turn3)
3612 C Third- and fourth-order contributions from turns
3613       implicit real*8 (a-h,o-z)
3614       include 'DIMENSIONS'
3615       include 'COMMON.IOUNITS'
3616       include 'COMMON.GEO'
3617       include 'COMMON.VAR'
3618       include 'COMMON.LOCAL'
3619       include 'COMMON.CHAIN'
3620       include 'COMMON.DERIV'
3621       include 'COMMON.INTERACT'
3622       include 'COMMON.CONTACTS'
3623       include 'COMMON.TORSION'
3624       include 'COMMON.VECTORS'
3625       include 'COMMON.FFIELD'
3626       include 'COMMON.CONTROL'
3627       dimension ggg(3)
3628       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3629      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3630      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3631       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3632      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3633       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3634      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3635      &    num_conti,j1,j2
3636       j=i+2
3637 c      write (iout,*) "eturn3",i,j,j1,j2
3638       a_temp(1,1)=a22
3639       a_temp(1,2)=a23
3640       a_temp(2,1)=a32
3641       a_temp(2,2)=a33
3642 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3643 C
3644 C               Third-order contributions
3645 C
3646 C                 (i+2)o----(i+3)
3647 C                      | |
3648 C                      | |
3649 C                 (i+1)o----i
3650 C
3651 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3652 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3653         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3654         call transpose2(auxmat(1,1),auxmat1(1,1))
3655         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3656         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3657         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3658      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3659 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3660 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3661 cd     &    ' eello_turn3_num',4*eello_turn3_num
3662 C Derivatives in gamma(i)
3663         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3664         call transpose2(auxmat2(1,1),auxmat3(1,1))
3665         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3666         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3667 C Derivatives in gamma(i+1)
3668         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3669         call transpose2(auxmat2(1,1),auxmat3(1,1))
3670         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3671         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3672      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3673 C Cartesian derivatives
3674         do l=1,3
3675 c            ghalf1=0.5d0*agg(l,1)
3676 c            ghalf2=0.5d0*agg(l,2)
3677 c            ghalf3=0.5d0*agg(l,3)
3678 c            ghalf4=0.5d0*agg(l,4)
3679           a_temp(1,1)=aggi(l,1)!+ghalf1
3680           a_temp(1,2)=aggi(l,2)!+ghalf2
3681           a_temp(2,1)=aggi(l,3)!+ghalf3
3682           a_temp(2,2)=aggi(l,4)!+ghalf4
3683           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3684           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3685      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3686           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3687           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3688           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3689           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3690           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3691           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3692      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3693           a_temp(1,1)=aggj(l,1)!+ghalf1
3694           a_temp(1,2)=aggj(l,2)!+ghalf2
3695           a_temp(2,1)=aggj(l,3)!+ghalf3
3696           a_temp(2,2)=aggj(l,4)!+ghalf4
3697           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3698           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3699      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3700           a_temp(1,1)=aggj1(l,1)
3701           a_temp(1,2)=aggj1(l,2)
3702           a_temp(2,1)=aggj1(l,3)
3703           a_temp(2,2)=aggj1(l,4)
3704           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3705           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3706      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3707         enddo
3708       return
3709       end
3710 C-------------------------------------------------------------------------------
3711       subroutine eturn4(i,eello_turn4)
3712 C Third- and fourth-order contributions from turns
3713       implicit real*8 (a-h,o-z)
3714       include 'DIMENSIONS'
3715       include 'COMMON.IOUNITS'
3716       include 'COMMON.GEO'
3717       include 'COMMON.VAR'
3718       include 'COMMON.LOCAL'
3719       include 'COMMON.CHAIN'
3720       include 'COMMON.DERIV'
3721       include 'COMMON.INTERACT'
3722       include 'COMMON.CONTACTS'
3723       include 'COMMON.TORSION'
3724       include 'COMMON.VECTORS'
3725       include 'COMMON.FFIELD'
3726       include 'COMMON.CONTROL'
3727       dimension ggg(3)
3728       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3729      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3730      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3731       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3732      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3733       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3734      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3735      &    num_conti,j1,j2
3736       j=i+3
3737 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3738 C
3739 C               Fourth-order contributions
3740 C
3741 C                 (i+3)o----(i+4)
3742 C                     /  |
3743 C               (i+2)o   |
3744 C                     \  |
3745 C                 (i+1)o----i
3746 C
3747 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3748 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3749 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3750         a_temp(1,1)=a22
3751         a_temp(1,2)=a23
3752         a_temp(2,1)=a32
3753         a_temp(2,2)=a33
3754         iti1=itortyp(itype(i+1))
3755         iti2=itortyp(itype(i+2))
3756         iti3=itortyp(itype(i+3))
3757 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3758         call transpose2(EUg(1,1,i+1),e1t(1,1))
3759         call transpose2(Eug(1,1,i+2),e2t(1,1))
3760         call transpose2(Eug(1,1,i+3),e3t(1,1))
3761         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3762         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3763         s1=scalar2(b1(1,iti2),auxvec(1))
3764         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3765         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3766         s2=scalar2(b1(1,iti1),auxvec(1))
3767         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3768         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3769         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3770         eello_turn4=eello_turn4-(s1+s2+s3)
3771         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3772      &      'eturn4',i,j,-(s1+s2+s3)
3773 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3774 cd     &    ' eello_turn4_num',8*eello_turn4_num
3775 C Derivatives in gamma(i)
3776         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3777         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3778         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3779         s1=scalar2(b1(1,iti2),auxvec(1))
3780         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3781         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3782         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3783 C Derivatives in gamma(i+1)
3784         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3785         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3786         s2=scalar2(b1(1,iti1),auxvec(1))
3787         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3788         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3789         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3790         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3791 C Derivatives in gamma(i+2)
3792         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3793         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3794         s1=scalar2(b1(1,iti2),auxvec(1))
3795         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3796         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3797         s2=scalar2(b1(1,iti1),auxvec(1))
3798         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3799         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3800         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3801         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3802 C Cartesian derivatives
3803 C Derivatives of this turn contributions in DC(i+2)
3804         if (j.lt.nres-1) then
3805           do l=1,3
3806             a_temp(1,1)=agg(l,1)
3807             a_temp(1,2)=agg(l,2)
3808             a_temp(2,1)=agg(l,3)
3809             a_temp(2,2)=agg(l,4)
3810             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3811             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3812             s1=scalar2(b1(1,iti2),auxvec(1))
3813             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3814             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3815             s2=scalar2(b1(1,iti1),auxvec(1))
3816             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3817             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3818             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3819             ggg(l)=-(s1+s2+s3)
3820             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3821           enddo
3822         endif
3823 C Remaining derivatives of this turn contribution
3824         do l=1,3
3825           a_temp(1,1)=aggi(l,1)
3826           a_temp(1,2)=aggi(l,2)
3827           a_temp(2,1)=aggi(l,3)
3828           a_temp(2,2)=aggi(l,4)
3829           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3830           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3831           s1=scalar2(b1(1,iti2),auxvec(1))
3832           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3833           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3834           s2=scalar2(b1(1,iti1),auxvec(1))
3835           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3836           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3837           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3838           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3839           a_temp(1,1)=aggi1(l,1)
3840           a_temp(1,2)=aggi1(l,2)
3841           a_temp(2,1)=aggi1(l,3)
3842           a_temp(2,2)=aggi1(l,4)
3843           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3844           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3845           s1=scalar2(b1(1,iti2),auxvec(1))
3846           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3847           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3848           s2=scalar2(b1(1,iti1),auxvec(1))
3849           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3850           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3851           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3852           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3853           a_temp(1,1)=aggj(l,1)
3854           a_temp(1,2)=aggj(l,2)
3855           a_temp(2,1)=aggj(l,3)
3856           a_temp(2,2)=aggj(l,4)
3857           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3858           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3859           s1=scalar2(b1(1,iti2),auxvec(1))
3860           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3861           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3862           s2=scalar2(b1(1,iti1),auxvec(1))
3863           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3864           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3865           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3866           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3867           a_temp(1,1)=aggj1(l,1)
3868           a_temp(1,2)=aggj1(l,2)
3869           a_temp(2,1)=aggj1(l,3)
3870           a_temp(2,2)=aggj1(l,4)
3871           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3872           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3873           s1=scalar2(b1(1,iti2),auxvec(1))
3874           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3875           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3876           s2=scalar2(b1(1,iti1),auxvec(1))
3877           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3878           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3879           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3880 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3881           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3882         enddo
3883       return
3884       end
3885 C-----------------------------------------------------------------------------
3886       subroutine vecpr(u,v,w)
3887       implicit real*8(a-h,o-z)
3888       dimension u(3),v(3),w(3)
3889       w(1)=u(2)*v(3)-u(3)*v(2)
3890       w(2)=-u(1)*v(3)+u(3)*v(1)
3891       w(3)=u(1)*v(2)-u(2)*v(1)
3892       return
3893       end
3894 C-----------------------------------------------------------------------------
3895       subroutine unormderiv(u,ugrad,unorm,ungrad)
3896 C This subroutine computes the derivatives of a normalized vector u, given
3897 C the derivatives computed without normalization conditions, ugrad. Returns
3898 C ungrad.
3899       implicit none
3900       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3901       double precision vec(3)
3902       double precision scalar
3903       integer i,j
3904 c      write (2,*) 'ugrad',ugrad
3905 c      write (2,*) 'u',u
3906       do i=1,3
3907         vec(i)=scalar(ugrad(1,i),u(1))
3908       enddo
3909 c      write (2,*) 'vec',vec
3910       do i=1,3
3911         do j=1,3
3912           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3913         enddo
3914       enddo
3915 c      write (2,*) 'ungrad',ungrad
3916       return
3917       end
3918 C-----------------------------------------------------------------------------
3919       subroutine escp_soft_sphere(evdw2,evdw2_14)
3920 C
3921 C This subroutine calculates the excluded-volume interaction energy between
3922 C peptide-group centers and side chains and its gradient in virtual-bond and
3923 C side-chain vectors.
3924 C
3925       implicit real*8 (a-h,o-z)
3926       include 'DIMENSIONS'
3927       include 'COMMON.GEO'
3928       include 'COMMON.VAR'
3929       include 'COMMON.LOCAL'
3930       include 'COMMON.CHAIN'
3931       include 'COMMON.DERIV'
3932       include 'COMMON.INTERACT'
3933       include 'COMMON.FFIELD'
3934       include 'COMMON.IOUNITS'
3935       include 'COMMON.CONTROL'
3936       dimension ggg(3)
3937       evdw2=0.0D0
3938       evdw2_14=0.0d0
3939       r0_scp=4.5d0
3940 cd    print '(a)','Enter ESCP'
3941 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3942       do i=iatscp_s,iatscp_e
3943         iteli=itel(i)
3944         xi=0.5D0*(c(1,i)+c(1,i+1))
3945         yi=0.5D0*(c(2,i)+c(2,i+1))
3946         zi=0.5D0*(c(3,i)+c(3,i+1))
3947
3948         do iint=1,nscp_gr(i)
3949
3950         do j=iscpstart(i,iint),iscpend(i,iint)
3951           itypj=itype(j)
3952 C Uncomment following three lines for SC-p interactions
3953 c         xj=c(1,nres+j)-xi
3954 c         yj=c(2,nres+j)-yi
3955 c         zj=c(3,nres+j)-zi
3956 C Uncomment following three lines for Ca-p interactions
3957           xj=c(1,j)-xi
3958           yj=c(2,j)-yi
3959           zj=c(3,j)-zi
3960           rij=xj*xj+yj*yj+zj*zj
3961           r0ij=r0_scp
3962           r0ijsq=r0ij*r0ij
3963           if (rij.lt.r0ijsq) then
3964             evdwij=0.25d0*(rij-r0ijsq)**2
3965             fac=rij-r0ijsq
3966           else
3967             evdwij=0.0d0
3968             fac=0.0d0
3969           endif
3970           evdw2=evdw2+evdwij
3971 C
3972 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3973 C
3974           ggg(1)=xj*fac
3975           ggg(2)=yj*fac
3976           ggg(3)=zj*fac
3977 cgrad          if (j.lt.i) then
3978 cd          write (iout,*) 'j<i'
3979 C Uncomment following three lines for SC-p interactions
3980 c           do k=1,3
3981 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3982 c           enddo
3983 cgrad          else
3984 cd          write (iout,*) 'j>i'
3985 cgrad            do k=1,3
3986 cgrad              ggg(k)=-ggg(k)
3987 C Uncomment following line for SC-p interactions
3988 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3989 cgrad            enddo
3990 cgrad          endif
3991 cgrad          do k=1,3
3992 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3993 cgrad          enddo
3994 cgrad          kstart=min0(i+1,j)
3995 cgrad          kend=max0(i-1,j-1)
3996 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3997 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3998 cgrad          do k=kstart,kend
3999 cgrad            do l=1,3
4000 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4001 cgrad            enddo
4002 cgrad          enddo
4003           do k=1,3
4004             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4005             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4006           enddo
4007         enddo
4008
4009         enddo ! iint
4010       enddo ! i
4011       return
4012       end
4013 C-----------------------------------------------------------------------------
4014       subroutine escp(evdw2,evdw2_14)
4015 C
4016 C This subroutine calculates the excluded-volume interaction energy between
4017 C peptide-group centers and side chains and its gradient in virtual-bond and
4018 C side-chain vectors.
4019 C
4020       implicit real*8 (a-h,o-z)
4021       include 'DIMENSIONS'
4022       include 'COMMON.GEO'
4023       include 'COMMON.VAR'
4024       include 'COMMON.LOCAL'
4025       include 'COMMON.CHAIN'
4026       include 'COMMON.DERIV'
4027       include 'COMMON.INTERACT'
4028       include 'COMMON.FFIELD'
4029       include 'COMMON.IOUNITS'
4030       include 'COMMON.CONTROL'
4031       dimension ggg(3)
4032       evdw2=0.0D0
4033       evdw2_14=0.0d0
4034 cd    print '(a)','Enter ESCP'
4035 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4036       do i=iatscp_s,iatscp_e
4037         iteli=itel(i)
4038         xi=0.5D0*(c(1,i)+c(1,i+1))
4039         yi=0.5D0*(c(2,i)+c(2,i+1))
4040         zi=0.5D0*(c(3,i)+c(3,i+1))
4041
4042         do iint=1,nscp_gr(i)
4043
4044         do j=iscpstart(i,iint),iscpend(i,iint)
4045           itypj=itype(j)
4046 C Uncomment following three lines for SC-p interactions
4047 c         xj=c(1,nres+j)-xi
4048 c         yj=c(2,nres+j)-yi
4049 c         zj=c(3,nres+j)-zi
4050 C Uncomment following three lines for Ca-p interactions
4051           xj=c(1,j)-xi
4052           yj=c(2,j)-yi
4053           zj=c(3,j)-zi
4054           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4055           fac=rrij**expon2
4056           e1=fac*fac*aad(itypj,iteli)
4057           e2=fac*bad(itypj,iteli)
4058           if (iabs(j-i) .le. 2) then
4059             e1=scal14*e1
4060             e2=scal14*e2
4061             evdw2_14=evdw2_14+e1+e2
4062           endif
4063           evdwij=e1+e2
4064           evdw2=evdw2+evdwij
4065           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4066      &        'evdw2',i,j,evdwij
4067 C
4068 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4069 C
4070           fac=-(evdwij+e1)*rrij
4071           ggg(1)=xj*fac
4072           ggg(2)=yj*fac
4073           ggg(3)=zj*fac
4074 cgrad          if (j.lt.i) then
4075 cd          write (iout,*) 'j<i'
4076 C Uncomment following three lines for SC-p interactions
4077 c           do k=1,3
4078 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4079 c           enddo
4080 cgrad          else
4081 cd          write (iout,*) 'j>i'
4082 cgrad            do k=1,3
4083 cgrad              ggg(k)=-ggg(k)
4084 C Uncomment following line for SC-p interactions
4085 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4086 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4087 cgrad            enddo
4088 cgrad          endif
4089 cgrad          do k=1,3
4090 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4091 cgrad          enddo
4092 cgrad          kstart=min0(i+1,j)
4093 cgrad          kend=max0(i-1,j-1)
4094 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4095 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4096 cgrad          do k=kstart,kend
4097 cgrad            do l=1,3
4098 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4099 cgrad            enddo
4100 cgrad          enddo
4101           do k=1,3
4102             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4103             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4104           enddo
4105         enddo
4106
4107         enddo ! iint
4108       enddo ! i
4109       do i=1,nct
4110         do j=1,3
4111           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4112           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4113           gradx_scp(j,i)=expon*gradx_scp(j,i)
4114         enddo
4115       enddo
4116 C******************************************************************************
4117 C
4118 C                              N O T E !!!
4119 C
4120 C To save time the factor EXPON has been extracted from ALL components
4121 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4122 C use!
4123 C
4124 C******************************************************************************
4125       return
4126       end
4127 C--------------------------------------------------------------------------
4128       subroutine edis(ehpb)
4129 C
4130 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4131 C
4132       implicit real*8 (a-h,o-z)
4133       include 'DIMENSIONS'
4134       include 'COMMON.SBRIDGE'
4135       include 'COMMON.CHAIN'
4136       include 'COMMON.DERIV'
4137       include 'COMMON.VAR'
4138       include 'COMMON.INTERACT'
4139       include 'COMMON.IOUNITS'
4140       dimension ggg(3)
4141       ehpb=0.0D0
4142 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4143 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4144       if (link_end.eq.0) return
4145       do i=link_start,link_end
4146 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4147 C CA-CA distance used in regularization of structure.
4148         ii=ihpb(i)
4149         jj=jhpb(i)
4150 C iii and jjj point to the residues for which the distance is assigned.
4151         if (ii.gt.nres) then
4152           iii=ii-nres
4153           jjj=jj-nres
4154         else
4155           iii=ii
4156           jjj=jj
4157         endif
4158 cd        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj
4159 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4160 C    distance and angle dependent SS bond potential.
4161         if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4162           call ssbond_ene(iii,jjj,eij)
4163           ehpb=ehpb+2*eij
4164 cd          write (iout,*) "eij",eij
4165         else
4166 C Calculate the distance between the two points and its difference from the
4167 C target distance.
4168         dd=dist(ii,jj)
4169         rdis=dd-dhpb(i)
4170 C Get the force constant corresponding to this distance.
4171         waga=forcon(i)
4172 C Calculate the contribution to energy.
4173         ehpb=ehpb+waga*rdis*rdis
4174 C
4175 C Evaluate gradient.
4176 C
4177         fac=waga*rdis/dd
4178 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4179 cd   &   ' waga=',waga,' fac=',fac
4180         do j=1,3
4181           ggg(j)=fac*(c(j,jj)-c(j,ii))
4182         enddo
4183 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4184 C If this is a SC-SC distance, we need to calculate the contributions to the
4185 C Cartesian gradient in the SC vectors (ghpbx).
4186         if (iii.lt.ii) then
4187           do j=1,3
4188             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4189             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4190           enddo
4191         endif
4192 cgrad        do j=iii,jjj-1
4193 cgrad          do k=1,3
4194 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4195 cgrad          enddo
4196 cgrad        enddo
4197         do k=1,3
4198           ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4199           ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4200         enddo
4201         endif
4202       enddo
4203       ehpb=0.5D0*ehpb
4204       return
4205       end
4206 C--------------------------------------------------------------------------
4207       subroutine ssbond_ene(i,j,eij)
4208 C
4209 C Calculate the distance and angle dependent SS-bond potential energy
4210 C using a free-energy function derived based on RHF/6-31G** ab initio
4211 C calculations of diethyl disulfide.
4212 C
4213 C A. Liwo and U. Kozlowska, 11/24/03
4214 C
4215       implicit real*8 (a-h,o-z)
4216       include 'DIMENSIONS'
4217       include 'COMMON.SBRIDGE'
4218       include 'COMMON.CHAIN'
4219       include 'COMMON.DERIV'
4220       include 'COMMON.LOCAL'
4221       include 'COMMON.INTERACT'
4222       include 'COMMON.VAR'
4223       include 'COMMON.IOUNITS'
4224       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4225       itypi=itype(i)
4226       xi=c(1,nres+i)
4227       yi=c(2,nres+i)
4228       zi=c(3,nres+i)
4229       dxi=dc_norm(1,nres+i)
4230       dyi=dc_norm(2,nres+i)
4231       dzi=dc_norm(3,nres+i)
4232 c      dsci_inv=dsc_inv(itypi)
4233       dsci_inv=vbld_inv(nres+i)
4234       itypj=itype(j)
4235 c      dscj_inv=dsc_inv(itypj)
4236       dscj_inv=vbld_inv(nres+j)
4237       xj=c(1,nres+j)-xi
4238       yj=c(2,nres+j)-yi
4239       zj=c(3,nres+j)-zi
4240       dxj=dc_norm(1,nres+j)
4241       dyj=dc_norm(2,nres+j)
4242       dzj=dc_norm(3,nres+j)
4243       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4244       rij=dsqrt(rrij)
4245       erij(1)=xj*rij
4246       erij(2)=yj*rij
4247       erij(3)=zj*rij
4248       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4249       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4250       om12=dxi*dxj+dyi*dyj+dzi*dzj
4251       do k=1,3
4252         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4253         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4254       enddo
4255       rij=1.0d0/rij
4256       deltad=rij-d0cm
4257       deltat1=1.0d0-om1
4258       deltat2=1.0d0+om2
4259       deltat12=om2-om1+2.0d0
4260       cosphi=om12-om1*om2
4261       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4262      &  +akct*deltad*deltat12
4263      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4264 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4265 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4266 c     &  " deltat12",deltat12," eij",eij
4267       ed=2*akcm*deltad+akct*deltat12
4268       pom1=akct*deltad
4269       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4270       eom1=-2*akth*deltat1-pom1-om2*pom2
4271       eom2= 2*akth*deltat2+pom1-om1*pom2
4272       eom12=pom2
4273       do k=1,3
4274         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4275         ghpbx(k,i)=ghpbx(k,i)-ggk
4276      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4277      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4278         ghpbx(k,j)=ghpbx(k,j)+ggk
4279      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4280      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4281         ghpbc(k,i)=ghpbc(k,i)-ggk
4282         ghpbc(k,j)=ghpbc(k,j)+ggk
4283       enddo
4284 C
4285 C Calculate the components of the gradient in DC and X
4286 C
4287 cgrad      do k=i,j-1
4288 cgrad        do l=1,3
4289 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4290 cgrad        enddo
4291 cgrad      enddo
4292       return
4293       end
4294 C--------------------------------------------------------------------------
4295       subroutine ebond(estr)
4296 c
4297 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4298 c
4299       implicit real*8 (a-h,o-z)
4300       include 'DIMENSIONS'
4301       include 'COMMON.LOCAL'
4302       include 'COMMON.GEO'
4303       include 'COMMON.INTERACT'
4304       include 'COMMON.DERIV'
4305       include 'COMMON.VAR'
4306       include 'COMMON.CHAIN'
4307       include 'COMMON.IOUNITS'
4308       include 'COMMON.NAMES'
4309       include 'COMMON.FFIELD'
4310       include 'COMMON.CONTROL'
4311       include 'COMMON.SETUP'
4312       double precision u(3),ud(3)
4313       estr=0.0d0
4314       do i=ibondp_start,ibondp_end
4315         diff = vbld(i)-vbldp0
4316 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4317         estr=estr+diff*diff
4318         do j=1,3
4319           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4320         enddo
4321 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4322       enddo
4323       estr=0.5d0*AKP*estr
4324 c
4325 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4326 c
4327       do i=ibond_start,ibond_end
4328         iti=itype(i)
4329         if (iti.ne.10) then
4330           nbi=nbondterm(iti)
4331           if (nbi.eq.1) then
4332             diff=vbld(i+nres)-vbldsc0(1,iti)
4333 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4334 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4335             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4336             do j=1,3
4337               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4338             enddo
4339           else
4340             do j=1,nbi
4341               diff=vbld(i+nres)-vbldsc0(j,iti)
4342               ud(j)=aksc(j,iti)*diff
4343               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4344             enddo
4345             uprod=u(1)
4346             do j=2,nbi
4347               uprod=uprod*u(j)
4348             enddo
4349             usum=0.0d0
4350             usumsqder=0.0d0
4351             do j=1,nbi
4352               uprod1=1.0d0
4353               uprod2=1.0d0
4354               do k=1,nbi
4355                 if (k.ne.j) then
4356                   uprod1=uprod1*u(k)
4357                   uprod2=uprod2*u(k)*u(k)
4358                 endif
4359               enddo
4360               usum=usum+uprod1
4361               usumsqder=usumsqder+ud(j)*uprod2
4362             enddo
4363             estr=estr+uprod/usum
4364             do j=1,3
4365              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4366             enddo
4367           endif
4368         endif
4369       enddo
4370       return
4371       end
4372 #ifdef CRYST_THETA
4373 C--------------------------------------------------------------------------
4374       subroutine ebend(etheta)
4375 C
4376 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4377 C angles gamma and its derivatives in consecutive thetas and gammas.
4378 C
4379       implicit real*8 (a-h,o-z)
4380       include 'DIMENSIONS'
4381       include 'COMMON.LOCAL'
4382       include 'COMMON.GEO'
4383       include 'COMMON.INTERACT'
4384       include 'COMMON.DERIV'
4385       include 'COMMON.VAR'
4386       include 'COMMON.CHAIN'
4387       include 'COMMON.IOUNITS'
4388       include 'COMMON.NAMES'
4389       include 'COMMON.FFIELD'
4390       include 'COMMON.CONTROL'
4391       common /calcthet/ term1,term2,termm,diffak,ratak,
4392      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4393      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4394       double precision y(2),z(2)
4395       delta=0.02d0*pi
4396 c      time11=dexp(-2*time)
4397 c      time12=1.0d0
4398       etheta=0.0D0
4399 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4400       do i=ithet_start,ithet_end
4401 C Zero the energy function and its derivative at 0 or pi.
4402         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4403         it=itype(i-1)
4404         if (i.gt.3) then
4405 #ifdef OSF
4406           phii=phi(i)
4407           if (phii.ne.phii) phii=150.0
4408 #else
4409           phii=phi(i)
4410 #endif
4411           y(1)=dcos(phii)
4412           y(2)=dsin(phii)
4413         else
4414           y(1)=0.0D0
4415           y(2)=0.0D0
4416         endif
4417         if (i.lt.nres) then
4418 #ifdef OSF
4419           phii1=phi(i+1)
4420           if (phii1.ne.phii1) phii1=150.0
4421           phii1=pinorm(phii1)
4422           z(1)=cos(phii1)
4423 #else
4424           phii1=phi(i+1)
4425           z(1)=dcos(phii1)
4426 #endif
4427           z(2)=dsin(phii1)
4428         else
4429           z(1)=0.0D0
4430           z(2)=0.0D0
4431         endif
4432 C Calculate the "mean" value of theta from the part of the distribution
4433 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4434 C In following comments this theta will be referred to as t_c.
4435         thet_pred_mean=0.0d0
4436         do k=1,2
4437           athetk=athet(k,it)
4438           bthetk=bthet(k,it)
4439           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4440         enddo
4441         dthett=thet_pred_mean*ssd
4442         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4443 C Derivatives of the "mean" values in gamma1 and gamma2.
4444         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
4445         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
4446         if (theta(i).gt.pi-delta) then
4447           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4448      &         E_tc0)
4449           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4450           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4451           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4452      &        E_theta)
4453           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4454      &        E_tc)
4455         else if (theta(i).lt.delta) then
4456           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4457           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4458           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4459      &        E_theta)
4460           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4461           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4462      &        E_tc)
4463         else
4464           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4465      &        E_theta,E_tc)
4466         endif
4467         etheta=etheta+ethetai
4468         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4469      &      'ebend',i,ethetai
4470         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4471         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4472         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4473       enddo
4474 C Ufff.... We've done all this!!!
4475       return
4476       end
4477 C---------------------------------------------------------------------------
4478       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4479      &     E_tc)
4480       implicit real*8 (a-h,o-z)
4481       include 'DIMENSIONS'
4482       include 'COMMON.LOCAL'
4483       include 'COMMON.IOUNITS'
4484       common /calcthet/ term1,term2,termm,diffak,ratak,
4485      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4486      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4487 C Calculate the contributions to both Gaussian lobes.
4488 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4489 C The "polynomial part" of the "standard deviation" of this part of
4490 C the distribution.
4491         sig=polthet(3,it)
4492         do j=2,0,-1
4493           sig=sig*thet_pred_mean+polthet(j,it)
4494         enddo
4495 C Derivative of the "interior part" of the "standard deviation of the"
4496 C gamma-dependent Gaussian lobe in t_c.
4497         sigtc=3*polthet(3,it)
4498         do j=2,1,-1
4499           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4500         enddo
4501         sigtc=sig*sigtc
4502 C Set the parameters of both Gaussian lobes of the distribution.
4503 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4504         fac=sig*sig+sigc0(it)
4505         sigcsq=fac+fac
4506         sigc=1.0D0/sigcsq
4507 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4508         sigsqtc=-4.0D0*sigcsq*sigtc
4509 c       print *,i,sig,sigtc,sigsqtc
4510 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4511         sigtc=-sigtc/(fac*fac)
4512 C Following variable is sigma(t_c)**(-2)
4513         sigcsq=sigcsq*sigcsq
4514         sig0i=sig0(it)
4515         sig0inv=1.0D0/sig0i**2
4516         delthec=thetai-thet_pred_mean
4517         delthe0=thetai-theta0i
4518         term1=-0.5D0*sigcsq*delthec*delthec
4519         term2=-0.5D0*sig0inv*delthe0*delthe0
4520 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4521 C NaNs in taking the logarithm. We extract the largest exponent which is added
4522 C to the energy (this being the log of the distribution) at the end of energy
4523 C term evaluation for this virtual-bond angle.
4524         if (term1.gt.term2) then
4525           termm=term1
4526           term2=dexp(term2-termm)
4527           term1=1.0d0
4528         else
4529           termm=term2
4530           term1=dexp(term1-termm)
4531           term2=1.0d0
4532         endif
4533 C The ratio between the gamma-independent and gamma-dependent lobes of
4534 C the distribution is a Gaussian function of thet_pred_mean too.
4535         diffak=gthet(2,it)-thet_pred_mean
4536         ratak=diffak/gthet(3,it)**2
4537         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4538 C Let's differentiate it in thet_pred_mean NOW.
4539         aktc=ak*ratak
4540 C Now put together the distribution terms to make complete distribution.
4541         termexp=term1+ak*term2
4542         termpre=sigc+ak*sig0i
4543 C Contribution of the bending energy from this theta is just the -log of
4544 C the sum of the contributions from the two lobes and the pre-exponential
4545 C factor. Simple enough, isn't it?
4546         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4547 C NOW the derivatives!!!
4548 C 6/6/97 Take into account the deformation.
4549         E_theta=(delthec*sigcsq*term1
4550      &       +ak*delthe0*sig0inv*term2)/termexp
4551         E_tc=((sigtc+aktc*sig0i)/termpre
4552      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4553      &       aktc*term2)/termexp)
4554       return
4555       end
4556 c-----------------------------------------------------------------------------
4557       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4558       implicit real*8 (a-h,o-z)
4559       include 'DIMENSIONS'
4560       include 'COMMON.LOCAL'
4561       include 'COMMON.IOUNITS'
4562       common /calcthet/ term1,term2,termm,diffak,ratak,
4563      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4564      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4565       delthec=thetai-thet_pred_mean
4566       delthe0=thetai-theta0i
4567 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4568       t3 = thetai-thet_pred_mean
4569       t6 = t3**2
4570       t9 = term1
4571       t12 = t3*sigcsq
4572       t14 = t12+t6*sigsqtc
4573       t16 = 1.0d0
4574       t21 = thetai-theta0i
4575       t23 = t21**2
4576       t26 = term2
4577       t27 = t21*t26
4578       t32 = termexp
4579       t40 = t32**2
4580       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4581      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4582      & *(-t12*t9-ak*sig0inv*t27)
4583       return
4584       end
4585 #else
4586 C--------------------------------------------------------------------------
4587       subroutine ebend(etheta)
4588 C
4589 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4590 C angles gamma and its derivatives in consecutive thetas and gammas.
4591 C ab initio-derived potentials from
4592 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4593 C
4594       implicit real*8 (a-h,o-z)
4595       include 'DIMENSIONS'
4596       include 'COMMON.LOCAL'
4597       include 'COMMON.GEO'
4598       include 'COMMON.INTERACT'
4599       include 'COMMON.DERIV'
4600       include 'COMMON.VAR'
4601       include 'COMMON.CHAIN'
4602       include 'COMMON.IOUNITS'
4603       include 'COMMON.NAMES'
4604       include 'COMMON.FFIELD'
4605       include 'COMMON.CONTROL'
4606       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4607      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4608      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4609      & sinph1ph2(maxdouble,maxdouble)
4610       logical lprn /.false./, lprn1 /.false./
4611       etheta=0.0D0
4612       do i=ithet_start,ithet_end
4613         dethetai=0.0d0
4614         dephii=0.0d0
4615         dephii1=0.0d0
4616         theti2=0.5d0*theta(i)
4617         ityp2=ithetyp(itype(i-1))
4618         do k=1,nntheterm
4619           coskt(k)=dcos(k*theti2)
4620           sinkt(k)=dsin(k*theti2)
4621         enddo
4622         if (i.gt.3) then
4623 #ifdef OSF
4624           phii=phi(i)
4625           if (phii.ne.phii) phii=150.0
4626 #else
4627           phii=phi(i)
4628 #endif
4629           ityp1=ithetyp(itype(i-2))
4630           do k=1,nsingle
4631             cosph1(k)=dcos(k*phii)
4632             sinph1(k)=dsin(k*phii)
4633           enddo
4634         else
4635           phii=0.0d0
4636           ityp1=nthetyp+1
4637           do k=1,nsingle
4638             cosph1(k)=0.0d0
4639             sinph1(k)=0.0d0
4640           enddo
4641         endif
4642         if (i.lt.nres) then
4643 #ifdef OSF
4644           phii1=phi(i+1)
4645           if (phii1.ne.phii1) phii1=150.0
4646           phii1=pinorm(phii1)
4647 #else
4648           phii1=phi(i+1)
4649 #endif
4650           ityp3=ithetyp(itype(i))
4651           do k=1,nsingle
4652             cosph2(k)=dcos(k*phii1)
4653             sinph2(k)=dsin(k*phii1)
4654           enddo
4655         else
4656           phii1=0.0d0
4657           ityp3=nthetyp+1
4658           do k=1,nsingle
4659             cosph2(k)=0.0d0
4660             sinph2(k)=0.0d0
4661           enddo
4662         endif
4663         ethetai=aa0thet(ityp1,ityp2,ityp3)
4664         do k=1,ndouble
4665           do l=1,k-1
4666             ccl=cosph1(l)*cosph2(k-l)
4667             ssl=sinph1(l)*sinph2(k-l)
4668             scl=sinph1(l)*cosph2(k-l)
4669             csl=cosph1(l)*sinph2(k-l)
4670             cosph1ph2(l,k)=ccl-ssl
4671             cosph1ph2(k,l)=ccl+ssl
4672             sinph1ph2(l,k)=scl+csl
4673             sinph1ph2(k,l)=scl-csl
4674           enddo
4675         enddo
4676         if (lprn) then
4677         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4678      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4679         write (iout,*) "coskt and sinkt"
4680         do k=1,nntheterm
4681           write (iout,*) k,coskt(k),sinkt(k)
4682         enddo
4683         endif
4684         do k=1,ntheterm
4685           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4686           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4687      &      *coskt(k)
4688           if (lprn)
4689      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4690      &     " ethetai",ethetai
4691         enddo
4692         if (lprn) then
4693         write (iout,*) "cosph and sinph"
4694         do k=1,nsingle
4695           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4696         enddo
4697         write (iout,*) "cosph1ph2 and sinph2ph2"
4698         do k=2,ndouble
4699           do l=1,k-1
4700             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4701      &         sinph1ph2(l,k),sinph1ph2(k,l)
4702           enddo
4703         enddo
4704         write(iout,*) "ethetai",ethetai
4705         endif
4706         do m=1,ntheterm2
4707           do k=1,nsingle
4708             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4709      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4710      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4711      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4712             ethetai=ethetai+sinkt(m)*aux
4713             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4714             dephii=dephii+k*sinkt(m)*(
4715      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4716      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4717             dephii1=dephii1+k*sinkt(m)*(
4718      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4719      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4720             if (lprn)
4721      &      write (iout,*) "m",m," k",k," bbthet",
4722      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4723      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4724      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4725      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4726           enddo
4727         enddo
4728         if (lprn)
4729      &  write(iout,*) "ethetai",ethetai
4730         do m=1,ntheterm3
4731           do k=2,ndouble
4732             do l=1,k-1
4733               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4734      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4735      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4736      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4737               ethetai=ethetai+sinkt(m)*aux
4738               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4739               dephii=dephii+l*sinkt(m)*(
4740      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4741      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4742      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4743      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4744               dephii1=dephii1+(k-l)*sinkt(m)*(
4745      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4746      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4747      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
4748      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4749               if (lprn) then
4750               write (iout,*) "m",m," k",k," l",l," ffthet",
4751      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
4752      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
4753      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
4754      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4755               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4756      &            cosph1ph2(k,l)*sinkt(m),
4757      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4758               endif
4759             enddo
4760           enddo
4761         enddo
4762 10      continue
4763         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4764      &   i,theta(i)*rad2deg,phii*rad2deg,
4765      &   phii1*rad2deg,ethetai
4766         etheta=etheta+ethetai
4767         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4768         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4769         gloc(nphi+i-2,icg)=wang*dethetai
4770       enddo
4771       return
4772       end
4773 #endif
4774 #ifdef CRYST_SC
4775 c-----------------------------------------------------------------------------
4776       subroutine esc(escloc)
4777 C Calculate the local energy of a side chain and its derivatives in the
4778 C corresponding virtual-bond valence angles THETA and the spherical angles
4779 C ALPHA and OMEGA.
4780       implicit real*8 (a-h,o-z)
4781       include 'DIMENSIONS'
4782       include 'COMMON.GEO'
4783       include 'COMMON.LOCAL'
4784       include 'COMMON.VAR'
4785       include 'COMMON.INTERACT'
4786       include 'COMMON.DERIV'
4787       include 'COMMON.CHAIN'
4788       include 'COMMON.IOUNITS'
4789       include 'COMMON.NAMES'
4790       include 'COMMON.FFIELD'
4791       include 'COMMON.CONTROL'
4792       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4793      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4794       common /sccalc/ time11,time12,time112,theti,it,nlobit
4795       delta=0.02d0*pi
4796       escloc=0.0D0
4797 c     write (iout,'(a)') 'ESC'
4798       do i=loc_start,loc_end
4799         it=itype(i)
4800         if (it.eq.10) goto 1
4801         nlobit=nlob(it)
4802 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4803 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4804         theti=theta(i+1)-pipol
4805         x(1)=dtan(theti)
4806         x(2)=alph(i)
4807         x(3)=omeg(i)
4808
4809         if (x(2).gt.pi-delta) then
4810           xtemp(1)=x(1)
4811           xtemp(2)=pi-delta
4812           xtemp(3)=x(3)
4813           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4814           xtemp(2)=pi
4815           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4816           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4817      &        escloci,dersc(2))
4818           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4819      &        ddersc0(1),dersc(1))
4820           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4821      &        ddersc0(3),dersc(3))
4822           xtemp(2)=pi-delta
4823           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4824           xtemp(2)=pi
4825           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4826           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4827      &            dersc0(2),esclocbi,dersc02)
4828           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4829      &            dersc12,dersc01)
4830           call splinthet(x(2),0.5d0*delta,ss,ssd)
4831           dersc0(1)=dersc01
4832           dersc0(2)=dersc02
4833           dersc0(3)=0.0d0
4834           do k=1,3
4835             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4836           enddo
4837           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4838 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4839 c    &             esclocbi,ss,ssd
4840           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4841 c         escloci=esclocbi
4842 c         write (iout,*) escloci
4843         else if (x(2).lt.delta) then
4844           xtemp(1)=x(1)
4845           xtemp(2)=delta
4846           xtemp(3)=x(3)
4847           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4848           xtemp(2)=0.0d0
4849           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4850           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4851      &        escloci,dersc(2))
4852           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4853      &        ddersc0(1),dersc(1))
4854           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4855      &        ddersc0(3),dersc(3))
4856           xtemp(2)=delta
4857           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4858           xtemp(2)=0.0d0
4859           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4860           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4861      &            dersc0(2),esclocbi,dersc02)
4862           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4863      &            dersc12,dersc01)
4864           dersc0(1)=dersc01
4865           dersc0(2)=dersc02
4866           dersc0(3)=0.0d0
4867           call splinthet(x(2),0.5d0*delta,ss,ssd)
4868           do k=1,3
4869             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4870           enddo
4871           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4872 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4873 c    &             esclocbi,ss,ssd
4874           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4875 c         write (iout,*) escloci
4876         else
4877           call enesc(x,escloci,dersc,ddummy,.false.)
4878         endif
4879
4880         escloc=escloc+escloci
4881         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4882      &     'escloc',i,escloci
4883 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4884
4885         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4886      &   wscloc*dersc(1)
4887         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4888         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4889     1   continue
4890       enddo
4891       return
4892       end
4893 C---------------------------------------------------------------------------
4894       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4895       implicit real*8 (a-h,o-z)
4896       include 'DIMENSIONS'
4897       include 'COMMON.GEO'
4898       include 'COMMON.LOCAL'
4899       include 'COMMON.IOUNITS'
4900       common /sccalc/ time11,time12,time112,theti,it,nlobit
4901       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4902       double precision contr(maxlob,-1:1)
4903       logical mixed
4904 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4905         escloc_i=0.0D0
4906         do j=1,3
4907           dersc(j)=0.0D0
4908           if (mixed) ddersc(j)=0.0d0
4909         enddo
4910         x3=x(3)
4911
4912 C Because of periodicity of the dependence of the SC energy in omega we have
4913 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4914 C To avoid underflows, first compute & store the exponents.
4915
4916         do iii=-1,1
4917
4918           x(3)=x3+iii*dwapi
4919
4920           do j=1,nlobit
4921             do k=1,3
4922               z(k)=x(k)-censc(k,j,it)
4923             enddo
4924             do k=1,3
4925               Axk=0.0D0
4926               do l=1,3
4927                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4928               enddo
4929               Ax(k,j,iii)=Axk
4930             enddo
4931             expfac=0.0D0
4932             do k=1,3
4933               expfac=expfac+Ax(k,j,iii)*z(k)
4934             enddo
4935             contr(j,iii)=expfac
4936           enddo ! j
4937
4938         enddo ! iii
4939
4940         x(3)=x3
4941 C As in the case of ebend, we want to avoid underflows in exponentiation and
4942 C subsequent NaNs and INFs in energy calculation.
4943 C Find the largest exponent
4944         emin=contr(1,-1)
4945         do iii=-1,1
4946           do j=1,nlobit
4947             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4948           enddo
4949         enddo
4950         emin=0.5D0*emin
4951 cd      print *,'it=',it,' emin=',emin
4952
4953 C Compute the contribution to SC energy and derivatives
4954         do iii=-1,1
4955
4956           do j=1,nlobit
4957 #ifdef OSF
4958             adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin
4959             if(adexp.ne.adexp) adexp=1.0
4960             expfac=dexp(adexp)
4961 #else
4962             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
4963 #endif
4964 cd          print *,'j=',j,' expfac=',expfac
4965             escloc_i=escloc_i+expfac
4966             do k=1,3
4967               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4968             enddo
4969             if (mixed) then
4970               do k=1,3,2
4971                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4972      &            +gaussc(k,2,j,it))*expfac
4973               enddo
4974             endif
4975           enddo
4976
4977         enddo ! iii
4978
4979         dersc(1)=dersc(1)/cos(theti)**2
4980         ddersc(1)=ddersc(1)/cos(theti)**2
4981         ddersc(3)=ddersc(3)
4982
4983         escloci=-(dlog(escloc_i)-emin)
4984         do j=1,3
4985           dersc(j)=dersc(j)/escloc_i
4986         enddo
4987         if (mixed) then
4988           do j=1,3,2
4989             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4990           enddo
4991         endif
4992       return
4993       end
4994 C------------------------------------------------------------------------------
4995       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4996       implicit real*8 (a-h,o-z)
4997       include 'DIMENSIONS'
4998       include 'COMMON.GEO'
4999       include 'COMMON.LOCAL'
5000       include 'COMMON.IOUNITS'
5001       common /sccalc/ time11,time12,time112,theti,it,nlobit
5002       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5003       double precision contr(maxlob)
5004       logical mixed
5005
5006       escloc_i=0.0D0
5007
5008       do j=1,3
5009         dersc(j)=0.0D0
5010       enddo
5011
5012       do j=1,nlobit
5013         do k=1,2
5014           z(k)=x(k)-censc(k,j,it)
5015         enddo
5016         z(3)=dwapi
5017         do k=1,3
5018           Axk=0.0D0
5019           do l=1,3
5020             Axk=Axk+gaussc(l,k,j,it)*z(l)
5021           enddo
5022           Ax(k,j)=Axk
5023         enddo
5024         expfac=0.0D0
5025         do k=1,3
5026           expfac=expfac+Ax(k,j)*z(k)
5027         enddo
5028         contr(j)=expfac
5029       enddo ! j
5030
5031 C As in the case of ebend, we want to avoid underflows in exponentiation and
5032 C subsequent NaNs and INFs in energy calculation.
5033 C Find the largest exponent
5034       emin=contr(1)
5035       do j=1,nlobit
5036         if (emin.gt.contr(j)) emin=contr(j)
5037       enddo
5038       emin=0.5D0*emin
5039
5040 C Compute the contribution to SC energy and derivatives
5041
5042       dersc12=0.0d0
5043       do j=1,nlobit
5044         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
5045         escloc_i=escloc_i+expfac
5046         do k=1,2
5047           dersc(k)=dersc(k)+Ax(k,j)*expfac
5048         enddo
5049         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5050      &            +gaussc(1,2,j,it))*expfac
5051         dersc(3)=0.0d0
5052       enddo
5053
5054       dersc(1)=dersc(1)/cos(theti)**2
5055       dersc12=dersc12/cos(theti)**2
5056       escloci=-(dlog(escloc_i)-emin)
5057       do j=1,2
5058         dersc(j)=dersc(j)/escloc_i
5059       enddo
5060       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5061       return
5062       end
5063 #else
5064 c----------------------------------------------------------------------------------
5065       subroutine esc(escloc)
5066 C Calculate the local energy of a side chain and its derivatives in the
5067 C corresponding virtual-bond valence angles THETA and the spherical angles
5068 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5069 C added by Urszula Kozlowska. 07/11/2007
5070 C
5071       implicit real*8 (a-h,o-z)
5072       include 'DIMENSIONS'
5073       include 'COMMON.GEO'
5074       include 'COMMON.LOCAL'
5075       include 'COMMON.VAR'
5076       include 'COMMON.SCROT'
5077       include 'COMMON.INTERACT'
5078       include 'COMMON.DERIV'
5079       include 'COMMON.CHAIN'
5080       include 'COMMON.IOUNITS'
5081       include 'COMMON.NAMES'
5082       include 'COMMON.FFIELD'
5083       include 'COMMON.CONTROL'
5084       include 'COMMON.VECTORS'
5085       double precision x_prime(3),y_prime(3),z_prime(3)
5086      &    , sumene,dsc_i,dp2_i,x(65),
5087      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5088      &    de_dxx,de_dyy,de_dzz,de_dt
5089       double precision s1_t,s1_6_t,s2_t,s2_6_t
5090       double precision
5091      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5092      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5093      & dt_dCi(3),dt_dCi1(3)
5094       common /sccalc/ time11,time12,time112,theti,it,nlobit
5095       delta=0.02d0*pi
5096       escloc=0.0D0
5097       do i=loc_start,loc_end
5098         costtab(i+1) =dcos(theta(i+1))
5099         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5100         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5101         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5102         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5103         cosfac=dsqrt(cosfac2)
5104         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5105         sinfac=dsqrt(sinfac2)
5106         it=itype(i)
5107         if (it.eq.10) goto 1
5108 c
5109 C  Compute the axes of tghe local cartesian coordinates system; store in
5110 c   x_prime, y_prime and z_prime
5111 c
5112         do j=1,3
5113           x_prime(j) = 0.00
5114           y_prime(j) = 0.00
5115           z_prime(j) = 0.00
5116         enddo
5117 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5118 C     &   dc_norm(3,i+nres)
5119         do j = 1,3
5120           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5121           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5122         enddo
5123         do j = 1,3
5124           z_prime(j) = -uz(j,i-1)
5125         enddo
5126 c       write (2,*) "i",i
5127 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5128 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5129 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5130 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5131 c      & " xy",scalar(x_prime(1),y_prime(1)),
5132 c      & " xz",scalar(x_prime(1),z_prime(1)),
5133 c      & " yy",scalar(y_prime(1),y_prime(1)),
5134 c      & " yz",scalar(y_prime(1),z_prime(1)),
5135 c      & " zz",scalar(z_prime(1),z_prime(1))
5136 c
5137 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5138 C to local coordinate system. Store in xx, yy, zz.
5139 c
5140         xx=0.0d0
5141         yy=0.0d0
5142         zz=0.0d0
5143         do j = 1,3
5144           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5145           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5146           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5147         enddo
5148
5149         xxtab(i)=xx
5150         yytab(i)=yy
5151         zztab(i)=zz
5152 C
5153 C Compute the energy of the ith side cbain
5154 C
5155 c        write (2,*) "xx",xx," yy",yy," zz",zz
5156         it=itype(i)
5157         do j = 1,65
5158           x(j) = sc_parmin(j,it)
5159         enddo
5160 #ifdef CHECK_COORD
5161 Cc diagnostics - remove later
5162         xx1 = dcos(alph(2))
5163         yy1 = dsin(alph(2))*dcos(omeg(2))
5164         zz1 = -dsin(alph(2))*dsin(omeg(2))
5165         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5166      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5167      &    xx1,yy1,zz1
5168 C,"  --- ", xx_w,yy_w,zz_w
5169 c end diagnostics
5170 #endif
5171         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5172      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5173      &   + x(10)*yy*zz
5174         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5175      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5176      & + x(20)*yy*zz
5177         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5178      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5179      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5180      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5181      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5182      &  +x(40)*xx*yy*zz
5183         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5184      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5185      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5186      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5187      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5188      &  +x(60)*xx*yy*zz
5189         dsc_i   = 0.743d0+x(61)
5190         dp2_i   = 1.9d0+x(62)
5191         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5192      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5193         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5194      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5195         s1=(1+x(63))/(0.1d0 + dscp1)
5196         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5197         s2=(1+x(65))/(0.1d0 + dscp2)
5198         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5199         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5200      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5201 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5202 c     &   sumene4,
5203 c     &   dscp1,dscp2,sumene
5204 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5205         escloc = escloc + sumene
5206 c        write (2,*) "i",i," escloc",sumene,escloc
5207 #ifdef DEBUG
5208 C
5209 C This section to check the numerical derivatives of the energy of ith side
5210 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5211 C #define DEBUG in the code to turn it on.
5212 C
5213         write (2,*) "sumene               =",sumene
5214         aincr=1.0d-7
5215         xxsave=xx
5216         xx=xx+aincr
5217         write (2,*) xx,yy,zz
5218         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5219         de_dxx_num=(sumenep-sumene)/aincr
5220         xx=xxsave
5221         write (2,*) "xx+ sumene from enesc=",sumenep
5222         yysave=yy
5223         yy=yy+aincr
5224         write (2,*) xx,yy,zz
5225         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5226         de_dyy_num=(sumenep-sumene)/aincr
5227         yy=yysave
5228         write (2,*) "yy+ sumene from enesc=",sumenep
5229         zzsave=zz
5230         zz=zz+aincr
5231         write (2,*) xx,yy,zz
5232         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5233         de_dzz_num=(sumenep-sumene)/aincr
5234         zz=zzsave
5235         write (2,*) "zz+ sumene from enesc=",sumenep
5236         costsave=cost2tab(i+1)
5237         sintsave=sint2tab(i+1)
5238         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5239         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5240         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5241         de_dt_num=(sumenep-sumene)/aincr
5242         write (2,*) " t+ sumene from enesc=",sumenep
5243         cost2tab(i+1)=costsave
5244         sint2tab(i+1)=sintsave
5245 C End of diagnostics section.
5246 #endif
5247 C
5248 C Compute the gradient of esc
5249 C
5250         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5251         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5252         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5253         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5254         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5255         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5256         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5257         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5258         pom1=(sumene3*sint2tab(i+1)+sumene1)
5259      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5260         pom2=(sumene4*cost2tab(i+1)+sumene2)
5261      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5262         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5263         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5264      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5265      &  +x(40)*yy*zz
5266         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5267         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5268      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5269      &  +x(60)*yy*zz
5270         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5271      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5272      &        +(pom1+pom2)*pom_dx
5273 #ifdef DEBUG
5274         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5275 #endif
5276 C
5277         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5278         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5279      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5280      &  +x(40)*xx*zz
5281         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5282         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5283      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5284      &  +x(59)*zz**2 +x(60)*xx*zz
5285         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5286      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5287      &        +(pom1-pom2)*pom_dy
5288 #ifdef DEBUG
5289         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5290 #endif
5291 C
5292         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5293      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5294      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5295      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5296      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5297      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5298      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5299      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5300 #ifdef DEBUG
5301         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5302 #endif
5303 C
5304         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5305      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5306      &  +pom1*pom_dt1+pom2*pom_dt2
5307 #ifdef DEBUG
5308         write(2,*), "de_dt = ", de_dt,de_dt_num
5309 #endif
5310 c
5311 C
5312        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5313        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5314        cosfac2xx=cosfac2*xx
5315        sinfac2yy=sinfac2*yy
5316        do k = 1,3
5317          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5318      &      vbld_inv(i+1)
5319          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5320      &      vbld_inv(i)
5321          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5322          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5323 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5324 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5325 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5326 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5327          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5328          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5329          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5330          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5331          dZZ_Ci1(k)=0.0d0
5332          dZZ_Ci(k)=0.0d0
5333          do j=1,3
5334            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5335            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5336          enddo
5337
5338          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5339          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5340          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5341 c
5342          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5343          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5344        enddo
5345
5346        do k=1,3
5347          dXX_Ctab(k,i)=dXX_Ci(k)
5348          dXX_C1tab(k,i)=dXX_Ci1(k)
5349          dYY_Ctab(k,i)=dYY_Ci(k)
5350          dYY_C1tab(k,i)=dYY_Ci1(k)
5351          dZZ_Ctab(k,i)=dZZ_Ci(k)
5352          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5353          dXX_XYZtab(k,i)=dXX_XYZ(k)
5354          dYY_XYZtab(k,i)=dYY_XYZ(k)
5355          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5356        enddo
5357
5358        do k = 1,3
5359 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5360 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5361 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5362 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5363 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5364 c     &    dt_dci(k)
5365 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5366 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5367          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5368      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5369          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5370      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5371          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5372      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5373        enddo
5374 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5375 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5376
5377 C to check gradient call subroutine check_grad
5378
5379     1 continue
5380       enddo
5381       return
5382       end
5383 c------------------------------------------------------------------------------
5384       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5385       implicit none
5386       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5387      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5388       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5389      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5390      &   + x(10)*yy*zz
5391       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5392      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5393      & + x(20)*yy*zz
5394       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5395      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5396      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5397      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5398      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5399      &  +x(40)*xx*yy*zz
5400       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5401      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5402      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5403      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5404      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5405      &  +x(60)*xx*yy*zz
5406       dsc_i   = 0.743d0+x(61)
5407       dp2_i   = 1.9d0+x(62)
5408       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5409      &          *(xx*cost2+yy*sint2))
5410       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5411      &          *(xx*cost2-yy*sint2))
5412       s1=(1+x(63))/(0.1d0 + dscp1)
5413       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5414       s2=(1+x(65))/(0.1d0 + dscp2)
5415       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5416       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5417      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5418       enesc=sumene
5419       return
5420       end
5421 #endif
5422 c------------------------------------------------------------------------------
5423       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5424 C
5425 C This procedure calculates two-body contact function g(rij) and its derivative:
5426 C
5427 C           eps0ij                                     !       x < -1
5428 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5429 C            0                                         !       x > 1
5430 C
5431 C where x=(rij-r0ij)/delta
5432 C
5433 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5434 C
5435       implicit none
5436       double precision rij,r0ij,eps0ij,fcont,fprimcont
5437       double precision x,x2,x4,delta
5438 c     delta=0.02D0*r0ij
5439 c      delta=0.2D0*r0ij
5440       x=(rij-r0ij)/delta
5441       if (x.lt.-1.0D0) then
5442         fcont=eps0ij
5443         fprimcont=0.0D0
5444       else if (x.le.1.0D0) then
5445         x2=x*x
5446         x4=x2*x2
5447         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5448         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5449       else
5450         fcont=0.0D0
5451         fprimcont=0.0D0
5452       endif
5453       return
5454       end
5455 c------------------------------------------------------------------------------
5456       subroutine splinthet(theti,delta,ss,ssder)
5457       implicit real*8 (a-h,o-z)
5458       include 'DIMENSIONS'
5459       include 'COMMON.VAR'
5460       include 'COMMON.GEO'
5461       thetup=pi-delta
5462       thetlow=delta
5463       if (theti.gt.pipol) then
5464         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5465       else
5466         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5467         ssder=-ssder
5468       endif
5469       return
5470       end
5471 c------------------------------------------------------------------------------
5472       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5473       implicit none
5474       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5475       double precision ksi,ksi2,ksi3,a1,a2,a3
5476       a1=fprim0*delta/(f1-f0)
5477       a2=3.0d0-2.0d0*a1
5478       a3=a1-2.0d0
5479       ksi=(x-x0)/delta
5480       ksi2=ksi*ksi
5481       ksi3=ksi2*ksi
5482       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5483       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5484       return
5485       end
5486 c------------------------------------------------------------------------------
5487       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5488       implicit none
5489       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5490       double precision ksi,ksi2,ksi3,a1,a2,a3
5491       ksi=(x-x0)/delta
5492       ksi2=ksi*ksi
5493       ksi3=ksi2*ksi
5494       a1=fprim0x*delta
5495       a2=3*(f1x-f0x)-2*fprim0x*delta
5496       a3=fprim0x*delta-2*(f1x-f0x)
5497       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5498       return
5499       end
5500 C-----------------------------------------------------------------------------
5501 #ifdef CRYST_TOR
5502 C-----------------------------------------------------------------------------
5503       subroutine etor(etors,edihcnstr)
5504       implicit real*8 (a-h,o-z)
5505       include 'DIMENSIONS'
5506       include 'COMMON.VAR'
5507       include 'COMMON.GEO'
5508       include 'COMMON.LOCAL'
5509       include 'COMMON.TORSION'
5510       include 'COMMON.INTERACT'
5511       include 'COMMON.DERIV'
5512       include 'COMMON.CHAIN'
5513       include 'COMMON.NAMES'
5514       include 'COMMON.IOUNITS'
5515       include 'COMMON.FFIELD'
5516       include 'COMMON.TORCNSTR'
5517       include 'COMMON.CONTROL'
5518       logical lprn
5519 C Set lprn=.true. for debugging
5520       lprn=.false.
5521 c      lprn=.true.
5522       etors=0.0D0
5523       do i=iphi_start,iphi_end
5524       etors_ii=0.0D0
5525         itori=itortyp(itype(i-2))
5526         itori1=itortyp(itype(i-1))
5527         phii=phi(i)
5528         gloci=0.0D0
5529 C Proline-Proline pair is a special case...
5530         if (itori.eq.3 .and. itori1.eq.3) then
5531           if (phii.gt.-dwapi3) then
5532             cosphi=dcos(3*phii)
5533             fac=1.0D0/(1.0D0-cosphi)
5534             etorsi=v1(1,3,3)*fac
5535             etorsi=etorsi+etorsi
5536             etors=etors+etorsi-v1(1,3,3)
5537             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5538             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5539           endif
5540           do j=1,3
5541             v1ij=v1(j+1,itori,itori1)
5542             v2ij=v2(j+1,itori,itori1)
5543             cosphi=dcos(j*phii)
5544             sinphi=dsin(j*phii)
5545             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5546             if (energy_dec) etors_ii=etors_ii+
5547      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5548             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5549           enddo
5550         else
5551           do j=1,nterm_old
5552             v1ij=v1(j,itori,itori1)
5553             v2ij=v2(j,itori,itori1)
5554             cosphi=dcos(j*phii)
5555             sinphi=dsin(j*phii)
5556             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5557             if (energy_dec) etors_ii=etors_ii+
5558      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5559             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5560           enddo
5561         endif
5562         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5563      &        'etor',i,etors_ii
5564         if (lprn)
5565      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5566      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5567      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5568         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5569 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5570       enddo
5571 ! 6/20/98 - dihedral angle constraints
5572       edihcnstr=0.0d0
5573       do i=1,ndih_constr
5574         itori=idih_constr(i)
5575         phii=phi(itori)
5576         difi=phii-phi0(i)
5577         if (difi.gt.drange(i)) then
5578           difi=difi-drange(i)
5579           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5580           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5581         else if (difi.lt.-drange(i)) then
5582           difi=difi+drange(i)
5583           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5584           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5585         endif
5586 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5587 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5588       enddo
5589 !      write (iout,*) 'edihcnstr',edihcnstr
5590       return
5591       end
5592 c------------------------------------------------------------------------------
5593       subroutine etor_d(etors_d)
5594       etors_d=0.0d0
5595       return
5596       end
5597 c----------------------------------------------------------------------------
5598 #else
5599       subroutine etor(etors,edihcnstr)
5600       implicit real*8 (a-h,o-z)
5601       include 'DIMENSIONS'
5602       include 'COMMON.VAR'
5603       include 'COMMON.GEO'
5604       include 'COMMON.LOCAL'
5605       include 'COMMON.TORSION'
5606       include 'COMMON.INTERACT'
5607       include 'COMMON.DERIV'
5608       include 'COMMON.CHAIN'
5609       include 'COMMON.NAMES'
5610       include 'COMMON.IOUNITS'
5611       include 'COMMON.FFIELD'
5612       include 'COMMON.TORCNSTR'
5613       include 'COMMON.CONTROL'
5614       logical lprn
5615 C Set lprn=.true. for debugging
5616       lprn=.false.
5617 c     lprn=.true.
5618       etors=0.0D0
5619       do i=iphi_start,iphi_end
5620       etors_ii=0.0D0
5621         itori=itortyp(itype(i-2))
5622         itori1=itortyp(itype(i-1))
5623         phii=phi(i)
5624         gloci=0.0D0
5625 C Regular cosine and sine terms
5626         do j=1,nterm(itori,itori1)
5627           v1ij=v1(j,itori,itori1)
5628           v2ij=v2(j,itori,itori1)
5629           cosphi=dcos(j*phii)
5630           sinphi=dsin(j*phii)
5631           etors=etors+v1ij*cosphi+v2ij*sinphi
5632           if (energy_dec) etors_ii=etors_ii+
5633      &                v1ij*cosphi+v2ij*sinphi
5634           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5635         enddo
5636 C Lorentz terms
5637 C                         v1
5638 C  E = SUM ----------------------------------- - v1
5639 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5640 C
5641         cosphi=dcos(0.5d0*phii)
5642         sinphi=dsin(0.5d0*phii)
5643         do j=1,nlor(itori,itori1)
5644           vl1ij=vlor1(j,itori,itori1)
5645           vl2ij=vlor2(j,itori,itori1)
5646           vl3ij=vlor3(j,itori,itori1)
5647           pom=vl2ij*cosphi+vl3ij*sinphi
5648           pom1=1.0d0/(pom*pom+1.0d0)
5649           etors=etors+vl1ij*pom1
5650           if (energy_dec) etors_ii=etors_ii+
5651      &                vl1ij*pom1
5652           pom=-pom*pom1*pom1
5653           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5654         enddo
5655 C Subtract the constant term
5656         etors=etors-v0(itori,itori1)
5657           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5658      &         'etor',i,etors_ii-v0(itori,itori1)
5659         if (lprn)
5660      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5661      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5662      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5663         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5664 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5665       enddo
5666 ! 6/20/98 - dihedral angle constraints
5667       edihcnstr=0.0d0
5668 c      do i=1,ndih_constr
5669       do i=idihconstr_start,idihconstr_end
5670         itori=idih_constr(i)
5671         phii=phi(itori)
5672         difi=pinorm(phii-phi0(i))
5673         if (difi.gt.drange(i)) then
5674           difi=difi-drange(i)
5675           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5676           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5677         else if (difi.lt.-drange(i)) then
5678           difi=difi+drange(i)
5679           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5680           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5681         else
5682           difi=0.0
5683         endif
5684 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5685 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5686 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5687       enddo
5688 cd       write (iout,*) 'edihcnstr',edihcnstr
5689       return
5690       end
5691 c----------------------------------------------------------------------------
5692       subroutine etor_d(etors_d)
5693 C 6/23/01 Compute double torsional energy
5694       implicit real*8 (a-h,o-z)
5695       include 'DIMENSIONS'
5696       include 'COMMON.VAR'
5697       include 'COMMON.GEO'
5698       include 'COMMON.LOCAL'
5699       include 'COMMON.TORSION'
5700       include 'COMMON.INTERACT'
5701       include 'COMMON.DERIV'
5702       include 'COMMON.CHAIN'
5703       include 'COMMON.NAMES'
5704       include 'COMMON.IOUNITS'
5705       include 'COMMON.FFIELD'
5706       include 'COMMON.TORCNSTR'
5707       logical lprn
5708 C Set lprn=.true. for debugging
5709       lprn=.false.
5710 c     lprn=.true.
5711       etors_d=0.0D0
5712       do i=iphid_start,iphid_end
5713         itori=itortyp(itype(i-2))
5714         itori1=itortyp(itype(i-1))
5715         itori2=itortyp(itype(i))
5716         phii=phi(i)
5717         phii1=phi(i+1)
5718         gloci1=0.0D0
5719         gloci2=0.0D0
5720 C Regular cosine and sine terms
5721         do j=1,ntermd_1(itori,itori1,itori2)
5722           v1cij=v1c(1,j,itori,itori1,itori2)
5723           v1sij=v1s(1,j,itori,itori1,itori2)
5724           v2cij=v1c(2,j,itori,itori1,itori2)
5725           v2sij=v1s(2,j,itori,itori1,itori2)
5726           cosphi1=dcos(j*phii)
5727           sinphi1=dsin(j*phii)
5728           cosphi2=dcos(j*phii1)
5729           sinphi2=dsin(j*phii1)
5730           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5731      &     v2cij*cosphi2+v2sij*sinphi2
5732           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5733           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5734         enddo
5735         do k=2,ntermd_2(itori,itori1,itori2)
5736           do l=1,k-1
5737             v1cdij = v2c(k,l,itori,itori1,itori2)
5738             v2cdij = v2c(l,k,itori,itori1,itori2)
5739             v1sdij = v2s(k,l,itori,itori1,itori2)
5740             v2sdij = v2s(l,k,itori,itori1,itori2)
5741             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5742             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5743             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5744             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5745             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5746      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5747             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5748      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5749             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5750      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5751           enddo
5752         enddo
5753         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5754         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5755       enddo
5756       return
5757       end
5758 #endif
5759 c------------------------------------------------------------------------------
5760       subroutine eback_sc_corr(esccor)
5761 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5762 c        conformational states; temporarily implemented as differences
5763 c        between UNRES torsional potentials (dependent on three types of
5764 c        residues) and the torsional potentials dependent on all 20 types
5765 c        of residues computed from AM1  energy surfaces of terminally-blocked
5766 c        amino-acid residues.
5767       implicit real*8 (a-h,o-z)
5768       include 'DIMENSIONS'
5769       include 'COMMON.VAR'
5770       include 'COMMON.GEO'
5771       include 'COMMON.LOCAL'
5772       include 'COMMON.TORSION'
5773       include 'COMMON.SCCOR'
5774       include 'COMMON.INTERACT'
5775       include 'COMMON.DERIV'
5776       include 'COMMON.CHAIN'
5777       include 'COMMON.NAMES'
5778       include 'COMMON.IOUNITS'
5779       include 'COMMON.FFIELD'
5780       include 'COMMON.CONTROL'
5781       logical lprn
5782 C Set lprn=.true. for debugging
5783 C Set lprn=.true. for debugging
5784       lprn=.false.
5785 c      lprn=.true.
5786 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
5787       esccor=0.0D0
5788       do i=itau_start,itau_end
5789         esccor_ii=0.0D0
5790         isccori=isccortyp(itype(i-2))
5791         isccori1=isccortyp(itype(i-1))
5792 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
5793         phii=phi(i)
5794         do intertyp=1,3 !intertyp
5795 cc Added 09 May 2012 (Adasko)
5796 cc  Intertyp means interaction type of backbone mainchain correlation:
5797 c   1 = SC...Ca...Ca...Ca
5798 c   2 = Ca...Ca...Ca...SC
5799 c   3 = SC...Ca...Ca...SCi
5800         gloci=0.0D0
5801         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5802      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
5803      &      (itype(i-1).eq.ntyp1)))
5804      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5805      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
5806      &     .or.(itype(i).eq.ntyp1)))
5807      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5808      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
5809      &      (itype(i-3).eq.ntyp1)))) cycle
5810         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
5811         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
5812      & cycle
5813        do j=1,nterm_sccor(isccori,isccori1)
5814           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5815           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5816           cosphi=dcos(j*tauangle(intertyp,i))
5817           sinphi=dsin(j*tauangle(intertyp,i))
5818           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5819           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5820         enddo
5821 c      write (iout,*) "EBACK_SC_COR",i,esccor,intertyp
5822         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5823         if (lprn)
5824      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5825      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
5826      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
5827      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
5828 C        gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5829        enddo !intertyp
5830       enddo
5831       return
5832       end
5833 c----------------------------------------------------------------------------
5834       subroutine multibody(ecorr)
5835 C This subroutine calculates multi-body contributions to energy following
5836 C the idea of Skolnick et al. If side chains I and J make a contact and
5837 C at the same time side chains I+1 and J+1 make a contact, an extra
5838 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5839       implicit real*8 (a-h,o-z)
5840       include 'DIMENSIONS'
5841       include 'COMMON.IOUNITS'
5842       include 'COMMON.DERIV'
5843       include 'COMMON.INTERACT'
5844       include 'COMMON.CONTACTS'
5845       double precision gx(3),gx1(3)
5846       logical lprn
5847
5848 C Set lprn=.true. for debugging
5849       lprn=.false.
5850
5851       if (lprn) then
5852         write (iout,'(a)') 'Contact function values:'
5853         do i=nnt,nct-2
5854           write (iout,'(i2,20(1x,i2,f10.5))')
5855      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5856         enddo
5857       endif
5858       ecorr=0.0D0
5859       do i=nnt,nct
5860         do j=1,3
5861           gradcorr(j,i)=0.0D0
5862           gradxorr(j,i)=0.0D0
5863         enddo
5864       enddo
5865       do i=nnt,nct-2
5866
5867         DO ISHIFT = 3,4
5868
5869         i1=i+ishift
5870         num_conti=num_cont(i)
5871         num_conti1=num_cont(i1)
5872         do jj=1,num_conti
5873           j=jcont(jj,i)
5874           do kk=1,num_conti1
5875             j1=jcont(kk,i1)
5876             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5877 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5878 cd   &                   ' ishift=',ishift
5879 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5880 C The system gains extra energy.
5881               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5882             endif   ! j1==j+-ishift
5883           enddo     ! kk
5884         enddo       ! jj
5885
5886         ENDDO ! ISHIFT
5887
5888       enddo         ! i
5889       return
5890       end
5891 c------------------------------------------------------------------------------
5892       double precision function esccorr(i,j,k,l,jj,kk)
5893       implicit real*8 (a-h,o-z)
5894       include 'DIMENSIONS'
5895       include 'COMMON.IOUNITS'
5896       include 'COMMON.DERIV'
5897       include 'COMMON.INTERACT'
5898       include 'COMMON.CONTACTS'
5899       double precision gx(3),gx1(3)
5900       logical lprn
5901       lprn=.false.
5902       eij=facont(jj,i)
5903       ekl=facont(kk,k)
5904 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5905 C Calculate the multi-body contribution to energy.
5906 C Calculate multi-body contributions to the gradient.
5907 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5908 cd   & k,l,(gacont(m,kk,k),m=1,3)
5909       do m=1,3
5910         gx(m) =ekl*gacont(m,jj,i)
5911         gx1(m)=eij*gacont(m,kk,k)
5912         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5913         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5914         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5915         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5916       enddo
5917       do m=i,j-1
5918         do ll=1,3
5919           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5920         enddo
5921       enddo
5922       do m=k,l-1
5923         do ll=1,3
5924           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5925         enddo
5926       enddo
5927       esccorr=-eij*ekl
5928       return
5929       end
5930 c------------------------------------------------------------------------------
5931       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5932 C This subroutine calculates multi-body contributions to hydrogen-bonding
5933       implicit real*8 (a-h,o-z)
5934       include 'DIMENSIONS'
5935       include 'COMMON.IOUNITS'
5936 #ifdef MPI
5937       include "mpif.h"
5938       parameter (max_cont=maxconts)
5939       parameter (max_dim=26)
5940       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
5941       double precision zapas(max_dim,maxconts,max_fg_procs),
5942      &  zapas_recv(max_dim,maxconts,max_fg_procs)
5943       common /przechowalnia/ zapas
5944       integer status(MPI_STATUS_SIZE),req(maxconts*2),
5945      &  status_array(MPI_STATUS_SIZE,maxconts*2)
5946 #endif
5947       include 'COMMON.SETUP'
5948       include 'COMMON.FFIELD'
5949       include 'COMMON.DERIV'
5950       include 'COMMON.INTERACT'
5951       include 'COMMON.CONTACTS'
5952       include 'COMMON.CONTROL'
5953       include 'COMMON.LOCAL'
5954       double precision gx(3),gx1(3),time00
5955       logical lprn,ldone
5956
5957 C Set lprn=.true. for debugging
5958       lprn=.false.
5959 #ifdef MPI
5960       n_corr=0
5961       n_corr1=0
5962       if (nfgtasks.le.1) goto 30
5963       if (lprn) then
5964         write (iout,'(a)') 'Contact function values before RECEIVE:'
5965         do i=nnt,nct-2
5966           write (iout,'(2i3,50(1x,i2,f5.2))')
5967      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5968      &    j=1,num_cont_hb(i))
5969         enddo
5970       endif
5971       call flush(iout)
5972       do i=1,ntask_cont_from
5973         ncont_recv(i)=0
5974       enddo
5975       do i=1,ntask_cont_to
5976         ncont_sent(i)=0
5977       enddo
5978 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
5979 c     & ntask_cont_to
5980 C Make the list of contacts to send to send to other procesors
5981 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
5982 c      call flush(iout)
5983       do i=iturn3_start,iturn3_end
5984 c        write (iout,*) "make contact list turn3",i," num_cont",
5985 c     &    num_cont_hb(i)
5986         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
5987       enddo
5988       do i=iturn4_start,iturn4_end
5989 c        write (iout,*) "make contact list turn4",i," num_cont",
5990 c     &   num_cont_hb(i)
5991         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
5992       enddo
5993       do ii=1,nat_sent
5994         i=iat_sent(ii)
5995 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
5996 c     &    num_cont_hb(i)
5997         do j=1,num_cont_hb(i)
5998         do k=1,4
5999           jjc=jcont_hb(j,i)
6000           iproc=iint_sent_local(k,jjc,ii)
6001 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6002           if (iproc.gt.0) then
6003             ncont_sent(iproc)=ncont_sent(iproc)+1
6004             nn=ncont_sent(iproc)
6005             zapas(1,nn,iproc)=i
6006             zapas(2,nn,iproc)=jjc
6007             zapas(3,nn,iproc)=facont_hb(j,i)
6008             zapas(4,nn,iproc)=ees0p(j,i)
6009             zapas(5,nn,iproc)=ees0m(j,i)
6010             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6011             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6012             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6013             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6014             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6015             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6016             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6017             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6018             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6019             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6020             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6021             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6022             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6023             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6024             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6025             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6026             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6027             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6028             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6029             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6030             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6031           endif
6032         enddo
6033         enddo
6034       enddo
6035       if (lprn) then
6036       write (iout,*)
6037      &  "Numbers of contacts to be sent to other processors",
6038      &  (ncont_sent(i),i=1,ntask_cont_to)
6039       write (iout,*) "Contacts sent"
6040       do ii=1,ntask_cont_to
6041         nn=ncont_sent(ii)
6042         iproc=itask_cont_to(ii)
6043         write (iout,*) nn," contacts to processor",iproc,
6044      &   " of CONT_TO_COMM group"
6045         do i=1,nn
6046           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6047         enddo
6048       enddo
6049       call flush(iout)
6050       endif
6051       CorrelType=477
6052       CorrelID=fg_rank+1
6053       CorrelType1=478
6054       CorrelID1=nfgtasks+fg_rank+1
6055       ireq=0
6056 C Receive the numbers of needed contacts from other processors
6057       do ii=1,ntask_cont_from
6058         iproc=itask_cont_from(ii)
6059         ireq=ireq+1
6060         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6061      &    FG_COMM,req(ireq),IERR)
6062       enddo
6063 c      write (iout,*) "IRECV ended"
6064 c      call flush(iout)
6065 C Send the number of contacts needed by other processors
6066       do ii=1,ntask_cont_to
6067         iproc=itask_cont_to(ii)
6068         ireq=ireq+1
6069         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6070      &    FG_COMM,req(ireq),IERR)
6071       enddo
6072 c      write (iout,*) "ISEND ended"
6073 c      write (iout,*) "number of requests (nn)",ireq
6074       call flush(iout)
6075       if (ireq.gt.0)
6076      &  call MPI_Waitall(ireq,req,status_array,ierr)
6077 c      write (iout,*)
6078 c     &  "Numbers of contacts to be received from other processors",
6079 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6080 c      call flush(iout)
6081 C Receive contacts
6082       ireq=0
6083       do ii=1,ntask_cont_from
6084         iproc=itask_cont_from(ii)
6085         nn=ncont_recv(ii)
6086 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6087 c     &   " of CONT_TO_COMM group"
6088         call flush(iout)
6089         if (nn.gt.0) then
6090           ireq=ireq+1
6091           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6092      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6093 c          write (iout,*) "ireq,req",ireq,req(ireq)
6094         endif
6095       enddo
6096 C Send the contacts to processors that need them
6097       do ii=1,ntask_cont_to
6098         iproc=itask_cont_to(ii)
6099         nn=ncont_sent(ii)
6100 c        write (iout,*) nn," contacts to processor",iproc,
6101 c     &   " of CONT_TO_COMM group"
6102         if (nn.gt.0) then
6103           ireq=ireq+1
6104           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6105      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6106 c          write (iout,*) "ireq,req",ireq,req(ireq)
6107 c          do i=1,nn
6108 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6109 c          enddo
6110         endif
6111       enddo
6112 c      write (iout,*) "number of requests (contacts)",ireq
6113 c      write (iout,*) "req",(req(i),i=1,4)
6114 c      call flush(iout)
6115       if (ireq.gt.0)
6116      & call MPI_Waitall(ireq,req,status_array,ierr)
6117       do iii=1,ntask_cont_from
6118         iproc=itask_cont_from(iii)
6119         nn=ncont_recv(iii)
6120         if (lprn) then
6121         write (iout,*) "Received",nn," contacts from processor",iproc,
6122      &   " of CONT_FROM_COMM group"
6123         call flush(iout)
6124         do i=1,nn
6125           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6126         enddo
6127         call flush(iout)
6128         endif
6129         do i=1,nn
6130           ii=zapas_recv(1,i,iii)
6131 c Flag the received contacts to prevent double-counting
6132           jj=-zapas_recv(2,i,iii)
6133 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6134 c          call flush(iout)
6135           nnn=num_cont_hb(ii)+1
6136           num_cont_hb(ii)=nnn
6137           jcont_hb(nnn,ii)=jj
6138           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6139           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6140           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6141           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6142           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6143           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6144           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6145           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6146           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6147           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6148           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6149           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6150           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6151           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6152           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6153           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6154           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6155           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6156           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6157           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6158           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6159           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6160           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6161           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6162         enddo
6163       enddo
6164       call flush(iout)
6165       if (lprn) then
6166         write (iout,'(a)') 'Contact function values after receive:'
6167         do i=nnt,nct-2
6168           write (iout,'(2i3,50(1x,i3,f5.2))')
6169      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6170      &    j=1,num_cont_hb(i))
6171         enddo
6172         call flush(iout)
6173       endif
6174    30 continue
6175 #endif
6176       if (lprn) then
6177         write (iout,'(a)') 'Contact function values:'
6178         do i=nnt,nct-2
6179           write (iout,'(2i3,50(1x,i3,f5.2))')
6180      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6181      &    j=1,num_cont_hb(i))
6182         enddo
6183       endif
6184       ecorr=0.0D0
6185 C Remove the loop below after debugging !!!
6186       do i=nnt,nct
6187         do j=1,3
6188           gradcorr(j,i)=0.0D0
6189           gradxorr(j,i)=0.0D0
6190         enddo
6191       enddo
6192 C Calculate the local-electrostatic correlation terms
6193       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6194         i1=i+1
6195         num_conti=num_cont_hb(i)
6196         num_conti1=num_cont_hb(i+1)
6197         do jj=1,num_conti
6198           j=jcont_hb(jj,i)
6199           jp=iabs(j)
6200           do kk=1,num_conti1
6201             j1=jcont_hb(kk,i1)
6202             jp1=iabs(j1)
6203 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6204 c     &         ' jj=',jj,' kk=',kk
6205             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6206      &          .or. j.lt.0 .and. j1.gt.0) .and.
6207      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6208 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6209 C The system gains extra energy.
6210               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6211               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6212      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6213               n_corr=n_corr+1
6214             else if (j1.eq.j) then
6215 C Contacts I-J and I-(J+1) occur simultaneously.
6216 C The system loses extra energy.
6217 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6218             endif
6219           enddo ! kk
6220           do kk=1,num_conti
6221             j1=jcont_hb(kk,i)
6222 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6223 c    &         ' jj=',jj,' kk=',kk
6224             if (j1.eq.j+1) then
6225 C Contacts I-J and (I+1)-J occur simultaneously.
6226 C The system loses extra energy.
6227 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6228             endif ! j1==j+1
6229           enddo ! kk
6230         enddo ! jj
6231       enddo ! i
6232       return
6233       end
6234 c------------------------------------------------------------------------------
6235       subroutine add_hb_contact(ii,jj,itask)
6236       implicit real*8 (a-h,o-z)
6237       include "DIMENSIONS"
6238       include "COMMON.IOUNITS"
6239       integer max_cont
6240       integer max_dim
6241       parameter (max_cont=maxconts)
6242       parameter (max_dim=26)
6243       include "COMMON.CONTACTS"
6244       double precision zapas(max_dim,maxconts,max_fg_procs),
6245      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6246       common /przechowalnia/ zapas
6247       integer i,j,ii,jj,iproc,itask(4),nn
6248 c      write (iout,*) "itask",itask
6249       do i=1,2
6250         iproc=itask(i)
6251         if (iproc.gt.0) then
6252           do j=1,num_cont_hb(ii)
6253             jjc=jcont_hb(j,ii)
6254 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6255             if (jjc.eq.jj) then
6256               ncont_sent(iproc)=ncont_sent(iproc)+1
6257               nn=ncont_sent(iproc)
6258               zapas(1,nn,iproc)=ii
6259               zapas(2,nn,iproc)=jjc
6260               zapas(3,nn,iproc)=facont_hb(j,ii)
6261               zapas(4,nn,iproc)=ees0p(j,ii)
6262               zapas(5,nn,iproc)=ees0m(j,ii)
6263               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6264               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6265               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6266               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6267               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6268               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6269               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6270               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6271               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6272               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6273               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6274               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6275               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6276               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6277               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6278               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6279               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6280               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6281               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6282               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6283               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6284               exit
6285             endif
6286           enddo
6287         endif
6288       enddo
6289       return
6290       end
6291 c------------------------------------------------------------------------------
6292       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6293      &  n_corr1)
6294 C This subroutine calculates multi-body contributions to hydrogen-bonding
6295       implicit real*8 (a-h,o-z)
6296       include 'DIMENSIONS'
6297       include 'COMMON.IOUNITS'
6298 #ifdef MPI
6299       include "mpif.h"
6300       parameter (max_cont=maxconts)
6301       parameter (max_dim=70)
6302       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6303       double precision zapas(max_dim,maxconts,max_fg_procs),
6304      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6305       common /przechowalnia/ zapas
6306       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6307      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6308 #endif
6309       include 'COMMON.SETUP'
6310       include 'COMMON.FFIELD'
6311       include 'COMMON.DERIV'
6312       include 'COMMON.LOCAL'
6313       include 'COMMON.INTERACT'
6314       include 'COMMON.CONTACTS'
6315       include 'COMMON.CHAIN'
6316       include 'COMMON.CONTROL'
6317       double precision gx(3),gx1(3)
6318       integer num_cont_hb_old(maxres)
6319       logical lprn,ldone
6320       double precision eello4,eello5,eelo6,eello_turn6
6321       external eello4,eello5,eello6,eello_turn6
6322 C Set lprn=.true. for debugging
6323       lprn=.false.
6324       eturn6=0.0d0
6325 #ifdef MPI
6326       do i=1,nres
6327         num_cont_hb_old(i)=num_cont_hb(i)
6328       enddo
6329       n_corr=0
6330       n_corr1=0
6331       if (nfgtasks.le.1) goto 30
6332       if (lprn) then
6333         write (iout,'(a)') 'Contact function values before RECEIVE:'
6334         do i=nnt,nct-2
6335           write (iout,'(2i3,50(1x,i2,f5.2))')
6336      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6337      &    j=1,num_cont_hb(i))
6338         enddo
6339       endif
6340       call flush(iout)
6341       do i=1,ntask_cont_from
6342         ncont_recv(i)=0
6343       enddo
6344       do i=1,ntask_cont_to
6345         ncont_sent(i)=0
6346       enddo
6347 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6348 c     & ntask_cont_to
6349 C Make the list of contacts to send to send to other procesors
6350       do i=iturn3_start,iturn3_end
6351 c        write (iout,*) "make contact list turn3",i," num_cont",
6352 c     &    num_cont_hb(i)
6353         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6354       enddo
6355       do i=iturn4_start,iturn4_end
6356 c        write (iout,*) "make contact list turn4",i," num_cont",
6357 c     &   num_cont_hb(i)
6358         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6359       enddo
6360       do ii=1,nat_sent
6361         i=iat_sent(ii)
6362 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6363 c     &    num_cont_hb(i)
6364         do j=1,num_cont_hb(i)
6365         do k=1,4
6366           jjc=jcont_hb(j,i)
6367           iproc=iint_sent_local(k,jjc,ii)
6368 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6369           if (iproc.ne.0) then
6370             ncont_sent(iproc)=ncont_sent(iproc)+1
6371             nn=ncont_sent(iproc)
6372             zapas(1,nn,iproc)=i
6373             zapas(2,nn,iproc)=jjc
6374             zapas(3,nn,iproc)=d_cont(j,i)
6375             ind=3
6376             do kk=1,3
6377               ind=ind+1
6378               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6379             enddo
6380             do kk=1,2
6381               do ll=1,2
6382                 ind=ind+1
6383                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6384               enddo
6385             enddo
6386             do jj=1,5
6387               do kk=1,3
6388                 do ll=1,2
6389                   do mm=1,2
6390                     ind=ind+1
6391                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6392                   enddo
6393                 enddo
6394               enddo
6395             enddo
6396           endif
6397         enddo
6398         enddo
6399       enddo
6400       if (lprn) then
6401       write (iout,*)
6402      &  "Numbers of contacts to be sent to other processors",
6403      &  (ncont_sent(i),i=1,ntask_cont_to)
6404       write (iout,*) "Contacts sent"
6405       do ii=1,ntask_cont_to
6406         nn=ncont_sent(ii)
6407         iproc=itask_cont_to(ii)
6408         write (iout,*) nn," contacts to processor",iproc,
6409      &   " of CONT_TO_COMM group"
6410         do i=1,nn
6411           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6412         enddo
6413       enddo
6414       call flush(iout)
6415       endif
6416       CorrelType=477
6417       CorrelID=fg_rank+1
6418       CorrelType1=478
6419       CorrelID1=nfgtasks+fg_rank+1
6420       ireq=0
6421 C Receive the numbers of needed contacts from other processors
6422       do ii=1,ntask_cont_from
6423         iproc=itask_cont_from(ii)
6424         ireq=ireq+1
6425         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6426      &    FG_COMM,req(ireq),IERR)
6427       enddo
6428 c      write (iout,*) "IRECV ended"
6429 c      call flush(iout)
6430 C Send the number of contacts needed by other processors
6431       do ii=1,ntask_cont_to
6432         iproc=itask_cont_to(ii)
6433         ireq=ireq+1
6434         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6435      &    FG_COMM,req(ireq),IERR)
6436       enddo
6437 c      write (iout,*) "ISEND ended"
6438 c      write (iout,*) "number of requests (nn)",ireq
6439       call flush(iout)
6440       if (ireq.gt.0)
6441      &  call MPI_Waitall(ireq,req,status_array,ierr)
6442 c      write (iout,*)
6443 c     &  "Numbers of contacts to be received from other processors",
6444 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6445 c      call flush(iout)
6446 C Receive contacts
6447       ireq=0
6448       do ii=1,ntask_cont_from
6449         iproc=itask_cont_from(ii)
6450         nn=ncont_recv(ii)
6451 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6452 c     &   " of CONT_TO_COMM group"
6453         call flush(iout)
6454         if (nn.gt.0) then
6455           ireq=ireq+1
6456           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6457      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6458 c          write (iout,*) "ireq,req",ireq,req(ireq)
6459         endif
6460       enddo
6461 C Send the contacts to processors that need them
6462       do ii=1,ntask_cont_to
6463         iproc=itask_cont_to(ii)
6464         nn=ncont_sent(ii)
6465 c        write (iout,*) nn," contacts to processor",iproc,
6466 c     &   " of CONT_TO_COMM group"
6467         if (nn.gt.0) then
6468           ireq=ireq+1
6469           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6470      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6471 c          write (iout,*) "ireq,req",ireq,req(ireq)
6472 c          do i=1,nn
6473 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6474 c          enddo
6475         endif
6476       enddo
6477 c      write (iout,*) "number of requests (contacts)",ireq
6478 c      write (iout,*) "req",(req(i),i=1,4)
6479 c      call flush(iout)
6480       if (ireq.gt.0)
6481      & call MPI_Waitall(ireq,req,status_array,ierr)
6482       do iii=1,ntask_cont_from
6483         iproc=itask_cont_from(iii)
6484         nn=ncont_recv(iii)
6485         if (lprn) then
6486         write (iout,*) "Received",nn," contacts from processor",iproc,
6487      &   " of CONT_FROM_COMM group"
6488         call flush(iout)
6489         do i=1,nn
6490           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6491         enddo
6492         call flush(iout)
6493         endif
6494         do i=1,nn
6495           ii=zapas_recv(1,i,iii)
6496 c Flag the received contacts to prevent double-counting
6497           jj=-zapas_recv(2,i,iii)
6498 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6499 c          call flush(iout)
6500           nnn=num_cont_hb(ii)+1
6501           num_cont_hb(ii)=nnn
6502           jcont_hb(nnn,ii)=jj
6503           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6504           ind=3
6505           do kk=1,3
6506             ind=ind+1
6507             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6508           enddo
6509           do kk=1,2
6510             do ll=1,2
6511               ind=ind+1
6512               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6513             enddo
6514           enddo
6515           do jj=1,5
6516             do kk=1,3
6517               do ll=1,2
6518                 do mm=1,2
6519                   ind=ind+1
6520                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6521                 enddo
6522               enddo
6523             enddo
6524           enddo
6525         enddo
6526       enddo
6527       call flush(iout)
6528       if (lprn) then
6529         write (iout,'(a)') 'Contact function values after receive:'
6530         do i=nnt,nct-2
6531           write (iout,'(2i3,50(1x,i3,5f6.3))')
6532      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6533      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6534         enddo
6535         call flush(iout)
6536       endif
6537    30 continue
6538 #endif
6539       if (lprn) then
6540         write (iout,'(a)') 'Contact function values:'
6541         do i=nnt,nct-2
6542           write (iout,'(2i3,50(1x,i2,5f6.3))')
6543      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6544      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6545         enddo
6546       endif
6547       ecorr=0.0D0
6548       ecorr5=0.0d0
6549       ecorr6=0.0d0
6550 C Remove the loop below after debugging !!!
6551       do i=nnt,nct
6552         do j=1,3
6553           gradcorr(j,i)=0.0D0
6554           gradxorr(j,i)=0.0D0
6555         enddo
6556       enddo
6557 C Calculate the dipole-dipole interaction energies
6558       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6559       do i=iatel_s,iatel_e+1
6560         num_conti=num_cont_hb(i)
6561         do jj=1,num_conti
6562           j=jcont_hb(jj,i)
6563 #ifdef MOMENT
6564           call dipole(i,j,jj)
6565 #endif
6566         enddo
6567       enddo
6568       endif
6569 C Calculate the local-electrostatic correlation terms
6570 c                write (iout,*) "gradcorr5 in eello5 before loop"
6571 c                do iii=1,nres
6572 c                  write (iout,'(i5,3f10.5)')
6573 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6574 c                enddo
6575       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6576 c        write (iout,*) "corr loop i",i
6577         i1=i+1
6578         num_conti=num_cont_hb(i)
6579         num_conti1=num_cont_hb(i+1)
6580         do jj=1,num_conti
6581           j=jcont_hb(jj,i)
6582           jp=iabs(j)
6583           do kk=1,num_conti1
6584             j1=jcont_hb(kk,i1)
6585             jp1=iabs(j1)
6586 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6587 c     &         ' jj=',jj,' kk=',kk
6588 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6589             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6590      &          .or. j.lt.0 .and. j1.gt.0) .and.
6591      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6592 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6593 C The system gains extra energy.
6594               n_corr=n_corr+1
6595               sqd1=dsqrt(d_cont(jj,i))
6596               sqd2=dsqrt(d_cont(kk,i1))
6597               sred_geom = sqd1*sqd2
6598               IF (sred_geom.lt.cutoff_corr) THEN
6599                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6600      &            ekont,fprimcont)
6601 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6602 cd     &         ' jj=',jj,' kk=',kk
6603                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6604                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6605                 do l=1,3
6606                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6607                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6608                 enddo
6609                 n_corr1=n_corr1+1
6610 cd               write (iout,*) 'sred_geom=',sred_geom,
6611 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6612 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6613 cd               write (iout,*) "g_contij",g_contij
6614 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6615 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6616                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6617                 if (wcorr4.gt.0.0d0)
6618      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6619                   if (energy_dec.and.wcorr4.gt.0.0d0)
6620      1                 write (iout,'(a6,4i5,0pf7.3)')
6621      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6622 c                write (iout,*) "gradcorr5 before eello5"
6623 c                do iii=1,nres
6624 c                  write (iout,'(i5,3f10.5)')
6625 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6626 c                enddo
6627                 if (wcorr5.gt.0.0d0)
6628      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6629 c                write (iout,*) "gradcorr5 after eello5"
6630 c                do iii=1,nres
6631 c                  write (iout,'(i5,3f10.5)')
6632 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6633 c                enddo
6634                   if (energy_dec.and.wcorr5.gt.0.0d0)
6635      1                 write (iout,'(a6,4i5,0pf7.3)')
6636      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6637 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6638 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6639                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6640      &               .or. wturn6.eq.0.0d0))then
6641 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6642                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6643                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6644      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6645 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6646 cd     &            'ecorr6=',ecorr6
6647 cd                write (iout,'(4e15.5)') sred_geom,
6648 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6649 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6650 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6651                 else if (wturn6.gt.0.0d0
6652      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6653 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6654                   eturn6=eturn6+eello_turn6(i,jj,kk)
6655                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6656      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6657 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6658                 endif
6659               ENDIF
6660 1111          continue
6661             endif
6662           enddo ! kk
6663         enddo ! jj
6664       enddo ! i
6665       do i=1,nres
6666         num_cont_hb(i)=num_cont_hb_old(i)
6667       enddo
6668 c                write (iout,*) "gradcorr5 in eello5"
6669 c                do iii=1,nres
6670 c                  write (iout,'(i5,3f10.5)')
6671 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6672 c                enddo
6673       return
6674       end
6675 c------------------------------------------------------------------------------
6676       subroutine add_hb_contact_eello(ii,jj,itask)
6677       implicit real*8 (a-h,o-z)
6678       include "DIMENSIONS"
6679       include "COMMON.IOUNITS"
6680       integer max_cont
6681       integer max_dim
6682       parameter (max_cont=maxconts)
6683       parameter (max_dim=70)
6684       include "COMMON.CONTACTS"
6685       double precision zapas(max_dim,maxconts,max_fg_procs),
6686      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6687       common /przechowalnia/ zapas
6688       integer i,j,ii,jj,iproc,itask(4),nn
6689 c      write (iout,*) "itask",itask
6690       do i=1,2
6691         iproc=itask(i)
6692         if (iproc.gt.0) then
6693           do j=1,num_cont_hb(ii)
6694             jjc=jcont_hb(j,ii)
6695 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6696             if (jjc.eq.jj) then
6697               ncont_sent(iproc)=ncont_sent(iproc)+1
6698               nn=ncont_sent(iproc)
6699               zapas(1,nn,iproc)=ii
6700               zapas(2,nn,iproc)=jjc
6701               zapas(3,nn,iproc)=d_cont(j,ii)
6702               ind=3
6703               do kk=1,3
6704                 ind=ind+1
6705                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6706               enddo
6707               do kk=1,2
6708                 do ll=1,2
6709                   ind=ind+1
6710                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6711                 enddo
6712               enddo
6713               do jj=1,5
6714                 do kk=1,3
6715                   do ll=1,2
6716                     do mm=1,2
6717                       ind=ind+1
6718                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6719                     enddo
6720                   enddo
6721                 enddo
6722               enddo
6723               exit
6724             endif
6725           enddo
6726         endif
6727       enddo
6728       return
6729       end
6730 c------------------------------------------------------------------------------
6731       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6732       implicit real*8 (a-h,o-z)
6733       include 'DIMENSIONS'
6734       include 'COMMON.IOUNITS'
6735       include 'COMMON.DERIV'
6736       include 'COMMON.INTERACT'
6737       include 'COMMON.CONTACTS'
6738       double precision gx(3),gx1(3)
6739       logical lprn
6740       lprn=.false.
6741       eij=facont_hb(jj,i)
6742       ekl=facont_hb(kk,k)
6743       ees0pij=ees0p(jj,i)
6744       ees0pkl=ees0p(kk,k)
6745       ees0mij=ees0m(jj,i)
6746       ees0mkl=ees0m(kk,k)
6747       ekont=eij*ekl
6748       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6749 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6750 C Following 4 lines for diagnostics.
6751 cd    ees0pkl=0.0D0
6752 cd    ees0pij=1.0D0
6753 cd    ees0mkl=0.0D0
6754 cd    ees0mij=1.0D0
6755 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6756 c     & 'Contacts ',i,j,
6757 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6758 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6759 c     & 'gradcorr_long'
6760 C Calculate the multi-body contribution to energy.
6761 c      ecorr=ecorr+ekont*ees
6762 C Calculate multi-body contributions to the gradient.
6763       coeffpees0pij=coeffp*ees0pij
6764       coeffmees0mij=coeffm*ees0mij
6765       coeffpees0pkl=coeffp*ees0pkl
6766       coeffmees0mkl=coeffm*ees0mkl
6767       do ll=1,3
6768 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6769         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6770      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6771      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6772         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6773      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6774      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6775 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6776         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6777      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6778      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6779         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6780      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6781      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6782         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6783      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6784      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6785         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6786         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6787         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6788      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6789      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6790         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6791         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6792 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6793       enddo
6794 c      write (iout,*)
6795 cgrad      do m=i+1,j-1
6796 cgrad        do ll=1,3
6797 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6798 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6799 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6800 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6801 cgrad        enddo
6802 cgrad      enddo
6803 cgrad      do m=k+1,l-1
6804 cgrad        do ll=1,3
6805 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6806 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6807 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6808 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6809 cgrad        enddo
6810 cgrad      enddo
6811 c      write (iout,*) "ehbcorr",ekont*ees
6812       ehbcorr=ekont*ees
6813       return
6814       end
6815 #ifdef MOMENT
6816 C---------------------------------------------------------------------------
6817       subroutine dipole(i,j,jj)
6818       implicit real*8 (a-h,o-z)
6819       include 'DIMENSIONS'
6820       include 'COMMON.IOUNITS'
6821       include 'COMMON.CHAIN'
6822       include 'COMMON.FFIELD'
6823       include 'COMMON.DERIV'
6824       include 'COMMON.INTERACT'
6825       include 'COMMON.CONTACTS'
6826       include 'COMMON.TORSION'
6827       include 'COMMON.VAR'
6828       include 'COMMON.GEO'
6829       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6830      &  auxmat(2,2)
6831       iti1 = itortyp(itype(i+1))
6832       if (j.lt.nres-1) then
6833         itj1 = itortyp(itype(j+1))
6834       else
6835         itj1=ntortyp+1
6836       endif
6837       do iii=1,2
6838         dipi(iii,1)=Ub2(iii,i)
6839         dipderi(iii)=Ub2der(iii,i)
6840         dipi(iii,2)=b1(iii,iti1)
6841         dipj(iii,1)=Ub2(iii,j)
6842         dipderj(iii)=Ub2der(iii,j)
6843         dipj(iii,2)=b1(iii,itj1)
6844       enddo
6845       kkk=0
6846       do iii=1,2
6847         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6848         do jjj=1,2
6849           kkk=kkk+1
6850           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6851         enddo
6852       enddo
6853       do kkk=1,5
6854         do lll=1,3
6855           mmm=0
6856           do iii=1,2
6857             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6858      &        auxvec(1))
6859             do jjj=1,2
6860               mmm=mmm+1
6861               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6862             enddo
6863           enddo
6864         enddo
6865       enddo
6866       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6867       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6868       do iii=1,2
6869         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6870       enddo
6871       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6872       do iii=1,2
6873         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6874       enddo
6875       return
6876       end
6877 #endif
6878 C---------------------------------------------------------------------------
6879       subroutine calc_eello(i,j,k,l,jj,kk)
6880 C
6881 C This subroutine computes matrices and vectors needed to calculate
6882 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6883 C
6884       implicit real*8 (a-h,o-z)
6885       include 'DIMENSIONS'
6886       include 'COMMON.IOUNITS'
6887       include 'COMMON.CHAIN'
6888       include 'COMMON.DERIV'
6889       include 'COMMON.INTERACT'
6890       include 'COMMON.CONTACTS'
6891       include 'COMMON.TORSION'
6892       include 'COMMON.VAR'
6893       include 'COMMON.GEO'
6894       include 'COMMON.FFIELD'
6895       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6896      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6897       logical lprn
6898       common /kutas/ lprn
6899 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6900 cd     & ' jj=',jj,' kk=',kk
6901 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6902 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
6903 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
6904       do iii=1,2
6905         do jjj=1,2
6906           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6907           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6908         enddo
6909       enddo
6910       call transpose2(aa1(1,1),aa1t(1,1))
6911       call transpose2(aa2(1,1),aa2t(1,1))
6912       do kkk=1,5
6913         do lll=1,3
6914           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6915      &      aa1tder(1,1,lll,kkk))
6916           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6917      &      aa2tder(1,1,lll,kkk))
6918         enddo
6919       enddo
6920       if (l.eq.j+1) then
6921 C parallel orientation of the two CA-CA-CA frames.
6922         if (i.gt.1) then
6923           iti=itortyp(itype(i))
6924         else
6925           iti=ntortyp+1
6926         endif
6927         itk1=itortyp(itype(k+1))
6928         itj=itortyp(itype(j))
6929         if (l.lt.nres-1) then
6930           itl1=itortyp(itype(l+1))
6931         else
6932           itl1=ntortyp+1
6933         endif
6934 C A1 kernel(j+1) A2T
6935 cd        do iii=1,2
6936 cd          write (iout,'(3f10.5,5x,3f10.5)')
6937 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6938 cd        enddo
6939         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6940      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6941      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6942 C Following matrices are needed only for 6-th order cumulants
6943         IF (wcorr6.gt.0.0d0) THEN
6944         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6945      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6946      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6947         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6948      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6949      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6950      &   ADtEAderx(1,1,1,1,1,1))
6951         lprn=.false.
6952         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6953      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6954      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6955      &   ADtEA1derx(1,1,1,1,1,1))
6956         ENDIF
6957 C End 6-th order cumulants
6958 cd        lprn=.false.
6959 cd        if (lprn) then
6960 cd        write (2,*) 'In calc_eello6'
6961 cd        do iii=1,2
6962 cd          write (2,*) 'iii=',iii
6963 cd          do kkk=1,5
6964 cd            write (2,*) 'kkk=',kkk
6965 cd            do jjj=1,2
6966 cd              write (2,'(3(2f10.5),5x)')
6967 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6968 cd            enddo
6969 cd          enddo
6970 cd        enddo
6971 cd        endif
6972         call transpose2(EUgder(1,1,k),auxmat(1,1))
6973         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6974         call transpose2(EUg(1,1,k),auxmat(1,1))
6975         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6976         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6977         do iii=1,2
6978           do kkk=1,5
6979             do lll=1,3
6980               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6981      &          EAEAderx(1,1,lll,kkk,iii,1))
6982             enddo
6983           enddo
6984         enddo
6985 C A1T kernel(i+1) A2
6986         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6987      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6988      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6989 C Following matrices are needed only for 6-th order cumulants
6990         IF (wcorr6.gt.0.0d0) THEN
6991         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6992      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6993      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6994         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6995      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6996      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6997      &   ADtEAderx(1,1,1,1,1,2))
6998         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6999      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7000      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7001      &   ADtEA1derx(1,1,1,1,1,2))
7002         ENDIF
7003 C End 6-th order cumulants
7004         call transpose2(EUgder(1,1,l),auxmat(1,1))
7005         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7006         call transpose2(EUg(1,1,l),auxmat(1,1))
7007         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7008         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7009         do iii=1,2
7010           do kkk=1,5
7011             do lll=1,3
7012               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7013      &          EAEAderx(1,1,lll,kkk,iii,2))
7014             enddo
7015           enddo
7016         enddo
7017 C AEAb1 and AEAb2
7018 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7019 C They are needed only when the fifth- or the sixth-order cumulants are
7020 C indluded.
7021         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7022         call transpose2(AEA(1,1,1),auxmat(1,1))
7023         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7024         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7025         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7026         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7027         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7028         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7029         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7030         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7031         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7032         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7033         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7034         call transpose2(AEA(1,1,2),auxmat(1,1))
7035         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7036         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7037         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7038         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7039         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7040         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7041         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7042         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7043         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7044         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7045         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7046 C Calculate the Cartesian derivatives of the vectors.
7047         do iii=1,2
7048           do kkk=1,5
7049             do lll=1,3
7050               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7051               call matvec2(auxmat(1,1),b1(1,iti),
7052      &          AEAb1derx(1,lll,kkk,iii,1,1))
7053               call matvec2(auxmat(1,1),Ub2(1,i),
7054      &          AEAb2derx(1,lll,kkk,iii,1,1))
7055               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7056      &          AEAb1derx(1,lll,kkk,iii,2,1))
7057               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7058      &          AEAb2derx(1,lll,kkk,iii,2,1))
7059               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7060               call matvec2(auxmat(1,1),b1(1,itj),
7061      &          AEAb1derx(1,lll,kkk,iii,1,2))
7062               call matvec2(auxmat(1,1),Ub2(1,j),
7063      &          AEAb2derx(1,lll,kkk,iii,1,2))
7064               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7065      &          AEAb1derx(1,lll,kkk,iii,2,2))
7066               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7067      &          AEAb2derx(1,lll,kkk,iii,2,2))
7068             enddo
7069           enddo
7070         enddo
7071         ENDIF
7072 C End vectors
7073       else
7074 C Antiparallel orientation of the two CA-CA-CA frames.
7075         if (i.gt.1) then
7076           iti=itortyp(itype(i))
7077         else
7078           iti=ntortyp+1
7079         endif
7080         itk1=itortyp(itype(k+1))
7081         itl=itortyp(itype(l))
7082         itj=itortyp(itype(j))
7083         if (j.lt.nres-1) then
7084           itj1=itortyp(itype(j+1))
7085         else
7086           itj1=ntortyp+1
7087         endif
7088 C A2 kernel(j-1)T A1T
7089         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7090      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7091      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7092 C Following matrices are needed only for 6-th order cumulants
7093         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7094      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7095         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7096      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7097      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7098         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7099      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7100      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7101      &   ADtEAderx(1,1,1,1,1,1))
7102         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7103      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7104      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7105      &   ADtEA1derx(1,1,1,1,1,1))
7106         ENDIF
7107 C End 6-th order cumulants
7108         call transpose2(EUgder(1,1,k),auxmat(1,1))
7109         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7110         call transpose2(EUg(1,1,k),auxmat(1,1))
7111         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7112         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7113         do iii=1,2
7114           do kkk=1,5
7115             do lll=1,3
7116               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7117      &          EAEAderx(1,1,lll,kkk,iii,1))
7118             enddo
7119           enddo
7120         enddo
7121 C A2T kernel(i+1)T A1
7122         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7123      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7124      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7125 C Following matrices are needed only for 6-th order cumulants
7126         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7127      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7128         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7129      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7130      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7131         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7132      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7133      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7134      &   ADtEAderx(1,1,1,1,1,2))
7135         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7136      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7137      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7138      &   ADtEA1derx(1,1,1,1,1,2))
7139         ENDIF
7140 C End 6-th order cumulants
7141         call transpose2(EUgder(1,1,j),auxmat(1,1))
7142         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7143         call transpose2(EUg(1,1,j),auxmat(1,1))
7144         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7145         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7146         do iii=1,2
7147           do kkk=1,5
7148             do lll=1,3
7149               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7150      &          EAEAderx(1,1,lll,kkk,iii,2))
7151             enddo
7152           enddo
7153         enddo
7154 C AEAb1 and AEAb2
7155 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7156 C They are needed only when the fifth- or the sixth-order cumulants are
7157 C indluded.
7158         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7159      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7160         call transpose2(AEA(1,1,1),auxmat(1,1))
7161         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7162         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7163         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7164         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7165         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7166         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7167         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7168         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7169         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7170         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7171         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7172         call transpose2(AEA(1,1,2),auxmat(1,1))
7173         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7174         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7175         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7176         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7177         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7178         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7179         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7180         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7181         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7182         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7183         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7184 C Calculate the Cartesian derivatives of the vectors.
7185         do iii=1,2
7186           do kkk=1,5
7187             do lll=1,3
7188               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7189               call matvec2(auxmat(1,1),b1(1,iti),
7190      &          AEAb1derx(1,lll,kkk,iii,1,1))
7191               call matvec2(auxmat(1,1),Ub2(1,i),
7192      &          AEAb2derx(1,lll,kkk,iii,1,1))
7193               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7194      &          AEAb1derx(1,lll,kkk,iii,2,1))
7195               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7196      &          AEAb2derx(1,lll,kkk,iii,2,1))
7197               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7198               call matvec2(auxmat(1,1),b1(1,itl),
7199      &          AEAb1derx(1,lll,kkk,iii,1,2))
7200               call matvec2(auxmat(1,1),Ub2(1,l),
7201      &          AEAb2derx(1,lll,kkk,iii,1,2))
7202               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7203      &          AEAb1derx(1,lll,kkk,iii,2,2))
7204               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7205      &          AEAb2derx(1,lll,kkk,iii,2,2))
7206             enddo
7207           enddo
7208         enddo
7209         ENDIF
7210 C End vectors
7211       endif
7212       return
7213       end
7214 C---------------------------------------------------------------------------
7215       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7216      &  KK,KKderg,AKA,AKAderg,AKAderx)
7217       implicit none
7218       integer nderg
7219       logical transp
7220       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7221      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7222      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7223       integer iii,kkk,lll
7224       integer jjj,mmm
7225       logical lprn
7226       common /kutas/ lprn
7227       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7228       do iii=1,nderg
7229         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7230      &    AKAderg(1,1,iii))
7231       enddo
7232 cd      if (lprn) write (2,*) 'In kernel'
7233       do kkk=1,5
7234 cd        if (lprn) write (2,*) 'kkk=',kkk
7235         do lll=1,3
7236           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7237      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7238 cd          if (lprn) then
7239 cd            write (2,*) 'lll=',lll
7240 cd            write (2,*) 'iii=1'
7241 cd            do jjj=1,2
7242 cd              write (2,'(3(2f10.5),5x)')
7243 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7244 cd            enddo
7245 cd          endif
7246           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7247      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7248 cd          if (lprn) then
7249 cd            write (2,*) 'lll=',lll
7250 cd            write (2,*) 'iii=2'
7251 cd            do jjj=1,2
7252 cd              write (2,'(3(2f10.5),5x)')
7253 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7254 cd            enddo
7255 cd          endif
7256         enddo
7257       enddo
7258       return
7259       end
7260 C---------------------------------------------------------------------------
7261       double precision function eello4(i,j,k,l,jj,kk)
7262       implicit real*8 (a-h,o-z)
7263       include 'DIMENSIONS'
7264       include 'COMMON.IOUNITS'
7265       include 'COMMON.CHAIN'
7266       include 'COMMON.DERIV'
7267       include 'COMMON.INTERACT'
7268       include 'COMMON.CONTACTS'
7269       include 'COMMON.TORSION'
7270       include 'COMMON.VAR'
7271       include 'COMMON.GEO'
7272       double precision pizda(2,2),ggg1(3),ggg2(3)
7273 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7274 cd        eello4=0.0d0
7275 cd        return
7276 cd      endif
7277 cd      print *,'eello4:',i,j,k,l,jj,kk
7278 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7279 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7280 cold      eij=facont_hb(jj,i)
7281 cold      ekl=facont_hb(kk,k)
7282 cold      ekont=eij*ekl
7283       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7284 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7285       gcorr_loc(k-1)=gcorr_loc(k-1)
7286      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7287       if (l.eq.j+1) then
7288         gcorr_loc(l-1)=gcorr_loc(l-1)
7289      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7290       else
7291         gcorr_loc(j-1)=gcorr_loc(j-1)
7292      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7293       endif
7294       do iii=1,2
7295         do kkk=1,5
7296           do lll=1,3
7297             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7298      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7299 cd            derx(lll,kkk,iii)=0.0d0
7300           enddo
7301         enddo
7302       enddo
7303 cd      gcorr_loc(l-1)=0.0d0
7304 cd      gcorr_loc(j-1)=0.0d0
7305 cd      gcorr_loc(k-1)=0.0d0
7306 cd      eel4=1.0d0
7307 cd      write (iout,*)'Contacts have occurred for peptide groups',
7308 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7309 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7310       if (j.lt.nres-1) then
7311         j1=j+1
7312         j2=j-1
7313       else
7314         j1=j-1
7315         j2=j-2
7316       endif
7317       if (l.lt.nres-1) then
7318         l1=l+1
7319         l2=l-1
7320       else
7321         l1=l-1
7322         l2=l-2
7323       endif
7324       do ll=1,3
7325 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7326 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7327         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7328         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7329 cgrad        ghalf=0.5d0*ggg1(ll)
7330         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7331         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7332         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7333         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7334         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7335         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7336 cgrad        ghalf=0.5d0*ggg2(ll)
7337         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7338         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7339         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7340         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7341         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7342         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7343       enddo
7344 cgrad      do m=i+1,j-1
7345 cgrad        do ll=1,3
7346 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7347 cgrad        enddo
7348 cgrad      enddo
7349 cgrad      do m=k+1,l-1
7350 cgrad        do ll=1,3
7351 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7352 cgrad        enddo
7353 cgrad      enddo
7354 cgrad      do m=i+2,j2
7355 cgrad        do ll=1,3
7356 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7357 cgrad        enddo
7358 cgrad      enddo
7359 cgrad      do m=k+2,l2
7360 cgrad        do ll=1,3
7361 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7362 cgrad        enddo
7363 cgrad      enddo
7364 cd      do iii=1,nres-3
7365 cd        write (2,*) iii,gcorr_loc(iii)
7366 cd      enddo
7367       eello4=ekont*eel4
7368 cd      write (2,*) 'ekont',ekont
7369 cd      write (iout,*) 'eello4',ekont*eel4
7370       return
7371       end
7372 C---------------------------------------------------------------------------
7373       double precision function eello5(i,j,k,l,jj,kk)
7374       implicit real*8 (a-h,o-z)
7375       include 'DIMENSIONS'
7376       include 'COMMON.IOUNITS'
7377       include 'COMMON.CHAIN'
7378       include 'COMMON.DERIV'
7379       include 'COMMON.INTERACT'
7380       include 'COMMON.CONTACTS'
7381       include 'COMMON.TORSION'
7382       include 'COMMON.VAR'
7383       include 'COMMON.GEO'
7384       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7385       double precision ggg1(3),ggg2(3)
7386 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7387 C                                                                              C
7388 C                            Parallel chains                                   C
7389 C                                                                              C
7390 C          o             o                   o             o                   C
7391 C         /l\           / \             \   / \           / \   /              C
7392 C        /   \         /   \             \ /   \         /   \ /               C
7393 C       j| o |l1       | o |              o| o |         | o |o                C
7394 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7395 C      \i/   \         /   \ /             /   \         /   \                 C
7396 C       o    k1             o                                                  C
7397 C         (I)          (II)                (III)          (IV)                 C
7398 C                                                                              C
7399 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7400 C                                                                              C
7401 C                            Antiparallel chains                               C
7402 C                                                                              C
7403 C          o             o                   o             o                   C
7404 C         /j\           / \             \   / \           / \   /              C
7405 C        /   \         /   \             \ /   \         /   \ /               C
7406 C      j1| o |l        | o |              o| o |         | o |o                C
7407 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7408 C      \i/   \         /   \ /             /   \         /   \                 C
7409 C       o     k1            o                                                  C
7410 C         (I)          (II)                (III)          (IV)                 C
7411 C                                                                              C
7412 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7413 C                                                                              C
7414 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7415 C                                                                              C
7416 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7417 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7418 cd        eello5=0.0d0
7419 cd        return
7420 cd      endif
7421 cd      write (iout,*)
7422 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7423 cd     &   ' and',k,l
7424       itk=itortyp(itype(k))
7425       itl=itortyp(itype(l))
7426       itj=itortyp(itype(j))
7427       eello5_1=0.0d0
7428       eello5_2=0.0d0
7429       eello5_3=0.0d0
7430       eello5_4=0.0d0
7431 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7432 cd     &   eel5_3_num,eel5_4_num)
7433       do iii=1,2
7434         do kkk=1,5
7435           do lll=1,3
7436             derx(lll,kkk,iii)=0.0d0
7437           enddo
7438         enddo
7439       enddo
7440 cd      eij=facont_hb(jj,i)
7441 cd      ekl=facont_hb(kk,k)
7442 cd      ekont=eij*ekl
7443 cd      write (iout,*)'Contacts have occurred for peptide groups',
7444 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7445 cd      goto 1111
7446 C Contribution from the graph I.
7447 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7448 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7449       call transpose2(EUg(1,1,k),auxmat(1,1))
7450       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7451       vv(1)=pizda(1,1)-pizda(2,2)
7452       vv(2)=pizda(1,2)+pizda(2,1)
7453       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7454      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7455 C Explicit gradient in virtual-dihedral angles.
7456       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7457      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7458      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7459       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7460       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7461       vv(1)=pizda(1,1)-pizda(2,2)
7462       vv(2)=pizda(1,2)+pizda(2,1)
7463       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7464      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7465      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7466       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7467       vv(1)=pizda(1,1)-pizda(2,2)
7468       vv(2)=pizda(1,2)+pizda(2,1)
7469       if (l.eq.j+1) then
7470         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7471      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7472      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7473       else
7474         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7475      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7476      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7477       endif
7478 C Cartesian gradient
7479       do iii=1,2
7480         do kkk=1,5
7481           do lll=1,3
7482             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7483      &        pizda(1,1))
7484             vv(1)=pizda(1,1)-pizda(2,2)
7485             vv(2)=pizda(1,2)+pizda(2,1)
7486             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7487      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7488      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7489           enddo
7490         enddo
7491       enddo
7492 c      goto 1112
7493 c1111  continue
7494 C Contribution from graph II
7495       call transpose2(EE(1,1,itk),auxmat(1,1))
7496       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7497       vv(1)=pizda(1,1)+pizda(2,2)
7498       vv(2)=pizda(2,1)-pizda(1,2)
7499       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7500      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7501 C Explicit gradient in virtual-dihedral angles.
7502       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7503      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7504       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7505       vv(1)=pizda(1,1)+pizda(2,2)
7506       vv(2)=pizda(2,1)-pizda(1,2)
7507       if (l.eq.j+1) then
7508         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7509      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7510      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7511       else
7512         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7513      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7514      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7515       endif
7516 C Cartesian gradient
7517       do iii=1,2
7518         do kkk=1,5
7519           do lll=1,3
7520             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7521      &        pizda(1,1))
7522             vv(1)=pizda(1,1)+pizda(2,2)
7523             vv(2)=pizda(2,1)-pizda(1,2)
7524             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7525      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7526      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7527           enddo
7528         enddo
7529       enddo
7530 cd      goto 1112
7531 cd1111  continue
7532       if (l.eq.j+1) then
7533 cd        goto 1110
7534 C Parallel orientation
7535 C Contribution from graph III
7536         call transpose2(EUg(1,1,l),auxmat(1,1))
7537         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7538         vv(1)=pizda(1,1)-pizda(2,2)
7539         vv(2)=pizda(1,2)+pizda(2,1)
7540         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7541      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7542 C Explicit gradient in virtual-dihedral angles.
7543         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7544      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7545      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7546         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7547         vv(1)=pizda(1,1)-pizda(2,2)
7548         vv(2)=pizda(1,2)+pizda(2,1)
7549         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7550      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7551      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7552         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7553         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7554         vv(1)=pizda(1,1)-pizda(2,2)
7555         vv(2)=pizda(1,2)+pizda(2,1)
7556         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7557      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7558      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7559 C Cartesian gradient
7560         do iii=1,2
7561           do kkk=1,5
7562             do lll=1,3
7563               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7564      &          pizda(1,1))
7565               vv(1)=pizda(1,1)-pizda(2,2)
7566               vv(2)=pizda(1,2)+pizda(2,1)
7567               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7568      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7569      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7570             enddo
7571           enddo
7572         enddo
7573 cd        goto 1112
7574 C Contribution from graph IV
7575 cd1110    continue
7576         call transpose2(EE(1,1,itl),auxmat(1,1))
7577         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7578         vv(1)=pizda(1,1)+pizda(2,2)
7579         vv(2)=pizda(2,1)-pizda(1,2)
7580         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7581      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7582 C Explicit gradient in virtual-dihedral angles.
7583         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7584      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7585         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7586         vv(1)=pizda(1,1)+pizda(2,2)
7587         vv(2)=pizda(2,1)-pizda(1,2)
7588         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7589      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7590      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7591 C Cartesian gradient
7592         do iii=1,2
7593           do kkk=1,5
7594             do lll=1,3
7595               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7596      &          pizda(1,1))
7597               vv(1)=pizda(1,1)+pizda(2,2)
7598               vv(2)=pizda(2,1)-pizda(1,2)
7599               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7600      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7601      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7602             enddo
7603           enddo
7604         enddo
7605       else
7606 C Antiparallel orientation
7607 C Contribution from graph III
7608 c        goto 1110
7609         call transpose2(EUg(1,1,j),auxmat(1,1))
7610         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7611         vv(1)=pizda(1,1)-pizda(2,2)
7612         vv(2)=pizda(1,2)+pizda(2,1)
7613         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7614      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7615 C Explicit gradient in virtual-dihedral angles.
7616         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7617      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7618      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7619         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7620         vv(1)=pizda(1,1)-pizda(2,2)
7621         vv(2)=pizda(1,2)+pizda(2,1)
7622         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7623      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7624      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7625         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7626         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7627         vv(1)=pizda(1,1)-pizda(2,2)
7628         vv(2)=pizda(1,2)+pizda(2,1)
7629         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7630      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7631      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7632 C Cartesian gradient
7633         do iii=1,2
7634           do kkk=1,5
7635             do lll=1,3
7636               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7637      &          pizda(1,1))
7638               vv(1)=pizda(1,1)-pizda(2,2)
7639               vv(2)=pizda(1,2)+pizda(2,1)
7640               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7641      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7642      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7643             enddo
7644           enddo
7645         enddo
7646 cd        goto 1112
7647 C Contribution from graph IV
7648 1110    continue
7649         call transpose2(EE(1,1,itj),auxmat(1,1))
7650         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7651         vv(1)=pizda(1,1)+pizda(2,2)
7652         vv(2)=pizda(2,1)-pizda(1,2)
7653         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7654      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7655 C Explicit gradient in virtual-dihedral angles.
7656         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7657      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7658         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7659         vv(1)=pizda(1,1)+pizda(2,2)
7660         vv(2)=pizda(2,1)-pizda(1,2)
7661         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7662      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7663      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7664 C Cartesian gradient
7665         do iii=1,2
7666           do kkk=1,5
7667             do lll=1,3
7668               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7669      &          pizda(1,1))
7670               vv(1)=pizda(1,1)+pizda(2,2)
7671               vv(2)=pizda(2,1)-pizda(1,2)
7672               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7673      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7674      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7675             enddo
7676           enddo
7677         enddo
7678       endif
7679 1112  continue
7680       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7681 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7682 cd        write (2,*) 'ijkl',i,j,k,l
7683 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7684 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7685 cd      endif
7686 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7687 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7688 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7689 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7690       if (j.lt.nres-1) then
7691         j1=j+1
7692         j2=j-1
7693       else
7694         j1=j-1
7695         j2=j-2
7696       endif
7697       if (l.lt.nres-1) then
7698         l1=l+1
7699         l2=l-1
7700       else
7701         l1=l-1
7702         l2=l-2
7703       endif
7704 cd      eij=1.0d0
7705 cd      ekl=1.0d0
7706 cd      ekont=1.0d0
7707 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7708 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7709 C        summed up outside the subrouine as for the other subroutines
7710 C        handling long-range interactions. The old code is commented out
7711 C        with "cgrad" to keep track of changes.
7712       do ll=1,3
7713 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7714 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7715         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7716         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7717 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7718 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7719 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7720 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7721 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7722 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7723 c     &   gradcorr5ij,
7724 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7725 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7726 cgrad        ghalf=0.5d0*ggg1(ll)
7727 cd        ghalf=0.0d0
7728         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7729         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7730         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7731         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7732         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7733         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7734 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7735 cgrad        ghalf=0.5d0*ggg2(ll)
7736 cd        ghalf=0.0d0
7737         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7738         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7739         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7740         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7741         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7742         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7743       enddo
7744 cd      goto 1112
7745 cgrad      do m=i+1,j-1
7746 cgrad        do ll=1,3
7747 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7748 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7749 cgrad        enddo
7750 cgrad      enddo
7751 cgrad      do m=k+1,l-1
7752 cgrad        do ll=1,3
7753 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7754 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7755 cgrad        enddo
7756 cgrad      enddo
7757 c1112  continue
7758 cgrad      do m=i+2,j2
7759 cgrad        do ll=1,3
7760 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7761 cgrad        enddo
7762 cgrad      enddo
7763 cgrad      do m=k+2,l2
7764 cgrad        do ll=1,3
7765 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7766 cgrad        enddo
7767 cgrad      enddo
7768 cd      do iii=1,nres-3
7769 cd        write (2,*) iii,g_corr5_loc(iii)
7770 cd      enddo
7771       eello5=ekont*eel5
7772 cd      write (2,*) 'ekont',ekont
7773 cd      write (iout,*) 'eello5',ekont*eel5
7774       return
7775       end
7776 c--------------------------------------------------------------------------
7777       double precision function eello6(i,j,k,l,jj,kk)
7778       implicit real*8 (a-h,o-z)
7779       include 'DIMENSIONS'
7780       include 'COMMON.IOUNITS'
7781       include 'COMMON.CHAIN'
7782       include 'COMMON.DERIV'
7783       include 'COMMON.INTERACT'
7784       include 'COMMON.CONTACTS'
7785       include 'COMMON.TORSION'
7786       include 'COMMON.VAR'
7787       include 'COMMON.GEO'
7788       include 'COMMON.FFIELD'
7789       double precision ggg1(3),ggg2(3)
7790 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7791 cd        eello6=0.0d0
7792 cd        return
7793 cd      endif
7794 cd      write (iout,*)
7795 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7796 cd     &   ' and',k,l
7797       eello6_1=0.0d0
7798       eello6_2=0.0d0
7799       eello6_3=0.0d0
7800       eello6_4=0.0d0
7801       eello6_5=0.0d0
7802       eello6_6=0.0d0
7803 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7804 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7805       do iii=1,2
7806         do kkk=1,5
7807           do lll=1,3
7808             derx(lll,kkk,iii)=0.0d0
7809           enddo
7810         enddo
7811       enddo
7812 cd      eij=facont_hb(jj,i)
7813 cd      ekl=facont_hb(kk,k)
7814 cd      ekont=eij*ekl
7815 cd      eij=1.0d0
7816 cd      ekl=1.0d0
7817 cd      ekont=1.0d0
7818       if (l.eq.j+1) then
7819         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7820         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7821         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7822         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7823         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7824         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7825       else
7826         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7827         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7828         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7829         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7830         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7831           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7832         else
7833           eello6_5=0.0d0
7834         endif
7835         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7836       endif
7837 C If turn contributions are considered, they will be handled separately.
7838       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7839 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
7840 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
7841 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
7842 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
7843 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
7844 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
7845 cd      goto 1112
7846       if (j.lt.nres-1) then
7847         j1=j+1
7848         j2=j-1
7849       else
7850         j1=j-1
7851         j2=j-2
7852       endif
7853       if (l.lt.nres-1) then
7854         l1=l+1
7855         l2=l-1
7856       else
7857         l1=l-1
7858         l2=l-2
7859       endif
7860       do ll=1,3
7861 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
7862 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
7863 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7864 cgrad        ghalf=0.5d0*ggg1(ll)
7865 cd        ghalf=0.0d0
7866         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
7867         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
7868         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
7869         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7870         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
7871         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7872         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
7873         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
7874 cgrad        ghalf=0.5d0*ggg2(ll)
7875 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7876 cd        ghalf=0.0d0
7877         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
7878         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7879         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
7880         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7881         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
7882         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
7883       enddo
7884 cd      goto 1112
7885 cgrad      do m=i+1,j-1
7886 cgrad        do ll=1,3
7887 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7888 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7889 cgrad        enddo
7890 cgrad      enddo
7891 cgrad      do m=k+1,l-1
7892 cgrad        do ll=1,3
7893 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7894 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7895 cgrad        enddo
7896 cgrad      enddo
7897 cgrad1112  continue
7898 cgrad      do m=i+2,j2
7899 cgrad        do ll=1,3
7900 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7901 cgrad        enddo
7902 cgrad      enddo
7903 cgrad      do m=k+2,l2
7904 cgrad        do ll=1,3
7905 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7906 cgrad        enddo
7907 cgrad      enddo
7908 cd      do iii=1,nres-3
7909 cd        write (2,*) iii,g_corr6_loc(iii)
7910 cd      enddo
7911       eello6=ekont*eel6
7912 cd      write (2,*) 'ekont',ekont
7913 cd      write (iout,*) 'eello6',ekont*eel6
7914       return
7915       end
7916 c--------------------------------------------------------------------------
7917       double precision function eello6_graph1(i,j,k,l,imat,swap)
7918       implicit real*8 (a-h,o-z)
7919       include 'DIMENSIONS'
7920       include 'COMMON.IOUNITS'
7921       include 'COMMON.CHAIN'
7922       include 'COMMON.DERIV'
7923       include 'COMMON.INTERACT'
7924       include 'COMMON.CONTACTS'
7925       include 'COMMON.TORSION'
7926       include 'COMMON.VAR'
7927       include 'COMMON.GEO'
7928       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7929       logical swap
7930       logical lprn
7931       common /kutas/ lprn
7932 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7933 C                                                                              C
7934 C      Parallel       Antiparallel                                             C
7935 C                                                                              C
7936 C          o             o                                                     C
7937 C         /l\           /j\                                                    C
7938 C        /   \         /   \                                                   C
7939 C       /| o |         | o |\                                                  C
7940 C     \ j|/k\|  /   \  |/k\|l /                                                C
7941 C      \ /   \ /     \ /   \ /                                                 C
7942 C       o     o       o     o                                                  C
7943 C       i             i                                                        C
7944 C                                                                              C
7945 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7946       itk=itortyp(itype(k))
7947       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7948       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7949       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7950       call transpose2(EUgC(1,1,k),auxmat(1,1))
7951       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7952       vv1(1)=pizda1(1,1)-pizda1(2,2)
7953       vv1(2)=pizda1(1,2)+pizda1(2,1)
7954       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7955       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7956       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7957       s5=scalar2(vv(1),Dtobr2(1,i))
7958 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7959       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7960       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7961      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7962      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7963      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7964      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7965      & +scalar2(vv(1),Dtobr2der(1,i)))
7966       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7967       vv1(1)=pizda1(1,1)-pizda1(2,2)
7968       vv1(2)=pizda1(1,2)+pizda1(2,1)
7969       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7970       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7971       if (l.eq.j+1) then
7972         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7973      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7974      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7975      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7976      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7977       else
7978         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7979      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7980      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7981      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7982      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7983       endif
7984       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7985       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7986       vv1(1)=pizda1(1,1)-pizda1(2,2)
7987       vv1(2)=pizda1(1,2)+pizda1(2,1)
7988       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7989      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7990      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7991      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7992       do iii=1,2
7993         if (swap) then
7994           ind=3-iii
7995         else
7996           ind=iii
7997         endif
7998         do kkk=1,5
7999           do lll=1,3
8000             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8001             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8002             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8003             call transpose2(EUgC(1,1,k),auxmat(1,1))
8004             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8005      &        pizda1(1,1))
8006             vv1(1)=pizda1(1,1)-pizda1(2,2)
8007             vv1(2)=pizda1(1,2)+pizda1(2,1)
8008             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8009             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8010      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8011             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8012      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8013             s5=scalar2(vv(1),Dtobr2(1,i))
8014             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8015           enddo
8016         enddo
8017       enddo
8018       return
8019       end
8020 c----------------------------------------------------------------------------
8021       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8022       implicit real*8 (a-h,o-z)
8023       include 'DIMENSIONS'
8024       include 'COMMON.IOUNITS'
8025       include 'COMMON.CHAIN'
8026       include 'COMMON.DERIV'
8027       include 'COMMON.INTERACT'
8028       include 'COMMON.CONTACTS'
8029       include 'COMMON.TORSION'
8030       include 'COMMON.VAR'
8031       include 'COMMON.GEO'
8032       logical swap
8033       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8034      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8035       logical lprn
8036       common /kutas/ lprn
8037 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8038 C                                                                              C
8039 C      Parallel       Antiparallel                                             C
8040 C                                                                              C
8041 C          o             o                                                     C
8042 C     \   /l\           /j\   /                                                C
8043 C      \ /   \         /   \ /                                                 C
8044 C       o| o |         | o |o                                                  C
8045 C     \ j|/k\|      \  |/k\|l                                                  C
8046 C      \ /   \       \ /   \                                                   C
8047 C       o             o                                                        C
8048 C       i             i                                                        C
8049 C                                                                              C
8050 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8051 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8052 C AL 7/4/01 s1 would occur in the sixth-order moment,
8053 C           but not in a cluster cumulant
8054 #ifdef MOMENT
8055       s1=dip(1,jj,i)*dip(1,kk,k)
8056 #endif
8057       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8058       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8059       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8060       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8061       call transpose2(EUg(1,1,k),auxmat(1,1))
8062       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8063       vv(1)=pizda(1,1)-pizda(2,2)
8064       vv(2)=pizda(1,2)+pizda(2,1)
8065       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8066 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8067 #ifdef MOMENT
8068       eello6_graph2=-(s1+s2+s3+s4)
8069 #else
8070       eello6_graph2=-(s2+s3+s4)
8071 #endif
8072 c      eello6_graph2=-s3
8073 C Derivatives in gamma(i-1)
8074       if (i.gt.1) then
8075 #ifdef MOMENT
8076         s1=dipderg(1,jj,i)*dip(1,kk,k)
8077 #endif
8078         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8079         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8080         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8081         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8082 #ifdef MOMENT
8083         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8084 #else
8085         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8086 #endif
8087 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8088       endif
8089 C Derivatives in gamma(k-1)
8090 #ifdef MOMENT
8091       s1=dip(1,jj,i)*dipderg(1,kk,k)
8092 #endif
8093       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8094       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8095       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8096       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8097       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8098       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8099       vv(1)=pizda(1,1)-pizda(2,2)
8100       vv(2)=pizda(1,2)+pizda(2,1)
8101       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8102 #ifdef MOMENT
8103       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8104 #else
8105       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8106 #endif
8107 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8108 C Derivatives in gamma(j-1) or gamma(l-1)
8109       if (j.gt.1) then
8110 #ifdef MOMENT
8111         s1=dipderg(3,jj,i)*dip(1,kk,k)
8112 #endif
8113         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8114         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8115         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8116         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8117         vv(1)=pizda(1,1)-pizda(2,2)
8118         vv(2)=pizda(1,2)+pizda(2,1)
8119         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8120 #ifdef MOMENT
8121         if (swap) then
8122           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8123         else
8124           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8125         endif
8126 #endif
8127         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8128 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8129       endif
8130 C Derivatives in gamma(l-1) or gamma(j-1)
8131       if (l.gt.1) then
8132 #ifdef MOMENT
8133         s1=dip(1,jj,i)*dipderg(3,kk,k)
8134 #endif
8135         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8136         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8137         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8138         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8139         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8140         vv(1)=pizda(1,1)-pizda(2,2)
8141         vv(2)=pizda(1,2)+pizda(2,1)
8142         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8143 #ifdef MOMENT
8144         if (swap) then
8145           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8146         else
8147           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8148         endif
8149 #endif
8150         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8151 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8152       endif
8153 C Cartesian derivatives.
8154       if (lprn) then
8155         write (2,*) 'In eello6_graph2'
8156         do iii=1,2
8157           write (2,*) 'iii=',iii
8158           do kkk=1,5
8159             write (2,*) 'kkk=',kkk
8160             do jjj=1,2
8161               write (2,'(3(2f10.5),5x)')
8162      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8163             enddo
8164           enddo
8165         enddo
8166       endif
8167       do iii=1,2
8168         do kkk=1,5
8169           do lll=1,3
8170 #ifdef MOMENT
8171             if (iii.eq.1) then
8172               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8173             else
8174               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8175             endif
8176 #endif
8177             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8178      &        auxvec(1))
8179             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8180             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8181      &        auxvec(1))
8182             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8183             call transpose2(EUg(1,1,k),auxmat(1,1))
8184             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8185      &        pizda(1,1))
8186             vv(1)=pizda(1,1)-pizda(2,2)
8187             vv(2)=pizda(1,2)+pizda(2,1)
8188             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8189 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8190 #ifdef MOMENT
8191             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8192 #else
8193             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8194 #endif
8195             if (swap) then
8196               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8197             else
8198               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8199             endif
8200           enddo
8201         enddo
8202       enddo
8203       return
8204       end
8205 c----------------------------------------------------------------------------
8206       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8207       implicit real*8 (a-h,o-z)
8208       include 'DIMENSIONS'
8209       include 'COMMON.IOUNITS'
8210       include 'COMMON.CHAIN'
8211       include 'COMMON.DERIV'
8212       include 'COMMON.INTERACT'
8213       include 'COMMON.CONTACTS'
8214       include 'COMMON.TORSION'
8215       include 'COMMON.VAR'
8216       include 'COMMON.GEO'
8217       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8218       logical swap
8219 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8220 C                                                                              C
8221 C      Parallel       Antiparallel                                             C
8222 C                                                                              C
8223 C          o             o                                                     C
8224 C         /l\   /   \   /j\                                                    C
8225 C        /   \ /     \ /   \                                                   C
8226 C       /| o |o       o| o |\                                                  C
8227 C       j|/k\|  /      |/k\|l /                                                C
8228 C        /   \ /       /   \ /                                                 C
8229 C       /     o       /     o                                                  C
8230 C       i             i                                                        C
8231 C                                                                              C
8232 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8233 C
8234 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8235 C           energy moment and not to the cluster cumulant.
8236       iti=itortyp(itype(i))
8237       if (j.lt.nres-1) then
8238         itj1=itortyp(itype(j+1))
8239       else
8240         itj1=ntortyp+1
8241       endif
8242       itk=itortyp(itype(k))
8243       itk1=itortyp(itype(k+1))
8244       if (l.lt.nres-1) then
8245         itl1=itortyp(itype(l+1))
8246       else
8247         itl1=ntortyp+1
8248       endif
8249 #ifdef MOMENT
8250       s1=dip(4,jj,i)*dip(4,kk,k)
8251 #endif
8252       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8253       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8254       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8255       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8256       call transpose2(EE(1,1,itk),auxmat(1,1))
8257       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8258       vv(1)=pizda(1,1)+pizda(2,2)
8259       vv(2)=pizda(2,1)-pizda(1,2)
8260       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8261 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8262 cd     & "sum",-(s2+s3+s4)
8263 #ifdef MOMENT
8264       eello6_graph3=-(s1+s2+s3+s4)
8265 #else
8266       eello6_graph3=-(s2+s3+s4)
8267 #endif
8268 c      eello6_graph3=-s4
8269 C Derivatives in gamma(k-1)
8270       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8271       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8272       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8273       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8274 C Derivatives in gamma(l-1)
8275       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8276       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8277       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8278       vv(1)=pizda(1,1)+pizda(2,2)
8279       vv(2)=pizda(2,1)-pizda(1,2)
8280       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8281       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8282 C Cartesian derivatives.
8283       do iii=1,2
8284         do kkk=1,5
8285           do lll=1,3
8286 #ifdef MOMENT
8287             if (iii.eq.1) then
8288               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8289             else
8290               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8291             endif
8292 #endif
8293             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8294      &        auxvec(1))
8295             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8296             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8297      &        auxvec(1))
8298             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8299             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8300      &        pizda(1,1))
8301             vv(1)=pizda(1,1)+pizda(2,2)
8302             vv(2)=pizda(2,1)-pizda(1,2)
8303             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8304 #ifdef MOMENT
8305             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8306 #else
8307             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8308 #endif
8309             if (swap) then
8310               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8311             else
8312               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8313             endif
8314 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8315           enddo
8316         enddo
8317       enddo
8318       return
8319       end
8320 c----------------------------------------------------------------------------
8321       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8322       implicit real*8 (a-h,o-z)
8323       include 'DIMENSIONS'
8324       include 'COMMON.IOUNITS'
8325       include 'COMMON.CHAIN'
8326       include 'COMMON.DERIV'
8327       include 'COMMON.INTERACT'
8328       include 'COMMON.CONTACTS'
8329       include 'COMMON.TORSION'
8330       include 'COMMON.VAR'
8331       include 'COMMON.GEO'
8332       include 'COMMON.FFIELD'
8333       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8334      & auxvec1(2),auxmat1(2,2)
8335       logical swap
8336 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8337 C                                                                              C
8338 C      Parallel       Antiparallel                                             C
8339 C                                                                              C
8340 C          o             o                                                     C
8341 C         /l\   /   \   /j\                                                    C
8342 C        /   \ /     \ /   \                                                   C
8343 C       /| o |o       o| o |\                                                  C
8344 C     \ j|/k\|      \  |/k\|l                                                  C
8345 C      \ /   \       \ /   \                                                   C
8346 C       o     \       o     \                                                  C
8347 C       i             i                                                        C
8348 C                                                                              C
8349 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8350 C
8351 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8352 C           energy moment and not to the cluster cumulant.
8353 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8354       iti=itortyp(itype(i))
8355       itj=itortyp(itype(j))
8356       if (j.lt.nres-1) then
8357         itj1=itortyp(itype(j+1))
8358       else
8359         itj1=ntortyp+1
8360       endif
8361       itk=itortyp(itype(k))
8362       if (k.lt.nres-1) then
8363         itk1=itortyp(itype(k+1))
8364       else
8365         itk1=ntortyp+1
8366       endif
8367       itl=itortyp(itype(l))
8368       if (l.lt.nres-1) then
8369         itl1=itortyp(itype(l+1))
8370       else
8371         itl1=ntortyp+1
8372       endif
8373 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8374 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8375 cd     & ' itl',itl,' itl1',itl1
8376 #ifdef MOMENT
8377       if (imat.eq.1) then
8378         s1=dip(3,jj,i)*dip(3,kk,k)
8379       else
8380         s1=dip(2,jj,j)*dip(2,kk,l)
8381       endif
8382 #endif
8383       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8384       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8385       if (j.eq.l+1) then
8386         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8387         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8388       else
8389         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8390         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8391       endif
8392       call transpose2(EUg(1,1,k),auxmat(1,1))
8393       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8394       vv(1)=pizda(1,1)-pizda(2,2)
8395       vv(2)=pizda(2,1)+pizda(1,2)
8396       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8397 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8398 #ifdef MOMENT
8399       eello6_graph4=-(s1+s2+s3+s4)
8400 #else
8401       eello6_graph4=-(s2+s3+s4)
8402 #endif
8403 C Derivatives in gamma(i-1)
8404       if (i.gt.1) then
8405 #ifdef MOMENT
8406         if (imat.eq.1) then
8407           s1=dipderg(2,jj,i)*dip(3,kk,k)
8408         else
8409           s1=dipderg(4,jj,j)*dip(2,kk,l)
8410         endif
8411 #endif
8412         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8413         if (j.eq.l+1) then
8414           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8415           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8416         else
8417           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8418           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8419         endif
8420         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8421         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8422 cd          write (2,*) 'turn6 derivatives'
8423 #ifdef MOMENT
8424           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8425 #else
8426           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8427 #endif
8428         else
8429 #ifdef MOMENT
8430           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8431 #else
8432           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8433 #endif
8434         endif
8435       endif
8436 C Derivatives in gamma(k-1)
8437 #ifdef MOMENT
8438       if (imat.eq.1) then
8439         s1=dip(3,jj,i)*dipderg(2,kk,k)
8440       else
8441         s1=dip(2,jj,j)*dipderg(4,kk,l)
8442       endif
8443 #endif
8444       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8445       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8446       if (j.eq.l+1) then
8447         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8448         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8449       else
8450         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8451         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8452       endif
8453       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8454       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8455       vv(1)=pizda(1,1)-pizda(2,2)
8456       vv(2)=pizda(2,1)+pizda(1,2)
8457       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8458       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8459 #ifdef MOMENT
8460         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8461 #else
8462         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8463 #endif
8464       else
8465 #ifdef MOMENT
8466         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8467 #else
8468         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8469 #endif
8470       endif
8471 C Derivatives in gamma(j-1) or gamma(l-1)
8472       if (l.eq.j+1 .and. l.gt.1) then
8473         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8474         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8475         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8476         vv(1)=pizda(1,1)-pizda(2,2)
8477         vv(2)=pizda(2,1)+pizda(1,2)
8478         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8479         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8480       else if (j.gt.1) then
8481         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8482         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8483         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8484         vv(1)=pizda(1,1)-pizda(2,2)
8485         vv(2)=pizda(2,1)+pizda(1,2)
8486         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8487         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8488           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8489         else
8490           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8491         endif
8492       endif
8493 C Cartesian derivatives.
8494       do iii=1,2
8495         do kkk=1,5
8496           do lll=1,3
8497 #ifdef MOMENT
8498             if (iii.eq.1) then
8499               if (imat.eq.1) then
8500                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8501               else
8502                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8503               endif
8504             else
8505               if (imat.eq.1) then
8506                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8507               else
8508                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8509               endif
8510             endif
8511 #endif
8512             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8513      &        auxvec(1))
8514             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8515             if (j.eq.l+1) then
8516               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8517      &          b1(1,itj1),auxvec(1))
8518               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8519             else
8520               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8521      &          b1(1,itl1),auxvec(1))
8522               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8523             endif
8524             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8525      &        pizda(1,1))
8526             vv(1)=pizda(1,1)-pizda(2,2)
8527             vv(2)=pizda(2,1)+pizda(1,2)
8528             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8529             if (swap) then
8530               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8531 #ifdef MOMENT
8532                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8533      &             -(s1+s2+s4)
8534 #else
8535                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8536      &             -(s2+s4)
8537 #endif
8538                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8539               else
8540 #ifdef MOMENT
8541                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8542 #else
8543                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8544 #endif
8545                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8546               endif
8547             else
8548 #ifdef MOMENT
8549               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8550 #else
8551               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8552 #endif
8553               if (l.eq.j+1) then
8554                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8555               else
8556                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8557               endif
8558             endif
8559           enddo
8560         enddo
8561       enddo
8562       return
8563       end
8564 c----------------------------------------------------------------------------
8565       double precision function eello_turn6(i,jj,kk)
8566       implicit real*8 (a-h,o-z)
8567       include 'DIMENSIONS'
8568       include 'COMMON.IOUNITS'
8569       include 'COMMON.CHAIN'
8570       include 'COMMON.DERIV'
8571       include 'COMMON.INTERACT'
8572       include 'COMMON.CONTACTS'
8573       include 'COMMON.TORSION'
8574       include 'COMMON.VAR'
8575       include 'COMMON.GEO'
8576       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8577      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8578      &  ggg1(3),ggg2(3)
8579       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8580      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8581 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8582 C           the respective energy moment and not to the cluster cumulant.
8583       s1=0.0d0
8584       s8=0.0d0
8585       s13=0.0d0
8586 c
8587       eello_turn6=0.0d0
8588       j=i+4
8589       k=i+1
8590       l=i+3
8591       iti=itortyp(itype(i))
8592       itk=itortyp(itype(k))
8593       itk1=itortyp(itype(k+1))
8594       itl=itortyp(itype(l))
8595       itj=itortyp(itype(j))
8596 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8597 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8598 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8599 cd        eello6=0.0d0
8600 cd        return
8601 cd      endif
8602 cd      write (iout,*)
8603 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8604 cd     &   ' and',k,l
8605 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8606       do iii=1,2
8607         do kkk=1,5
8608           do lll=1,3
8609             derx_turn(lll,kkk,iii)=0.0d0
8610           enddo
8611         enddo
8612       enddo
8613 cd      eij=1.0d0
8614 cd      ekl=1.0d0
8615 cd      ekont=1.0d0
8616       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8617 cd      eello6_5=0.0d0
8618 cd      write (2,*) 'eello6_5',eello6_5
8619 #ifdef MOMENT
8620       call transpose2(AEA(1,1,1),auxmat(1,1))
8621       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8622       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8623       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8624 #endif
8625       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8626       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8627       s2 = scalar2(b1(1,itk),vtemp1(1))
8628 #ifdef MOMENT
8629       call transpose2(AEA(1,1,2),atemp(1,1))
8630       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8631       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8632       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8633 #endif
8634       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8635       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8636       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8637 #ifdef MOMENT
8638       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8639       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8640       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8641       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8642       ss13 = scalar2(b1(1,itk),vtemp4(1))
8643       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8644 #endif
8645 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8646 c      s1=0.0d0
8647 c      s2=0.0d0
8648 c      s8=0.0d0
8649 c      s12=0.0d0
8650 c      s13=0.0d0
8651       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8652 C Derivatives in gamma(i+2)
8653       s1d =0.0d0
8654       s8d =0.0d0
8655 #ifdef MOMENT
8656       call transpose2(AEA(1,1,1),auxmatd(1,1))
8657       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8658       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8659       call transpose2(AEAderg(1,1,2),atempd(1,1))
8660       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8661       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8662 #endif
8663       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8664       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8665       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8666 c      s1d=0.0d0
8667 c      s2d=0.0d0
8668 c      s8d=0.0d0
8669 c      s12d=0.0d0
8670 c      s13d=0.0d0
8671       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8672 C Derivatives in gamma(i+3)
8673 #ifdef MOMENT
8674       call transpose2(AEA(1,1,1),auxmatd(1,1))
8675       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8676       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8677       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8678 #endif
8679       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8680       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8681       s2d = scalar2(b1(1,itk),vtemp1d(1))
8682 #ifdef MOMENT
8683       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8684       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8685 #endif
8686       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8687 #ifdef MOMENT
8688       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8689       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8690       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8691 #endif
8692 c      s1d=0.0d0
8693 c      s2d=0.0d0
8694 c      s8d=0.0d0
8695 c      s12d=0.0d0
8696 c      s13d=0.0d0
8697 #ifdef MOMENT
8698       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8699      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8700 #else
8701       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8702      &               -0.5d0*ekont*(s2d+s12d)
8703 #endif
8704 C Derivatives in gamma(i+4)
8705       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8706       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8707       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8708 #ifdef MOMENT
8709       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8710       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8711       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8712 #endif
8713 c      s1d=0.0d0
8714 c      s2d=0.0d0
8715 c      s8d=0.0d0
8716 C      s12d=0.0d0
8717 c      s13d=0.0d0
8718 #ifdef MOMENT
8719       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8720 #else
8721       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8722 #endif
8723 C Derivatives in gamma(i+5)
8724 #ifdef MOMENT
8725       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8726       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8727       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8728 #endif
8729       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8730       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8731       s2d = scalar2(b1(1,itk),vtemp1d(1))
8732 #ifdef MOMENT
8733       call transpose2(AEA(1,1,2),atempd(1,1))
8734       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8735       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8736 #endif
8737       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8738       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8739 #ifdef MOMENT
8740       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8741       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8742       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8743 #endif
8744 c      s1d=0.0d0
8745 c      s2d=0.0d0
8746 c      s8d=0.0d0
8747 c      s12d=0.0d0
8748 c      s13d=0.0d0
8749 #ifdef MOMENT
8750       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8751      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8752 #else
8753       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8754      &               -0.5d0*ekont*(s2d+s12d)
8755 #endif
8756 C Cartesian derivatives
8757       do iii=1,2
8758         do kkk=1,5
8759           do lll=1,3
8760 #ifdef MOMENT
8761             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8762             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8763             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8764 #endif
8765             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8766             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8767      &          vtemp1d(1))
8768             s2d = scalar2(b1(1,itk),vtemp1d(1))
8769 #ifdef MOMENT
8770             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8771             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8772             s8d = -(atempd(1,1)+atempd(2,2))*
8773      &           scalar2(cc(1,1,itl),vtemp2(1))
8774 #endif
8775             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8776      &           auxmatd(1,1))
8777             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8778             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8779 c      s1d=0.0d0
8780 c      s2d=0.0d0
8781 c      s8d=0.0d0
8782 c      s12d=0.0d0
8783 c      s13d=0.0d0
8784 #ifdef MOMENT
8785             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8786      &        - 0.5d0*(s1d+s2d)
8787 #else
8788             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8789      &        - 0.5d0*s2d
8790 #endif
8791 #ifdef MOMENT
8792             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8793      &        - 0.5d0*(s8d+s12d)
8794 #else
8795             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8796      &        - 0.5d0*s12d
8797 #endif
8798           enddo
8799         enddo
8800       enddo
8801 #ifdef MOMENT
8802       do kkk=1,5
8803         do lll=1,3
8804           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8805      &      achuj_tempd(1,1))
8806           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8807           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8808           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8809           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8810           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8811      &      vtemp4d(1))
8812           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8813           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8814           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8815         enddo
8816       enddo
8817 #endif
8818 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8819 cd     &  16*eel_turn6_num
8820 cd      goto 1112
8821       if (j.lt.nres-1) then
8822         j1=j+1
8823         j2=j-1
8824       else
8825         j1=j-1
8826         j2=j-2
8827       endif
8828       if (l.lt.nres-1) then
8829         l1=l+1
8830         l2=l-1
8831       else
8832         l1=l-1
8833         l2=l-2
8834       endif
8835       do ll=1,3
8836 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
8837 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
8838 cgrad        ghalf=0.5d0*ggg1(ll)
8839 cd        ghalf=0.0d0
8840         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
8841         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
8842         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
8843      &    +ekont*derx_turn(ll,2,1)
8844         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8845         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
8846      &    +ekont*derx_turn(ll,4,1)
8847         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8848         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
8849         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
8850 cgrad        ghalf=0.5d0*ggg2(ll)
8851 cd        ghalf=0.0d0
8852         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
8853      &    +ekont*derx_turn(ll,2,2)
8854         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8855         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
8856      &    +ekont*derx_turn(ll,4,2)
8857         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8858         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
8859         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
8860       enddo
8861 cd      goto 1112
8862 cgrad      do m=i+1,j-1
8863 cgrad        do ll=1,3
8864 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8865 cgrad        enddo
8866 cgrad      enddo
8867 cgrad      do m=k+1,l-1
8868 cgrad        do ll=1,3
8869 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8870 cgrad        enddo
8871 cgrad      enddo
8872 cgrad1112  continue
8873 cgrad      do m=i+2,j2
8874 cgrad        do ll=1,3
8875 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8876 cgrad        enddo
8877 cgrad      enddo
8878 cgrad      do m=k+2,l2
8879 cgrad        do ll=1,3
8880 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8881 cgrad        enddo
8882 cgrad      enddo
8883 cd      do iii=1,nres-3
8884 cd        write (2,*) iii,g_corr6_loc(iii)
8885 cd      enddo
8886       eello_turn6=ekont*eel_turn6
8887 cd      write (2,*) 'ekont',ekont
8888 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8889       return
8890       end
8891
8892 C-----------------------------------------------------------------------------
8893       double precision function scalar(u,v)
8894 !DIR$ INLINEALWAYS scalar
8895 #ifndef OSF
8896 cDEC$ ATTRIBUTES FORCEINLINE::scalar
8897 #endif
8898       implicit none
8899       double precision u(3),v(3)
8900 cd      double precision sc
8901 cd      integer i
8902 cd      sc=0.0d0
8903 cd      do i=1,3
8904 cd        sc=sc+u(i)*v(i)
8905 cd      enddo
8906 cd      scalar=sc
8907
8908       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
8909       return
8910       end
8911 crc-------------------------------------------------
8912       SUBROUTINE MATVEC2(A1,V1,V2)
8913 !DIR$ INLINEALWAYS MATVEC2
8914 #ifndef OSF
8915 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
8916 #endif
8917       implicit real*8 (a-h,o-z)
8918       include 'DIMENSIONS'
8919       DIMENSION A1(2,2),V1(2),V2(2)
8920 c      DO 1 I=1,2
8921 c        VI=0.0
8922 c        DO 3 K=1,2
8923 c    3     VI=VI+A1(I,K)*V1(K)
8924 c        Vaux(I)=VI
8925 c    1 CONTINUE
8926
8927       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8928       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8929
8930       v2(1)=vaux1
8931       v2(2)=vaux2
8932       END
8933 C---------------------------------------
8934       SUBROUTINE MATMAT2(A1,A2,A3)
8935 #ifndef OSF
8936 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
8937 #endif
8938       implicit real*8 (a-h,o-z)
8939       include 'DIMENSIONS'
8940       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8941 c      DIMENSION AI3(2,2)
8942 c        DO  J=1,2
8943 c          A3IJ=0.0
8944 c          DO K=1,2
8945 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8946 c          enddo
8947 c          A3(I,J)=A3IJ
8948 c       enddo
8949 c      enddo
8950
8951       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8952       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8953       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8954       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8955
8956       A3(1,1)=AI3_11
8957       A3(2,1)=AI3_21
8958       A3(1,2)=AI3_12
8959       A3(2,2)=AI3_22
8960       END
8961
8962 c-------------------------------------------------------------------------
8963       double precision function scalar2(u,v)
8964 !DIR$ INLINEALWAYS scalar2
8965       implicit none
8966       double precision u(2),v(2)
8967       double precision sc
8968       integer i
8969       scalar2=u(1)*v(1)+u(2)*v(2)
8970       return
8971       end
8972
8973 C-----------------------------------------------------------------------------
8974
8975       subroutine transpose2(a,at)
8976 !DIR$ INLINEALWAYS transpose2
8977 #ifndef OSF
8978 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
8979 #endif
8980       implicit none
8981       double precision a(2,2),at(2,2)
8982       at(1,1)=a(1,1)
8983       at(1,2)=a(2,1)
8984       at(2,1)=a(1,2)
8985       at(2,2)=a(2,2)
8986       return
8987       end
8988 c--------------------------------------------------------------------------
8989       subroutine transpose(n,a,at)
8990       implicit none
8991       integer n,i,j
8992       double precision a(n,n),at(n,n)
8993       do i=1,n
8994         do j=1,n
8995           at(j,i)=a(i,j)
8996         enddo
8997       enddo
8998       return
8999       end
9000 C---------------------------------------------------------------------------
9001       subroutine prodmat3(a1,a2,kk,transp,prod)
9002 !DIR$ INLINEALWAYS prodmat3
9003 #ifndef OSF
9004 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9005 #endif
9006       implicit none
9007       integer i,j
9008       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9009       logical transp
9010 crc      double precision auxmat(2,2),prod_(2,2)
9011
9012       if (transp) then
9013 crc        call transpose2(kk(1,1),auxmat(1,1))
9014 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9015 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9016
9017            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9018      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9019            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9020      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9021            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9022      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9023            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9024      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9025
9026       else
9027 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9028 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9029
9030            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9031      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9032            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9033      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9034            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9035      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9036            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9037      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9038
9039       endif
9040 c      call transpose2(a2(1,1),a2t(1,1))
9041
9042 crc      print *,transp
9043 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9044 crc      print *,((prod(i,j),i=1,2),j=1,2)
9045
9046       return
9047       end
9048