source/unres/src_MD/energy_p_new_barrier.F

   1       subroutine etotal(energia)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4 #ifndef ISNAN
   5       external proc_proc
   6 #ifdef WINPGI
   7 cMS$ATTRIBUTES C ::  proc_proc
   8 #endif
   9 #endif
  10 #ifdef MPI
  11       include "mpif.h"
  12       double precision weights_(n_ene)
  13 #endif
  14       include 'COMMON.SETUP'
  15       include 'COMMON.IOUNITS'
  16       double precision energia(0:n_ene)
  17       include 'COMMON.LOCAL'
  18       include 'COMMON.FFIELD'
  19       include 'COMMON.DERIV'
  20       include 'COMMON.INTERACT'
  21       include 'COMMON.SBRIDGE'
  22       include 'COMMON.CHAIN'
  23       include 'COMMON.VAR'
  24       include 'COMMON.MD'
  25       include 'COMMON.CONTROL'
  26       include 'COMMON.TIME1'
  27 #ifdef MPI
  28 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  29 c     & " nfgtasks",nfgtasks
  30       if (nfgtasks.gt.1) then
  31 #ifdef MPI
  32         time00=MPI_Wtime()
  33 #else
  34         time00=tcpu()
  35 #endif
  36 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  37         if (fg_rank.eq.0) then
  38           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  39 c          print *,"Processor",myrank," BROADCAST iorder"
  40 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  41 C FG slaves as WEIGHTS array.
  42           weights_(1)=wsc
  43           weights_(2)=wscp
  44           weights_(3)=welec
  45           weights_(4)=wcorr
  46           weights_(5)=wcorr5
  47           weights_(6)=wcorr6
  48           weights_(7)=wel_loc
  49           weights_(8)=wturn3
  50           weights_(9)=wturn4
  51           weights_(10)=wturn6
  52           weights_(11)=wang
  53           weights_(12)=wscloc
  54           weights_(13)=wtor
  55           weights_(14)=wtor_d
  56           weights_(15)=wstrain
  57           weights_(16)=wvdwpp
  58           weights_(17)=wbond
  59           weights_(18)=scal14
  60           weights_(21)=wsccor
  61           weights_(22)=wsct
  62 C FG Master broadcasts the WEIGHTS_ array
  63           call MPI_Bcast(weights_(1),n_ene,
  64      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  65         else
  66 C FG slaves receive the WEIGHTS array
  67           call MPI_Bcast(weights(1),n_ene,
  68      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  69           wsc=weights(1)
  70           wscp=weights(2)
  71           welec=weights(3)
  72           wcorr=weights(4)
  73           wcorr5=weights(5)
  74           wcorr6=weights(6)
  75           wel_loc=weights(7)
  76           wturn3=weights(8)
  77           wturn4=weights(9)
  78           wturn6=weights(10)
  79           wang=weights(11)
  80           wscloc=weights(12)
  81           wtor=weights(13)
  82           wtor_d=weights(14)
  83           wstrain=weights(15)
  84           wvdwpp=weights(16)
  85           wbond=weights(17)
  86           scal14=weights(18)
  87           wsccor=weights(21)
  88           wsct=weights(22)
  89         endif
  90         time_Bcast=time_Bcast+MPI_Wtime()-time00
  91         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  92 c        call chainbuild_cart
  93       endif
  94 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
  95 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  96 #else
  97 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  98 c        call int_from_cart1(.false.)
  99 c      endif
 100 #endif
 101 #ifdef TIMING
 102 #ifdef MPI
 103       time00=MPI_Wtime()
 104 #else
 105       time00=tcpu()
 106 #endif
 107 #endif
 108 C
 109 C Compute the side-chain and electrostatic interaction energy
 110 C
 111       goto (101,102,103,104,105,106) ipot
 112 C Lennard-Jones potential.
 113   101 call elj(evdw,evdw_p,evdw_m)
 114 cd    print '(a)','Exit ELJ'
 115       goto 107
 116 C Lennard-Jones-Kihara potential (shifted).
 117   102 call eljk(evdw,evdw_p,evdw_m)
 118       goto 107
 119 C Berne-Pechukas potential (dilated LJ, angular dependence).
 120   103 call ebp(evdw,evdw_p,evdw_m)
 121       goto 107
 122 C Gay-Berne potential (shifted LJ, angular dependence).
 123   104 call egb(evdw,evdw_p,evdw_m)
 124       goto 107
 125 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 126   105 call egbv(evdw,evdw_p,evdw_m)
 127       goto 107
 128 C Soft-sphere potential
 129   106 call e_softsphere(evdw)
 130 C
 131 C Calculate electrostatic (H-bonding) energy of the main chain.
 132 C
 133   107 continue
 134 cmc
 135 cmc Sep-06: egb takes care of dynamic ss bonds too
 136 cmc
 137       if (dyn_ss) call dyn_set_nss
 138
 139 c      print *,"Processor",myrank," computed USCSC"
 140 #ifdef TIMING
 141 #ifdef MPI
 142       time01=MPI_Wtime()
 143 #else
 144       time00=tcpu()
 145 #endif
 146 #endif
 147       call vec_and_deriv
 148 #ifdef TIMING
 149 #ifdef MPI
 150       time_vec=time_vec+MPI_Wtime()-time01
 151 #else
 152       time_vec=time_vec+tcpu()-time01
 153 #endif
 154 #endif
 155 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 156       if (ipot.lt.6) then
 157 #ifdef SPLITELE
 158          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 159      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 160      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 161      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 162 #else
 163          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 164      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 165      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 166      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 167 #endif
 168             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 169          else
 170             ees=0.0d0
 171             evdw1=0.0d0
 172             eel_loc=0.0d0
 173             eello_turn3=0.0d0
 174             eello_turn4=0.0d0
 175          endif
 176       else
 177 c        write (iout,*) "Soft-spheer ELEC potential"
 178         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 179      &   eello_turn4)
 180       endif
 181 c      print *,"Processor",myrank," computed UELEC"
 182 C
 183 C Calculate excluded-volume interaction energy between peptide groups
 184 C and side chains.
 185 C
 186       if (ipot.lt.6) then
 187        if(wscp.gt.0d0) then
 188         call escp(evdw2,evdw2_14)
 189        else
 190         evdw2=0
 191         evdw2_14=0
 192        endif
 193       else
 194 c        write (iout,*) "Soft-sphere SCP potential"
 195         call escp_soft_sphere(evdw2,evdw2_14)
 196       endif
 197 c
 198 c Calculate the bond-stretching energy
 199 c
 200       call ebond(estr)
 201 C
 202 C Calculate the disulfide-bridge and other energy and the contributions
 203 C from other distance constraints.
 204 cd    print *,'Calling EHPB'
 205       call edis(ehpb)
 206 cd    print *,'EHPB exitted succesfully.'
 207 C
 208 C Calculate the virtual-bond-angle energy.
 209 C
 210       if (wang.gt.0d0) then
 211         call ebend(ebe)
 212       else
 213         ebe=0
 214       endif
 215 c      print *,"Processor",myrank," computed UB"
 216 C
 217 C Calculate the SC local energy.
 218 C
 219       call esc(escloc)
 220 c      print *,"Processor",myrank," computed USC"
 221 C
 222 C Calculate the virtual-bond torsional energy.
 223 C
 224 cd    print *,'nterm=',nterm
 225       if (wtor.gt.0) then
 226        call etor(etors,edihcnstr)
 227       else
 228        etors=0
 229        edihcnstr=0
 230       endif
 231 c      print *,"Processor",myrank," computed Utor"
 232 C
 233 C 6/23/01 Calculate double-torsional energy
 234 C
 235       if (wtor_d.gt.0) then
 236        call etor_d(etors_d)
 237       else
 238        etors_d=0
 239       endif
 240 c      print *,"Processor",myrank," computed Utord"
 241 C
 242 C 21/5/07 Calculate local sicdechain correlation energy
 243 C
 244       if (wsccor.gt.0.0d0) then
 245         call eback_sc_corr(esccor)
 246       else
 247         esccor=0.0d0
 248       endif
 249 c      print *,"Processor",myrank," computed Usccorr"
 250 C
 251 C 12/1/95 Multi-body terms
 252 C
 253       n_corr=0
 254       n_corr1=0
 255       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 256      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 257          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 258 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 259 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 260       else
 261          ecorr=0.0d0
 262          ecorr5=0.0d0
 263          ecorr6=0.0d0
 264          eturn6=0.0d0
 265       endif
 266       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 267          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 268 cd         write (iout,*) "multibody_hb ecorr",ecorr
 269       endif
 270 c      print *,"Processor",myrank," computed Ucorr"
 271 C
 272 C If performing constraint dynamics, call the constraint energy
 273 C  after the equilibration time
 274       if(usampl.and.totT.gt.eq_time) then
 275          call EconstrQ
 276          call Econstr_back
 277       else
 278          Uconst=0.0d0
 279          Uconst_back=0.0d0
 280       endif
 281 #ifdef TIMING
 282 #ifdef MPI
 283       time_enecalc=time_enecalc+MPI_Wtime()-time00
 284 #else
 285       time_enecalc=time_enecalc+tcpu()-time00
 286 #endif
 287 #endif
 288 c      print *,"Processor",myrank," computed Uconstr"
 289 #ifdef TIMING
 290 #ifdef MPI
 291       time00=MPI_Wtime()
 292 #else
 293       time00=tcpu()
 294 #endif
 295 #endif
 296 c
 297 C Sum the energies
 298 C
 299       energia(1)=evdw
 300 #ifdef SCP14
 301       energia(2)=evdw2-evdw2_14
 302       energia(18)=evdw2_14
 303 #else
 304       energia(2)=evdw2
 305       energia(18)=0.0d0
 306 #endif
 307 #ifdef SPLITELE
 308       energia(3)=ees
 309       energia(16)=evdw1
 310 #else
 311       energia(3)=ees+evdw1
 312       energia(16)=0.0d0
 313 #endif
 314       energia(4)=ecorr
 315       energia(5)=ecorr5
 316       energia(6)=ecorr6
 317       energia(7)=eel_loc
 318       energia(8)=eello_turn3
 319       energia(9)=eello_turn4
 320       energia(10)=eturn6
 321       energia(11)=ebe
 322       energia(12)=escloc
 323       energia(13)=etors
 324       energia(14)=etors_d
 325       energia(15)=ehpb
 326       energia(19)=edihcnstr
 327       energia(17)=estr
 328       energia(20)=Uconst+Uconst_back
 329       energia(21)=esccor
 330       energia(22)=evdw_p
 331       energia(23)=evdw_m
 332 c      print *," Processor",myrank," calls SUM_ENERGY"
 333       call sum_energy(energia,.true.)
 334 c      print *," Processor",myrank," left SUM_ENERGY"
 335 #ifdef TIMING
 336 #ifdef MPI
 337       time_sumene=time_sumene+MPI_Wtime()-time00
 338 #else
 339       time_sumene=time_sumene+tcpu()-time00
 340 #endif
 341 #endif
 342       return
 343       end
 344 c-------------------------------------------------------------------------------
 345       subroutine sum_energy(energia,reduce)
 346       implicit real*8 (a-h,o-z)
 347       include 'DIMENSIONS'
 348 #ifndef ISNAN
 349       external proc_proc
 350 #ifdef WINPGI
 351 cMS$ATTRIBUTES C ::  proc_proc
 352 #endif
 353 #endif
 354 #ifdef MPI
 355       include "mpif.h"
 356 #endif
 357       include 'COMMON.SETUP'
 358       include 'COMMON.IOUNITS'
 359       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 360       include 'COMMON.FFIELD'
 361       include 'COMMON.DERIV'
 362       include 'COMMON.INTERACT'
 363       include 'COMMON.SBRIDGE'
 364       include 'COMMON.CHAIN'
 365       include 'COMMON.VAR'
 366       include 'COMMON.CONTROL'
 367       include 'COMMON.TIME1'
 368       logical reduce
 369 #ifdef MPI
 370       if (nfgtasks.gt.1 .and. reduce) then
 371 #ifdef DEBUG
 372         write (iout,*) "energies before REDUCE"
 373         call enerprint(energia)
 374         call flush(iout)
 375 #endif
 376         do i=0,n_ene
 377           enebuff(i)=energia(i)
 378         enddo
 379         time00=MPI_Wtime()
 380         call MPI_Barrier(FG_COMM,IERR)
 381         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 382         time00=MPI_Wtime()
 383         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 384      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 385 #ifdef DEBUG
 386         write (iout,*) "energies after REDUCE"
 387         call enerprint(energia)
 388         call flush(iout)
 389 #endif
 390         time_Reduce=time_Reduce+MPI_Wtime()-time00
 391       endif
 392       if (fg_rank.eq.0) then
 393 #endif
 394 #ifdef TSCSC
 395       evdw=energia(22)+wsct*energia(23)
 396 #else
 397       evdw=energia(1)
 398 #endif
 399 #ifdef SCP14
 400       evdw2=energia(2)+energia(18)
 401       evdw2_14=energia(18)
 402 #else
 403       evdw2=energia(2)
 404 #endif
 405 #ifdef SPLITELE
 406       ees=energia(3)
 407       evdw1=energia(16)
 408 #else
 409       ees=energia(3)
 410       evdw1=0.0d0
 411 #endif
 412       ecorr=energia(4)
 413       ecorr5=energia(5)
 414       ecorr6=energia(6)
 415       eel_loc=energia(7)
 416       eello_turn3=energia(8)
 417       eello_turn4=energia(9)
 418       eturn6=energia(10)
 419       ebe=energia(11)
 420       escloc=energia(12)
 421       etors=energia(13)
 422       etors_d=energia(14)
 423       ehpb=energia(15)
 424       edihcnstr=energia(19)
 425       estr=energia(17)
 426       Uconst=energia(20)
 427       esccor=energia(21)
 428 #ifdef SPLITELE
 429       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 430      & +wang*ebe+wtor*etors+wscloc*escloc
 431      & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5
 432      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 433      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 434      & +wbond*estr+Uconst+wsccor*esccor
 435 #else
 436       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 437      & +wang*ebe+wtor*etors+wscloc*escloc
 438      & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5
 439      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 440      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 441      & +wbond*estr+Uconst+wsccor*esccor
 442 #endif
 443       energia(0)=etot
 444 c detecting NaNQ
 445 #ifdef ISNAN
 446 #ifdef AIX
 447       if (isnan(etot).ne.0) energia(0)=1.0d+99
 448 #else
 449       if (isnan(etot)) energia(0)=1.0d+99
 450 #endif
 451 #else
 452       i=0
 453 #ifdef WINPGI
 454       idumm=proc_proc(etot,i)
 455 #else
 456       call proc_proc(etot,i)
 457 #endif
 458       if(i.eq.1)energia(0)=1.0d+99
 459 #endif
 460 #ifdef MPI
 461       endif
 462 #endif
 463       return
 464       end
 465 c-------------------------------------------------------------------------------
 466       subroutine sum_gradient
 467       implicit real*8 (a-h,o-z)
 468       include 'DIMENSIONS'
 469 #ifndef ISNAN
 470       external proc_proc
 471 #ifdef WINPGI
 472 cMS$ATTRIBUTES C ::  proc_proc
 473 #endif
 474 #endif
 475 #ifdef MPI
 476       include 'mpif.h'
 477 #endif
 478       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 479      &  glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres)
 480       include 'COMMON.SETUP'
 481       include 'COMMON.IOUNITS'
 482       include 'COMMON.FFIELD'
 483       include 'COMMON.DERIV'
 484       include 'COMMON.INTERACT'
 485       include 'COMMON.SBRIDGE'
 486       include 'COMMON.CHAIN'
 487       include 'COMMON.VAR'
 488       include 'COMMON.CONTROL'
 489       include 'COMMON.TIME1'
 490       include 'COMMON.MAXGRAD'
 491       include 'COMMON.SCCOR'
 492 #ifdef TIMING
 493 #ifdef MPI
 494       time01=MPI_Wtime()
 495 #else
 496       time01=tcpu()
 497 #endif
 498 #endif
 499 #ifdef DEBUG
 500       write (iout,*) "sum_gradient gvdwc, gvdwx"
 501       do i=1,nres
 502         write (iout,'(i3,3f10.5,5x,3f10.5,5x,3f10.5,5x,3f10.5)')
 503      &   i,(gvdwx(j,i),j=1,3),(gvdwcT(j,i),j=1,3),(gvdwc(j,i),j=1,3),
 504      &   (gvdwcT(j,i),j=1,3)
 505       enddo
 506       call flush(iout)
 507 #endif
 508 #ifdef MPI
 509 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 510         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 511      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 512 #endif
 513 C
 514 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 515 C            in virtual-bond-vector coordinates
 516 C
 517 #ifdef DEBUG
 518 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 519 c      do i=1,nres-1
 520 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 521 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 522 c      enddo
 523 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 524 c      do i=1,nres-1
 525 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 526 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 527 c      enddo
 528       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 529       do i=1,nres
 530         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 531      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 532      &   g_corr5_loc(i)
 533       enddo
 534       call flush(iout)
 535 #endif
 536 #ifdef SPLITELE
 537 #ifdef TSCSC
 538       do i=1,nct
 539         do j=1,3
 540           gradbufc(j,i)=wsc*gvdwc(j,i)+wsc*wscT*gvdwcT(j,i)+
 541      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 542      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 543      &                wel_loc*gel_loc_long(j,i)+
 544      &                wcorr*gradcorr_long(j,i)+
 545      &                wcorr5*gradcorr5_long(j,i)+
 546      &                wcorr6*gradcorr6_long(j,i)+
 547      &                wturn6*gcorr6_turn_long(j,i)+
 548      &                wstrain*ghpbc(j,i)
 549         enddo
 550       enddo
 551 #else
 552       do i=1,nct
 553         do j=1,3
 554           gradbufc(j,i)=wsc*gvdwc(j,i)+
 555      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 556      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 557      &                wel_loc*gel_loc_long(j,i)+
 558      &                wcorr*gradcorr_long(j,i)+
 559      &                wcorr5*gradcorr5_long(j,i)+
 560      &                wcorr6*gradcorr6_long(j,i)+
 561      &                wturn6*gcorr6_turn_long(j,i)+
 562      &                wstrain*ghpbc(j,i)
 563         enddo
 564       enddo
 565 #endif
 566 #else
 567       do i=1,nct
 568         do j=1,3
 569           gradbufc(j,i)=wsc*gvdwc(j,i)+
 570      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 571      &                welec*gelc_long(j,i)+
 572      &                wbond*gradb(j,i)+
 573      &                wel_loc*gel_loc_long(j,i)+
 574      &                wcorr*gradcorr_long(j,i)+
 575      &                wcorr5*gradcorr5_long(j,i)+
 576      &                wcorr6*gradcorr6_long(j,i)+
 577      &                wturn6*gcorr6_turn_long(j,i)+
 578      &                wstrain*ghpbc(j,i)
 579         enddo
 580       enddo
 581 #endif
 582 #ifdef MPI
 583       if (nfgtasks.gt.1) then
 584       time00=MPI_Wtime()
 585 #ifdef DEBUG
 586       write (iout,*) "gradbufc before allreduce"
 587       do i=1,nres
 588         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 589       enddo
 590       call flush(iout)
 591 #endif
 592       do i=1,nres
 593         do j=1,3
 594           gradbufc_sum(j,i)=gradbufc(j,i)
 595         enddo
 596       enddo
 597 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 598 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 599 c      time_reduce=time_reduce+MPI_Wtime()-time00
 600 #ifdef DEBUG
 601 c      write (iout,*) "gradbufc_sum after allreduce"
 602 c      do i=1,nres
 603 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 604 c      enddo
 605 c      call flush(iout)
 606 #endif
 607 #ifdef TIMING
 608 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 609 #endif
 610       do i=nnt,nres
 611         do k=1,3
 612           gradbufc(k,i)=0.0d0
 613         enddo
 614       enddo
 615 #ifdef DEBUG
 616       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 617       write (iout,*) (i," jgrad_start",jgrad_start(i),
 618      &                  " jgrad_end  ",jgrad_end(i),
 619      &                  i=igrad_start,igrad_end)
 620 #endif
 621 c
 622 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 623 c do not parallelize this part.
 624 c
 625 c      do i=igrad_start,igrad_end
 626 c        do j=jgrad_start(i),jgrad_end(i)
 627 c          do k=1,3
 628 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 629 c          enddo
 630 c        enddo
 631 c      enddo
 632       do j=1,3
 633         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 634       enddo
 635       do i=nres-2,nnt,-1
 636         do j=1,3
 637           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 638         enddo
 639       enddo
 640 #ifdef DEBUG
 641       write (iout,*) "gradbufc after summing"
 642       do i=1,nres
 643         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 644       enddo
 645       call flush(iout)
 646 #endif
 647       else
 648 #endif
 649 #ifdef DEBUG
 650       write (iout,*) "gradbufc"
 651       do i=1,nres
 652         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 653       enddo
 654       call flush(iout)
 655 #endif
 656       do i=1,nres
 657         do j=1,3
 658           gradbufc_sum(j,i)=gradbufc(j,i)
 659           gradbufc(j,i)=0.0d0
 660         enddo
 661       enddo
 662       do j=1,3
 663         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 664       enddo
 665       do i=nres-2,nnt,-1
 666         do j=1,3
 667           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 668         enddo
 669       enddo
 670 c      do i=nnt,nres-1
 671 c        do k=1,3
 672 c          gradbufc(k,i)=0.0d0
 673 c        enddo
 674 c        do j=i+1,nres
 675 c          do k=1,3
 676 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 677 c          enddo
 678 c        enddo
 679 c      enddo
 680 #ifdef DEBUG
 681       write (iout,*) "gradbufc after summing"
 682       do i=1,nres
 683         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 684       enddo
 685       call flush(iout)
 686 #endif
 687 #ifdef MPI
 688       endif
 689 #endif
 690       do k=1,3
 691         gradbufc(k,nres)=0.0d0
 692       enddo
 693       do i=1,nct
 694         do j=1,3
 695 #ifdef SPLITELE
 696           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 697      &                wel_loc*gel_loc(j,i)+
 698      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 699      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 700      &                wel_loc*gel_loc_long(j,i)+
 701      &                wcorr*gradcorr_long(j,i)+
 702      &                wcorr5*gradcorr5_long(j,i)+
 703      &                wcorr6*gradcorr6_long(j,i)+
 704      &                wturn6*gcorr6_turn_long(j,i))+
 705      &                wbond*gradb(j,i)+
 706      &                wcorr*gradcorr(j,i)+
 707      &                wturn3*gcorr3_turn(j,i)+
 708      &                wturn4*gcorr4_turn(j,i)+
 709      &                wcorr5*gradcorr5(j,i)+
 710      &                wcorr6*gradcorr6(j,i)+
 711      &                wturn6*gcorr6_turn(j,i)+
 712      &                wsccor*gsccorc(j,i)
 713      &               +wscloc*gscloc(j,i)
 714 #else
 715           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 716      &                wel_loc*gel_loc(j,i)+
 717      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 718      &                welec*gelc_long(j,i)+
 719      &                wel_loc*gel_loc_long(j,i)+
 720      &                wcorr*gcorr_long(j,i)+
 721      &                wcorr5*gradcorr5_long(j,i)+
 722      &                wcorr6*gradcorr6_long(j,i)+
 723      &                wturn6*gcorr6_turn_long(j,i))+
 724      &                wbond*gradb(j,i)+
 725      &                wcorr*gradcorr(j,i)+
 726      &                wturn3*gcorr3_turn(j,i)+
 727      &                wturn4*gcorr4_turn(j,i)+
 728      &                wcorr5*gradcorr5(j,i)+
 729      &                wcorr6*gradcorr6(j,i)+
 730      &                wturn6*gcorr6_turn(j,i)+
 731      &                wsccor*gsccorc(j,i)
 732      &               +wscloc*gscloc(j,i)
 733 #endif
 734 #ifdef TSCSC
 735           gradx(j,i,icg)=wsc*gvdwx(j,i)+wsc*wscT*gvdwxT(j,i)+
 736      &                  wscp*gradx_scp(j,i)+
 737      &                  wbond*gradbx(j,i)+
 738      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 739      &                  wsccor*gsccorx(j,i)
 740      &                 +wscloc*gsclocx(j,i)
 741 #else
 742           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 743      &                  wbond*gradbx(j,i)+
 744      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 745      &                  wsccor*gsccorx(j,i)
 746      &                 +wscloc*gsclocx(j,i)
 747 #endif
 748         enddo
 749       enddo
 750 #ifdef DEBUG
 751       write (iout,*) "gloc before adding corr"
 752       do i=1,4*nres
 753         write (iout,*) i,gloc(i,icg)
 754       enddo
 755 #endif
 756       do i=1,nres-3
 757         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 758      &   +wcorr5*g_corr5_loc(i)
 759      &   +wcorr6*g_corr6_loc(i)
 760      &   +wturn4*gel_loc_turn4(i)
 761      &   +wturn3*gel_loc_turn3(i)
 762      &   +wturn6*gel_loc_turn6(i)
 763      &   +wel_loc*gel_loc_loc(i)
 764       enddo
 765 #ifdef DEBUG
 766       write (iout,*) "gloc after adding corr"
 767       do i=1,4*nres
 768         write (iout,*) i,gloc(i,icg)
 769       enddo
 770 #endif
 771 #ifdef MPI
 772       if (nfgtasks.gt.1) then
 773         do j=1,3
 774           do i=1,nres
 775             gradbufc(j,i)=gradc(j,i,icg)
 776             gradbufx(j,i)=gradx(j,i,icg)
 777           enddo
 778         enddo
 779         do i=1,4*nres
 780           glocbuf(i)=gloc(i,icg)
 781         enddo
 782 #define DEBUG
 783 #ifdef DEBUG
 784       write (iout,*) "gloc_sc before reduce"
 785       do i=1,nres
 786        do j=1,3
 787         write (iout,*) i,j,gloc_sc(j,i,icg)
 788        enddo
 789       enddo
 790 #endif
 791 #undef DEBUG
 792         do i=1,nres
 793          do j=1,3
 794           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 795          enddo
 796         enddo
 797         time00=MPI_Wtime()
 798         call MPI_Barrier(FG_COMM,IERR)
 799         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 800         time00=MPI_Wtime()
 801         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 802      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 803         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 804      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 805         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 806      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 807         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 808      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 809         time_reduce=time_reduce+MPI_Wtime()-time00
 810 #define DEBUG
 811 #ifdef DEBUG
 812       write (iout,*) "gloc_sc after reduce"
 813       do i=1,nres
 814        do j=1,3
 815         write (iout,*) i,j,gloc_sc(j,i,icg)
 816        enddo
 817       enddo
 818 #endif
 819 #undef DEBUG
 820 #ifdef DEBUG
 821       write (iout,*) "gloc after reduce"
 822       do i=1,4*nres
 823         write (iout,*) i,gloc(i,icg)
 824       enddo
 825 #endif
 826       endif
 827 #endif
 828       if (gnorm_check) then
 829 c
 830 c Compute the maximum elements of the gradient
 831 c
 832       gvdwc_max=0.0d0
 833       gvdwc_scp_max=0.0d0
 834       gelc_max=0.0d0
 835       gvdwpp_max=0.0d0
 836       gradb_max=0.0d0
 837       ghpbc_max=0.0d0
 838       gradcorr_max=0.0d0
 839       gel_loc_max=0.0d0
 840       gcorr3_turn_max=0.0d0
 841       gcorr4_turn_max=0.0d0
 842       gradcorr5_max=0.0d0
 843       gradcorr6_max=0.0d0
 844       gcorr6_turn_max=0.0d0
 845       gsccorc_max=0.0d0
 846       gscloc_max=0.0d0
 847       gvdwx_max=0.0d0
 848       gradx_scp_max=0.0d0
 849       ghpbx_max=0.0d0
 850       gradxorr_max=0.0d0
 851       gsccorx_max=0.0d0
 852       gsclocx_max=0.0d0
 853       do i=1,nct
 854         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 855         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 856 #ifdef TSCSC
 857         gvdwc_norm=dsqrt(scalar(gvdwcT(1,i),gvdwcT(1,i)))
 858         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 859 #endif
 860         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 861         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 862      &   gvdwc_scp_max=gvdwc_scp_norm
 863         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 864         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 865         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 866         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 867         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 868         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 869         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 870         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 871         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 872         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 873         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 874         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 875         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 876      &    gcorr3_turn(1,i)))
 877         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 878      &    gcorr3_turn_max=gcorr3_turn_norm
 879         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 880      &    gcorr4_turn(1,i)))
 881         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 882      &    gcorr4_turn_max=gcorr4_turn_norm
 883         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 884         if (gradcorr5_norm.gt.gradcorr5_max)
 885      &    gradcorr5_max=gradcorr5_norm
 886         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 887         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 888         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 889      &    gcorr6_turn(1,i)))
 890         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 891      &    gcorr6_turn_max=gcorr6_turn_norm
 892         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 893         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 894         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 895         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 896         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 897         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 898 #ifdef TSCSC
 899         gvdwx_norm=dsqrt(scalar(gvdwxT(1,i),gvdwxT(1,i)))
 900         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 901 #endif
 902         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 903         if (gradx_scp_norm.gt.gradx_scp_max)
 904      &    gradx_scp_max=gradx_scp_norm
 905         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 906         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 907         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 908         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 909         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 910         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 911         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 912         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 913       enddo
 914       if (gradout) then
 915 #ifdef AIX
 916         open(istat,file=statname,position="append")
 917 #else
 918         open(istat,file=statname,access="append")
 919 #endif
 920         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 921      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 922      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 923      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 924      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 925      &     gsccorx_max,gsclocx_max
 926         close(istat)
 927         if (gvdwc_max.gt.1.0d4) then
 928           write (iout,*) "gvdwc gvdwx gradb gradbx"
 929           do i=nnt,nct
 930             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 931      &        gradb(j,i),gradbx(j,i),j=1,3)
 932           enddo
 933           call pdbout(0.0d0,'cipiszcze',iout)
 934           call flush(iout)
 935         endif
 936       endif
 937       endif
 938 #ifdef DEBUG
 939       write (iout,*) "gradc gradx gloc"
 940       do i=1,nres
 941         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 942      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 943       enddo
 944 #endif
 945 #ifdef TIMING
 946 #ifdef MPI
 947       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 948 #else
 949       time_sumgradient=time_sumgradient+tcpu()-time01
 950 #endif
 951 #endif
 952       return
 953       end
 954 c-------------------------------------------------------------------------------
 955       subroutine rescale_weights(t_bath)
 956       implicit real*8 (a-h,o-z)
 957       include 'DIMENSIONS'
 958       include 'COMMON.IOUNITS'
 959       include 'COMMON.FFIELD'
 960       include 'COMMON.SBRIDGE'
 961       double precision kfac /2.4d0/
 962       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 963 c      facT=temp0/t_bath
 964 c      facT=2*temp0/(t_bath+temp0)
 965       if (rescale_mode.eq.0) then
 966         facT=1.0d0
 967         facT2=1.0d0
 968         facT3=1.0d0
 969         facT4=1.0d0
 970         facT5=1.0d0
 971       else if (rescale_mode.eq.1) then
 972         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 973         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 974         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 975         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 976         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 977       else if (rescale_mode.eq.2) then
 978         x=t_bath/temp0
 979         x2=x*x
 980         x3=x2*x
 981         x4=x3*x
 982         x5=x4*x
 983         facT=licznik/dlog(dexp(x)+dexp(-x))
 984         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 985         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 986         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 987         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 988       else
 989         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 990         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 991 #ifdef MPI
 992        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 993 #endif
 994        stop 555
 995       endif
 996       welec=weights(3)*fact
 997       wcorr=weights(4)*fact3
 998       wcorr5=weights(5)*fact4
 999       wcorr6=weights(6)*fact5
1000       wel_loc=weights(7)*fact2
1001       wturn3=weights(8)*fact2
1002       wturn4=weights(9)*fact3
1003       wturn6=weights(10)*fact5
1004       wtor=weights(13)*fact
1005       wtor_d=weights(14)*fact2
1006       wsccor=weights(21)*fact
1007 #ifdef TSCSC
1008 c      wsct=t_bath/temp0
1009       wsct=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
1010 #endif
1011       return
1012       end
1013 C------------------------------------------------------------------------
1014       subroutine enerprint(energia)
1015       implicit real*8 (a-h,o-z)
1016       include 'DIMENSIONS'
1017       include 'COMMON.IOUNITS'
1018       include 'COMMON.FFIELD'
1019       include 'COMMON.SBRIDGE'
1020       include 'COMMON.MD'
1021       double precision energia(0:n_ene)
1022       etot=energia(0)
1023 #ifdef TSCSC
1024       evdw=energia(22)+wsct*energia(23)
1025 #else
1026       evdw=energia(1)
1027 #endif
1028       evdw2=energia(2)
1029 #ifdef SCP14
1030       evdw2=energia(2)+energia(18)
1031 #else
1032       evdw2=energia(2)
1033 #endif
1034       ees=energia(3)
1035 #ifdef SPLITELE
1036       evdw1=energia(16)
1037 #endif
1038       ecorr=energia(4)
1039       ecorr5=energia(5)
1040       ecorr6=energia(6)
1041       eel_loc=energia(7)
1042       eello_turn3=energia(8)
1043       eello_turn4=energia(9)
1044       eello_turn6=energia(10)
1045       ebe=energia(11)
1046       escloc=energia(12)
1047       etors=energia(13)
1048       etors_d=energia(14)
1049       ehpb=energia(15)
1050       edihcnstr=energia(19)
1051       estr=energia(17)
1052       Uconst=energia(20)
1053       esccor=energia(21)
1054 #ifdef SPLITELE
1055       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1056      &  estr,wbond,ebe,wang,
1057      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1058      &  ecorr,wcorr,
1059      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1060      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
1061      &  edihcnstr,ebr*nss,
1062      &  Uconst,etot
1063    10 format (/'Virtual-chain energies:'//
1064      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1065      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1066      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1067      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
1068      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1069      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1070      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1071      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1072      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1073      & 'EHPB=  ',1pE16.6,' WEIGHT=',1pD16.6,
1074      & ' (SS bridges & dist. cnstr.)'/
1075      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1076      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1077      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1078      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1079      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1080      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1081      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1082      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1083      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1084      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1085      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1086      & 'ETOT=  ',1pE16.6,' (total)')
1087 #else
1088       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1089      &  estr,wbond,ebe,wang,
1090      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1091      &  ecorr,wcorr,
1092      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1093      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1094      &  ebr*nss,Uconst,etot
1095    10 format (/'Virtual-chain energies:'//
1096      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1097      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1098      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1099      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1100      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1101      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1102      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1103      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1104      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1105      & ' (SS bridges & dist. cnstr.)'/
1106      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1107      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1108      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1109      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1110      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1111      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1112      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1113      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1114      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1115      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1116      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1117      & 'ETOT=  ',1pE16.6,' (total)')
1118 #endif
1119       return
1120       end
1121 C-----------------------------------------------------------------------
1122       subroutine elj(evdw,evdw_p,evdw_m)
1123 C
1124 C This subroutine calculates the interaction energy of nonbonded side chains
1125 C assuming the LJ potential of interaction.
1126 C
1127       implicit real*8 (a-h,o-z)
1128       include 'DIMENSIONS'
1129       parameter (accur=1.0d-10)
1130       include 'COMMON.GEO'
1131       include 'COMMON.VAR'
1132       include 'COMMON.LOCAL'
1133       include 'COMMON.CHAIN'
1134       include 'COMMON.DERIV'
1135       include 'COMMON.INTERACT'
1136       include 'COMMON.TORSION'
1137       include 'COMMON.SBRIDGE'
1138       include 'COMMON.NAMES'
1139       include 'COMMON.IOUNITS'
1140       include 'COMMON.CONTACTS'
1141       dimension gg(3)
1142 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1143       evdw=0.0D0
1144       do i=iatsc_s,iatsc_e
1145         itypi=itype(i)
1146         itypi1=itype(i+1)
1147         xi=c(1,nres+i)
1148         yi=c(2,nres+i)
1149         zi=c(3,nres+i)
1150 C Change 12/1/95
1151         num_conti=0
1152 C
1153 C Calculate SC interaction energy.
1154 C
1155         do iint=1,nint_gr(i)
1156 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1157 cd   &                  'iend=',iend(i,iint)
1158           do j=istart(i,iint),iend(i,iint)
1159             itypj=itype(j)
1160             xj=c(1,nres+j)-xi
1161             yj=c(2,nres+j)-yi
1162             zj=c(3,nres+j)-zi
1163 C Change 12/1/95 to calculate four-body interactions
1164             rij=xj*xj+yj*yj+zj*zj
1165             rrij=1.0D0/rij
1166 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1167             eps0ij=eps(itypi,itypj)
1168             fac=rrij**expon2
1169             e1=fac*fac*aa(itypi,itypj)
1170             e2=fac*bb(itypi,itypj)
1171             evdwij=e1+e2
1172 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1173 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1174 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1175 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1176 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1177 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1178 #ifdef TSCSC
1179             if (bb(itypi,itypj).gt.0) then
1180                evdw_p=evdw_p+evdwij
1181             else
1182                evdw_m=evdw_m+evdwij
1183             endif
1184 #else
1185             evdw=evdw+evdwij
1186 #endif
1187 C
1188 C Calculate the components of the gradient in DC and X
1189 C
1190             fac=-rrij*(e1+evdwij)
1191             gg(1)=xj*fac
1192             gg(2)=yj*fac
1193             gg(3)=zj*fac
1194 #ifdef TSCSC
1195             if (bb(itypi,itypj).gt.0.0d0) then
1196               do k=1,3
1197                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1198                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1199                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1200                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1201               enddo
1202             else
1203               do k=1,3
1204                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1205                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1206                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1207                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1208               enddo
1209             endif
1210 #else
1211             do k=1,3
1212               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1213               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1214               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1215               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1216             enddo
1217 #endif
1218 cgrad            do k=i,j-1
1219 cgrad              do l=1,3
1220 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1221 cgrad              enddo
1222 cgrad            enddo
1223 C
1224 C 12/1/95, revised on 5/20/97
1225 C
1226 C Calculate the contact function. The ith column of the array JCONT will
1227 C contain the numbers of atoms that make contacts with the atom I (of numbers
1228 C greater than I). The arrays FACONT and GACONT will contain the values of
1229 C the contact function and its derivative.
1230 C
1231 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1232 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1233 C Uncomment next line, if the correlation interactions are contact function only
1234             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1235               rij=dsqrt(rij)
1236               sigij=sigma(itypi,itypj)
1237               r0ij=rs0(itypi,itypj)
1238 C
1239 C Check whether the SC's are not too far to make a contact.
1240 C
1241               rcut=1.5d0*r0ij
1242               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1243 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1244 C
1245               if (fcont.gt.0.0D0) then
1246 C If the SC-SC distance if close to sigma, apply spline.
1247 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1248 cAdam &             fcont1,fprimcont1)
1249 cAdam           fcont1=1.0d0-fcont1
1250 cAdam           if (fcont1.gt.0.0d0) then
1251 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1252 cAdam             fcont=fcont*fcont1
1253 cAdam           endif
1254 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1255 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1256 cga             do k=1,3
1257 cga               gg(k)=gg(k)*eps0ij
1258 cga             enddo
1259 cga             eps0ij=-evdwij*eps0ij
1260 C Uncomment for AL's type of SC correlation interactions.
1261 cadam           eps0ij=-evdwij
1262                 num_conti=num_conti+1
1263                 jcont(num_conti,i)=j
1264                 facont(num_conti,i)=fcont*eps0ij
1265                 fprimcont=eps0ij*fprimcont/rij
1266                 fcont=expon*fcont
1267 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1268 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1269 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1270 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1271                 gacont(1,num_conti,i)=-fprimcont*xj
1272                 gacont(2,num_conti,i)=-fprimcont*yj
1273                 gacont(3,num_conti,i)=-fprimcont*zj
1274 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1275 cd              write (iout,'(2i3,3f10.5)')
1276 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1277               endif
1278             endif
1279           enddo      ! j
1280         enddo        ! iint
1281 C Change 12/1/95
1282         num_cont(i)=num_conti
1283       enddo          ! i
1284       do i=1,nct
1285         do j=1,3
1286           gvdwc(j,i)=expon*gvdwc(j,i)
1287           gvdwx(j,i)=expon*gvdwx(j,i)
1288         enddo
1289       enddo
1290 C******************************************************************************
1291 C
1292 C                              N O T E !!!
1293 C
1294 C To save time, the factor of EXPON has been extracted from ALL components
1295 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1296 C use!
1297 C
1298 C******************************************************************************
1299       return
1300       end
1301 C-----------------------------------------------------------------------------
1302       subroutine eljk(evdw,evdw_p,evdw_m)
1303 C
1304 C This subroutine calculates the interaction energy of nonbonded side chains
1305 C assuming the LJK potential of interaction.
1306 C
1307       implicit real*8 (a-h,o-z)
1308       include 'DIMENSIONS'
1309       include 'COMMON.GEO'
1310       include 'COMMON.VAR'
1311       include 'COMMON.LOCAL'
1312       include 'COMMON.CHAIN'
1313       include 'COMMON.DERIV'
1314       include 'COMMON.INTERACT'
1315       include 'COMMON.IOUNITS'
1316       include 'COMMON.NAMES'
1317       dimension gg(3)
1318       logical scheck
1319 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1320       evdw=0.0D0
1321       do i=iatsc_s,iatsc_e
1322         itypi=itype(i)
1323         itypi1=itype(i+1)
1324         xi=c(1,nres+i)
1325         yi=c(2,nres+i)
1326         zi=c(3,nres+i)
1327 C
1328 C Calculate SC interaction energy.
1329 C
1330         do iint=1,nint_gr(i)
1331           do j=istart(i,iint),iend(i,iint)
1332             itypj=itype(j)
1333             xj=c(1,nres+j)-xi
1334             yj=c(2,nres+j)-yi
1335             zj=c(3,nres+j)-zi
1336             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1337             fac_augm=rrij**expon
1338             e_augm=augm(itypi,itypj)*fac_augm
1339             r_inv_ij=dsqrt(rrij)
1340             rij=1.0D0/r_inv_ij
1341             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1342             fac=r_shift_inv**expon
1343             e1=fac*fac*aa(itypi,itypj)
1344             e2=fac*bb(itypi,itypj)
1345             evdwij=e_augm+e1+e2
1346 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1347 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1348 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1349 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1350 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1351 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1352 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1353 #ifdef TSCSC
1354             if (bb(itypi,itypj).gt.0) then
1355                evdw_p=evdw_p+evdwij
1356             else
1357                evdw_m=evdw_m+evdwij
1358             endif
1359 #else
1360             evdw=evdw+evdwij
1361 #endif
1362 C
1363 C Calculate the components of the gradient in DC and X
1364 C
1365             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1366             gg(1)=xj*fac
1367             gg(2)=yj*fac
1368             gg(3)=zj*fac
1369 #ifdef TSCSC
1370             if (bb(itypi,itypj).gt.0.0d0) then
1371               do k=1,3
1372                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1373                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1374                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1375                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1376               enddo
1377             else
1378               do k=1,3
1379                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1380                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1381                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1382                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1383               enddo
1384             endif
1385 #else
1386             do k=1,3
1387               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1388               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1389               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1390               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1391             enddo
1392 #endif
1393 cgrad            do k=i,j-1
1394 cgrad              do l=1,3
1395 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1396 cgrad              enddo
1397 cgrad            enddo
1398           enddo      ! j
1399         enddo        ! iint
1400       enddo          ! i
1401       do i=1,nct
1402         do j=1,3
1403           gvdwc(j,i)=expon*gvdwc(j,i)
1404           gvdwx(j,i)=expon*gvdwx(j,i)
1405         enddo
1406       enddo
1407       return
1408       end
1409 C-----------------------------------------------------------------------------
1410       subroutine ebp(evdw,evdw_p,evdw_m)
1411 C
1412 C This subroutine calculates the interaction energy of nonbonded side chains
1413 C assuming the Berne-Pechukas potential of interaction.
1414 C
1415       implicit real*8 (a-h,o-z)
1416       include 'DIMENSIONS'
1417       include 'COMMON.GEO'
1418       include 'COMMON.VAR'
1419       include 'COMMON.LOCAL'
1420       include 'COMMON.CHAIN'
1421       include 'COMMON.DERIV'
1422       include 'COMMON.NAMES'
1423       include 'COMMON.INTERACT'
1424       include 'COMMON.IOUNITS'
1425       include 'COMMON.CALC'
1426       common /srutu/ icall
1427 c     double precision rrsave(maxdim)
1428       logical lprn
1429       evdw=0.0D0
1430 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1431       evdw=0.0D0
1432 c     if (icall.eq.0) then
1433 c       lprn=.true.
1434 c     else
1435         lprn=.false.
1436 c     endif
1437       ind=0
1438       do i=iatsc_s,iatsc_e
1439         itypi=itype(i)
1440         itypi1=itype(i+1)
1441         xi=c(1,nres+i)
1442         yi=c(2,nres+i)
1443         zi=c(3,nres+i)
1444         dxi=dc_norm(1,nres+i)
1445         dyi=dc_norm(2,nres+i)
1446         dzi=dc_norm(3,nres+i)
1447 c        dsci_inv=dsc_inv(itypi)
1448         dsci_inv=vbld_inv(i+nres)
1449 C
1450 C Calculate SC interaction energy.
1451 C
1452         do iint=1,nint_gr(i)
1453           do j=istart(i,iint),iend(i,iint)
1454             ind=ind+1
1455             itypj=itype(j)
1456 c            dscj_inv=dsc_inv(itypj)
1457             dscj_inv=vbld_inv(j+nres)
1458             chi1=chi(itypi,itypj)
1459             chi2=chi(itypj,itypi)
1460             chi12=chi1*chi2
1461             chip1=chip(itypi)
1462             chip2=chip(itypj)
1463             chip12=chip1*chip2
1464             alf1=alp(itypi)
1465             alf2=alp(itypj)
1466             alf12=0.5D0*(alf1+alf2)
1467 C For diagnostics only!!!
1468 c           chi1=0.0D0
1469 c           chi2=0.0D0
1470 c           chi12=0.0D0
1471 c           chip1=0.0D0
1472 c           chip2=0.0D0
1473 c           chip12=0.0D0
1474 c           alf1=0.0D0
1475 c           alf2=0.0D0
1476 c           alf12=0.0D0
1477             xj=c(1,nres+j)-xi
1478             yj=c(2,nres+j)-yi
1479             zj=c(3,nres+j)-zi
1480             dxj=dc_norm(1,nres+j)
1481             dyj=dc_norm(2,nres+j)
1482             dzj=dc_norm(3,nres+j)
1483             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1484 cd          if (icall.eq.0) then
1485 cd            rrsave(ind)=rrij
1486 cd          else
1487 cd            rrij=rrsave(ind)
1488 cd          endif
1489             rij=dsqrt(rrij)
1490 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1491             call sc_angular
1492 C Calculate whole angle-dependent part of epsilon and contributions
1493 C to its derivatives
1494             fac=(rrij*sigsq)**expon2
1495             e1=fac*fac*aa(itypi,itypj)
1496             e2=fac*bb(itypi,itypj)
1497             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1498             eps2der=evdwij*eps3rt
1499             eps3der=evdwij*eps2rt
1500             evdwij=evdwij*eps2rt*eps3rt
1501 #ifdef TSCSC
1502             if (bb(itypi,itypj).gt.0) then
1503                evdw_p=evdw_p+evdwij
1504             else
1505                evdw_m=evdw_m+evdwij
1506             endif
1507 #else
1508             evdw=evdw+evdwij
1509 #endif
1510             if (lprn) then
1511             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1512             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1513 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1514 cd     &        restyp(itypi),i,restyp(itypj),j,
1515 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1516 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1517 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1518 cd     &        evdwij
1519             endif
1520 C Calculate gradient components.
1521             e1=e1*eps1*eps2rt**2*eps3rt**2
1522             fac=-expon*(e1+evdwij)
1523             sigder=fac/sigsq
1524             fac=rrij*fac
1525 C Calculate radial part of the gradient
1526             gg(1)=xj*fac
1527             gg(2)=yj*fac
1528             gg(3)=zj*fac
1529 C Calculate the angular part of the gradient and sum add the contributions
1530 C to the appropriate components of the Cartesian gradient.
1531 #ifdef TSCSC
1532             if (bb(itypi,itypj).gt.0) then
1533                call sc_grad
1534             else
1535                call sc_grad_T
1536             endif
1537 #else
1538             call sc_grad
1539 #endif
1540           enddo      ! j
1541         enddo        ! iint
1542       enddo          ! i
1543 c     stop
1544       return
1545       end
1546 C-----------------------------------------------------------------------------
1547       subroutine egb(evdw,evdw_p,evdw_m)
1548 C
1549 C This subroutine calculates the interaction energy of nonbonded side chains
1550 C assuming the Gay-Berne potential of interaction.
1551 C
1552       implicit real*8 (a-h,o-z)
1553       include 'DIMENSIONS'
1554       include 'COMMON.GEO'
1555       include 'COMMON.VAR'
1556       include 'COMMON.LOCAL'
1557       include 'COMMON.CHAIN'
1558       include 'COMMON.DERIV'
1559       include 'COMMON.NAMES'
1560       include 'COMMON.INTERACT'
1561       include 'COMMON.IOUNITS'
1562       include 'COMMON.CALC'
1563       include 'COMMON.CONTROL'
1564       include 'COMMON.SBRIDGE'
1565       logical lprn
1566       evdw=0.0D0
1567 ccccc      energy_dec=.false.
1568 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1569       evdw=0.0D0
1570       evdw_p=0.0D0
1571       evdw_m=0.0D0
1572       lprn=.false.
1573 c     if (icall.eq.0) lprn=.false.
1574       ind=0
1575       do i=iatsc_s,iatsc_e
1576         itypi=itype(i)
1577         itypi1=itype(i+1)
1578         xi=c(1,nres+i)
1579         yi=c(2,nres+i)
1580         zi=c(3,nres+i)
1581         dxi=dc_norm(1,nres+i)
1582         dyi=dc_norm(2,nres+i)
1583         dzi=dc_norm(3,nres+i)
1584 c        dsci_inv=dsc_inv(itypi)
1585         dsci_inv=vbld_inv(i+nres)
1586 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1587 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1588 C
1589 C Calculate SC interaction energy.
1590 C
1591         do iint=1,nint_gr(i)
1592           do j=istart(i,iint),iend(i,iint)
1593             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1594               call dyn_ssbond_ene(i,j,evdwij)
1595               evdw=evdw+evdwij
1596             ELSE
1597             ind=ind+1
1598             itypj=itype(j)
1599 c            dscj_inv=dsc_inv(itypj)
1600             dscj_inv=vbld_inv(j+nres)
1601 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1602 c     &       1.0d0/vbld(j+nres)
1603 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1604             sig0ij=sigma(itypi,itypj)
1605             chi1=chi(itypi,itypj)
1606             chi2=chi(itypj,itypi)
1607             chi12=chi1*chi2
1608             chip1=chip(itypi)
1609             chip2=chip(itypj)
1610             chip12=chip1*chip2
1611             alf1=alp(itypi)
1612             alf2=alp(itypj)
1613             alf12=0.5D0*(alf1+alf2)
1614 C For diagnostics only!!!
1615 c           chi1=0.0D0
1616 c           chi2=0.0D0
1617 c           chi12=0.0D0
1618 c           chip1=0.0D0
1619 c           chip2=0.0D0
1620 c           chip12=0.0D0
1621 c           alf1=0.0D0
1622 c           alf2=0.0D0
1623 c           alf12=0.0D0
1624             xj=c(1,nres+j)-xi
1625             yj=c(2,nres+j)-yi
1626             zj=c(3,nres+j)-zi
1627             dxj=dc_norm(1,nres+j)
1628             dyj=dc_norm(2,nres+j)
1629             dzj=dc_norm(3,nres+j)
1630 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1631 c            write (iout,*) "j",j," dc_norm",
1632 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1633             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1634             rij=dsqrt(rrij)
1635 C Calculate angle-dependent terms of energy and contributions to their
1636 C derivatives.
1637             call sc_angular
1638             sigsq=1.0D0/sigsq
1639             sig=sig0ij*dsqrt(sigsq)
1640             rij_shift=1.0D0/rij-sig+sig0ij
1641 c for diagnostics; uncomment
1642 c            rij_shift=1.2*sig0ij
1643 C I hate to put IF's in the loops, but here don't have another choice!!!!
1644             if (rij_shift.le.0.0D0) then
1645               evdw=1.0D20
1646 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1647 cd     &        restyp(itypi),i,restyp(itypj),j,
1648 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1649               return
1650             endif
1651             sigder=-sig*sigsq
1652 c---------------------------------------------------------------
1653             rij_shift=1.0D0/rij_shift
1654             fac=rij_shift**expon
1655             e1=fac*fac*aa(itypi,itypj)
1656             e2=fac*bb(itypi,itypj)
1657             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1658             eps2der=evdwij*eps3rt
1659             eps3der=evdwij*eps2rt
1660 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1661 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1662             evdwij=evdwij*eps2rt*eps3rt
1663 #ifdef TSCSC
1664             if (bb(itypi,itypj).gt.0) then
1665                evdw_p=evdw_p+evdwij
1666             else
1667                evdw_m=evdw_m+evdwij
1668             endif
1669 #else
1670             evdw=evdw+evdwij
1671 #endif
1672             if (lprn) then
1673             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1674             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1675             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1676      &        restyp(itypi),i,restyp(itypj),j,
1677      &        epsi,sigm,chi1,chi2,chip1,chip2,
1678      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1679      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1680      &        evdwij
1681             endif
1682
1683             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1684      &                        'evdw',i,j,evdwij
1685
1686 C Calculate gradient components.
1687             e1=e1*eps1*eps2rt**2*eps3rt**2
1688             fac=-expon*(e1+evdwij)*rij_shift
1689             sigder=fac*sigder
1690             fac=rij*fac
1691 c            fac=0.0d0
1692 C Calculate the radial part of the gradient
1693             gg(1)=xj*fac
1694             gg(2)=yj*fac
1695             gg(3)=zj*fac
1696 C Calculate angular part of the gradient.
1697 #ifdef TSCSC
1698             if (bb(itypi,itypj).gt.0) then
1699                call sc_grad
1700             else
1701                call sc_grad_T
1702             endif
1703 #else
1704             call sc_grad
1705 #endif
1706             ENDIF    ! dyn_ss
1707           enddo      ! j
1708         enddo        ! iint
1709       enddo          ! i
1710 c      write (iout,*) "Number of loop steps in EGB:",ind
1711 cccc      energy_dec=.false.
1712       return
1713       end
1714 C-----------------------------------------------------------------------------
1715       subroutine egbv(evdw,evdw_p,evdw_m)
1716 C
1717 C This subroutine calculates the interaction energy of nonbonded side chains
1718 C assuming the Gay-Berne-Vorobjev potential of interaction.
1719 C
1720       implicit real*8 (a-h,o-z)
1721       include 'DIMENSIONS'
1722       include 'COMMON.GEO'
1723       include 'COMMON.VAR'
1724       include 'COMMON.LOCAL'
1725       include 'COMMON.CHAIN'
1726       include 'COMMON.DERIV'
1727       include 'COMMON.NAMES'
1728       include 'COMMON.INTERACT'
1729       include 'COMMON.IOUNITS'
1730       include 'COMMON.CALC'
1731       common /srutu/ icall
1732       logical lprn
1733       evdw=0.0D0
1734 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1735       evdw=0.0D0
1736       lprn=.false.
1737 c     if (icall.eq.0) lprn=.true.
1738       ind=0
1739       do i=iatsc_s,iatsc_e
1740         itypi=itype(i)
1741         itypi1=itype(i+1)
1742         xi=c(1,nres+i)
1743         yi=c(2,nres+i)
1744         zi=c(3,nres+i)
1745         dxi=dc_norm(1,nres+i)
1746         dyi=dc_norm(2,nres+i)
1747         dzi=dc_norm(3,nres+i)
1748 c        dsci_inv=dsc_inv(itypi)
1749         dsci_inv=vbld_inv(i+nres)
1750 C
1751 C Calculate SC interaction energy.
1752 C
1753         do iint=1,nint_gr(i)
1754           do j=istart(i,iint),iend(i,iint)
1755             ind=ind+1
1756             itypj=itype(j)
1757 c            dscj_inv=dsc_inv(itypj)
1758             dscj_inv=vbld_inv(j+nres)
1759             sig0ij=sigma(itypi,itypj)
1760             r0ij=r0(itypi,itypj)
1761             chi1=chi(itypi,itypj)
1762             chi2=chi(itypj,itypi)
1763             chi12=chi1*chi2
1764             chip1=chip(itypi)
1765             chip2=chip(itypj)
1766             chip12=chip1*chip2
1767             alf1=alp(itypi)
1768             alf2=alp(itypj)
1769             alf12=0.5D0*(alf1+alf2)
1770 C For diagnostics only!!!
1771 c           chi1=0.0D0
1772 c           chi2=0.0D0
1773 c           chi12=0.0D0
1774 c           chip1=0.0D0
1775 c           chip2=0.0D0
1776 c           chip12=0.0D0
1777 c           alf1=0.0D0
1778 c           alf2=0.0D0
1779 c           alf12=0.0D0
1780             xj=c(1,nres+j)-xi
1781             yj=c(2,nres+j)-yi
1782             zj=c(3,nres+j)-zi
1783             dxj=dc_norm(1,nres+j)
1784             dyj=dc_norm(2,nres+j)
1785             dzj=dc_norm(3,nres+j)
1786             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1787             rij=dsqrt(rrij)
1788 C Calculate angle-dependent terms of energy and contributions to their
1789 C derivatives.
1790             call sc_angular
1791             sigsq=1.0D0/sigsq
1792             sig=sig0ij*dsqrt(sigsq)
1793             rij_shift=1.0D0/rij-sig+r0ij
1794 C I hate to put IF's in the loops, but here don't have another choice!!!!
1795             if (rij_shift.le.0.0D0) then
1796               evdw=1.0D20
1797               return
1798             endif
1799             sigder=-sig*sigsq
1800 c---------------------------------------------------------------
1801             rij_shift=1.0D0/rij_shift
1802             fac=rij_shift**expon
1803             e1=fac*fac*aa(itypi,itypj)
1804             e2=fac*bb(itypi,itypj)
1805             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1806             eps2der=evdwij*eps3rt
1807             eps3der=evdwij*eps2rt
1808             fac_augm=rrij**expon
1809             e_augm=augm(itypi,itypj)*fac_augm
1810             evdwij=evdwij*eps2rt*eps3rt
1811 #ifdef TSCSC
1812             if (bb(itypi,itypj).gt.0) then
1813                evdw_p=evdw_p+evdwij+e_augm
1814             else
1815                evdw_m=evdw_m+evdwij+e_augm
1816             endif
1817 #else
1818             evdw=evdw+evdwij+e_augm
1819 #endif
1820             if (lprn) then
1821             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1822             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1823             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1824      &        restyp(itypi),i,restyp(itypj),j,
1825      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1826      &        chi1,chi2,chip1,chip2,
1827      &        eps1,eps2rt**2,eps3rt**2,
1828      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1829      &        evdwij+e_augm
1830             endif
1831 C Calculate gradient components.
1832             e1=e1*eps1*eps2rt**2*eps3rt**2
1833             fac=-expon*(e1+evdwij)*rij_shift
1834             sigder=fac*sigder
1835             fac=rij*fac-2*expon*rrij*e_augm
1836 C Calculate the radial part of the gradient
1837             gg(1)=xj*fac
1838             gg(2)=yj*fac
1839             gg(3)=zj*fac
1840 C Calculate angular part of the gradient.
1841 #ifdef TSCSC
1842             if (bb(itypi,itypj).gt.0) then
1843                call sc_grad
1844             else
1845                call sc_grad_T
1846             endif
1847 #else
1848             call sc_grad
1849 #endif
1850           enddo      ! j
1851         enddo        ! iint
1852       enddo          ! i
1853       end
1854 C-----------------------------------------------------------------------------
1855       subroutine sc_angular
1856 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1857 C om12. Called by ebp, egb, and egbv.
1858       implicit none
1859       include 'COMMON.CALC'
1860       include 'COMMON.IOUNITS'
1861       erij(1)=xj*rij
1862       erij(2)=yj*rij
1863       erij(3)=zj*rij
1864       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1865       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1866       om12=dxi*dxj+dyi*dyj+dzi*dzj
1867       chiom12=chi12*om12
1868 C Calculate eps1(om12) and its derivative in om12
1869       faceps1=1.0D0-om12*chiom12
1870       faceps1_inv=1.0D0/faceps1
1871       eps1=dsqrt(faceps1_inv)
1872 C Following variable is eps1*deps1/dom12
1873       eps1_om12=faceps1_inv*chiom12
1874 c diagnostics only
1875 c      faceps1_inv=om12
1876 c      eps1=om12
1877 c      eps1_om12=1.0d0
1878 c      write (iout,*) "om12",om12," eps1",eps1
1879 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1880 C and om12.
1881       om1om2=om1*om2
1882       chiom1=chi1*om1
1883       chiom2=chi2*om2
1884       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1885       sigsq=1.0D0-facsig*faceps1_inv
1886       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1887       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1888       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1889 c diagnostics only
1890 c      sigsq=1.0d0
1891 c      sigsq_om1=0.0d0
1892 c      sigsq_om2=0.0d0
1893 c      sigsq_om12=0.0d0
1894 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1895 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1896 c     &    " eps1",eps1
1897 C Calculate eps2 and its derivatives in om1, om2, and om12.
1898       chipom1=chip1*om1
1899       chipom2=chip2*om2
1900       chipom12=chip12*om12
1901       facp=1.0D0-om12*chipom12
1902       facp_inv=1.0D0/facp
1903       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1904 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1905 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1906 C Following variable is the square root of eps2
1907       eps2rt=1.0D0-facp1*facp_inv
1908 C Following three variables are the derivatives of the square root of eps
1909 C in om1, om2, and om12.
1910       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1911       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1912       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1913 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1914       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1915 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1916 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1917 c     &  " eps2rt_om12",eps2rt_om12
1918 C Calculate whole angle-dependent part of epsilon and contributions
1919 C to its derivatives
1920       return
1921       end
1922
1923 C----------------------------------------------------------------------------
1924       subroutine sc_grad_T
1925       implicit real*8 (a-h,o-z)
1926       include 'DIMENSIONS'
1927       include 'COMMON.CHAIN'
1928       include 'COMMON.DERIV'
1929       include 'COMMON.CALC'
1930       include 'COMMON.IOUNITS'
1931       double precision dcosom1(3),dcosom2(3)
1932       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1933       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1934       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1935      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1936 c diagnostics only
1937 c      eom1=0.0d0
1938 c      eom2=0.0d0
1939 c      eom12=evdwij*eps1_om12
1940 c end diagnostics
1941 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1942 c     &  " sigder",sigder
1943 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1944 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1945       do k=1,3
1946         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1947         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1948       enddo
1949       do k=1,3
1950         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1951       enddo
1952 c      write (iout,*) "gg",(gg(k),k=1,3)
1953       do k=1,3
1954         gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1955      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1956      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1957         gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1958      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1959      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1960 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1961 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1962 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1963 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1964       enddo
1965 C
1966 C Calculate the components of the gradient in DC and X
1967 C
1968 cgrad      do k=i,j-1
1969 cgrad        do l=1,3
1970 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1971 cgrad        enddo
1972 cgrad      enddo
1973       do l=1,3
1974         gvdwcT(l,i)=gvdwcT(l,i)-gg(l)
1975         gvdwcT(l,j)=gvdwcT(l,j)+gg(l)
1976       enddo
1977       return
1978       end
1979
1980 C----------------------------------------------------------------------------
1981       subroutine sc_grad
1982       implicit real*8 (a-h,o-z)
1983       include 'DIMENSIONS'
1984       include 'COMMON.CHAIN'
1985       include 'COMMON.DERIV'
1986       include 'COMMON.CALC'
1987       include 'COMMON.IOUNITS'
1988       double precision dcosom1(3),dcosom2(3)
1989       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1990       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1991       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1992      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1993 c diagnostics only
1994 c      eom1=0.0d0
1995 c      eom2=0.0d0
1996 c      eom12=evdwij*eps1_om12
1997 c end diagnostics
1998 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1999 c     &  " sigder",sigder
2000 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2001 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2002       do k=1,3
2003         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2004         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2005       enddo
2006       do k=1,3
2007         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
2008       enddo
2009 c      write (iout,*) "gg",(gg(k),k=1,3)
2010       do k=1,3
2011         gvdwx(k,i)=gvdwx(k,i)-gg(k)
2012      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2013      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2014         gvdwx(k,j)=gvdwx(k,j)+gg(k)
2015      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2016      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2017 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2018 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2019 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2020 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2021       enddo
2022 C
2023 C Calculate the components of the gradient in DC and X
2024 C
2025 cgrad      do k=i,j-1
2026 cgrad        do l=1,3
2027 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2028 cgrad        enddo
2029 cgrad      enddo
2030       do l=1,3
2031         gvdwc(l,i)=gvdwc(l,i)-gg(l)
2032         gvdwc(l,j)=gvdwc(l,j)+gg(l)
2033       enddo
2034       return
2035       end
2036 C-----------------------------------------------------------------------
2037       subroutine e_softsphere(evdw)
2038 C
2039 C This subroutine calculates the interaction energy of nonbonded side chains
2040 C assuming the LJ potential of interaction.
2041 C
2042       implicit real*8 (a-h,o-z)
2043       include 'DIMENSIONS'
2044       parameter (accur=1.0d-10)
2045       include 'COMMON.GEO'
2046       include 'COMMON.VAR'
2047       include 'COMMON.LOCAL'
2048       include 'COMMON.CHAIN'
2049       include 'COMMON.DERIV'
2050       include 'COMMON.INTERACT'
2051       include 'COMMON.TORSION'
2052       include 'COMMON.SBRIDGE'
2053       include 'COMMON.NAMES'
2054       include 'COMMON.IOUNITS'
2055       include 'COMMON.CONTACTS'
2056       dimension gg(3)
2057 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2058       evdw=0.0D0
2059       do i=iatsc_s,iatsc_e
2060         itypi=itype(i)
2061         itypi1=itype(i+1)
2062         xi=c(1,nres+i)
2063         yi=c(2,nres+i)
2064         zi=c(3,nres+i)
2065 C
2066 C Calculate SC interaction energy.
2067 C
2068         do iint=1,nint_gr(i)
2069 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2070 cd   &                  'iend=',iend(i,iint)
2071           do j=istart(i,iint),iend(i,iint)
2072             itypj=itype(j)
2073             xj=c(1,nres+j)-xi
2074             yj=c(2,nres+j)-yi
2075             zj=c(3,nres+j)-zi
2076             rij=xj*xj+yj*yj+zj*zj
2077 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2078             r0ij=r0(itypi,itypj)
2079             r0ijsq=r0ij*r0ij
2080 c            print *,i,j,r0ij,dsqrt(rij)
2081             if (rij.lt.r0ijsq) then
2082               evdwij=0.25d0*(rij-r0ijsq)**2
2083               fac=rij-r0ijsq
2084             else
2085               evdwij=0.0d0
2086               fac=0.0d0
2087             endif
2088             evdw=evdw+evdwij
2089 C
2090 C Calculate the components of the gradient in DC and X
2091 C
2092             gg(1)=xj*fac
2093             gg(2)=yj*fac
2094             gg(3)=zj*fac
2095             do k=1,3
2096               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2097               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2098               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2099               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2100             enddo
2101 cgrad            do k=i,j-1
2102 cgrad              do l=1,3
2103 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2104 cgrad              enddo
2105 cgrad            enddo
2106           enddo ! j
2107         enddo ! iint
2108       enddo ! i
2109       return
2110       end
2111 C--------------------------------------------------------------------------
2112       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2113      &              eello_turn4)
2114 C
2115 C Soft-sphere potential of p-p interaction
2116 C
2117       implicit real*8 (a-h,o-z)
2118       include 'DIMENSIONS'
2119       include 'COMMON.CONTROL'
2120       include 'COMMON.IOUNITS'
2121       include 'COMMON.GEO'
2122       include 'COMMON.VAR'
2123       include 'COMMON.LOCAL'
2124       include 'COMMON.CHAIN'
2125       include 'COMMON.DERIV'
2126       include 'COMMON.INTERACT'
2127       include 'COMMON.CONTACTS'
2128       include 'COMMON.TORSION'
2129       include 'COMMON.VECTORS'
2130       include 'COMMON.FFIELD'
2131       dimension ggg(3)
2132 cd      write(iout,*) 'In EELEC_soft_sphere'
2133       ees=0.0D0
2134       evdw1=0.0D0
2135       eel_loc=0.0d0
2136       eello_turn3=0.0d0
2137       eello_turn4=0.0d0
2138       ind=0
2139       do i=iatel_s,iatel_e
2140         dxi=dc(1,i)
2141         dyi=dc(2,i)
2142         dzi=dc(3,i)
2143         xmedi=c(1,i)+0.5d0*dxi
2144         ymedi=c(2,i)+0.5d0*dyi
2145         zmedi=c(3,i)+0.5d0*dzi
2146         num_conti=0
2147 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2148         do j=ielstart(i),ielend(i)
2149           ind=ind+1
2150           iteli=itel(i)
2151           itelj=itel(j)
2152           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2153           r0ij=rpp(iteli,itelj)
2154           r0ijsq=r0ij*r0ij
2155           dxj=dc(1,j)
2156           dyj=dc(2,j)
2157           dzj=dc(3,j)
2158           xj=c(1,j)+0.5D0*dxj-xmedi
2159           yj=c(2,j)+0.5D0*dyj-ymedi
2160           zj=c(3,j)+0.5D0*dzj-zmedi
2161           rij=xj*xj+yj*yj+zj*zj
2162           if (rij.lt.r0ijsq) then
2163             evdw1ij=0.25d0*(rij-r0ijsq)**2
2164             fac=rij-r0ijsq
2165           else
2166             evdw1ij=0.0d0
2167             fac=0.0d0
2168           endif
2169           evdw1=evdw1+evdw1ij
2170 C
2171 C Calculate contributions to the Cartesian gradient.
2172 C
2173           ggg(1)=fac*xj
2174           ggg(2)=fac*yj
2175           ggg(3)=fac*zj
2176           do k=1,3
2177             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2178             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2179           enddo
2180 *
2181 * Loop over residues i+1 thru j-1.
2182 *
2183 cgrad          do k=i+1,j-1
2184 cgrad            do l=1,3
2185 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2186 cgrad            enddo
2187 cgrad          enddo
2188         enddo ! j
2189       enddo   ! i
2190 cgrad      do i=nnt,nct-1
2191 cgrad        do k=1,3
2192 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2193 cgrad        enddo
2194 cgrad        do j=i+1,nct-1
2195 cgrad          do k=1,3
2196 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2197 cgrad          enddo
2198 cgrad        enddo
2199 cgrad      enddo
2200       return
2201       end
2202 c------------------------------------------------------------------------------
2203       subroutine vec_and_deriv
2204       implicit real*8 (a-h,o-z)
2205       include 'DIMENSIONS'
2206 #ifdef MPI
2207       include 'mpif.h'
2208 #endif
2209       include 'COMMON.IOUNITS'
2210       include 'COMMON.GEO'
2211       include 'COMMON.VAR'
2212       include 'COMMON.LOCAL'
2213       include 'COMMON.CHAIN'
2214       include 'COMMON.VECTORS'
2215       include 'COMMON.SETUP'
2216       include 'COMMON.TIME1'
2217       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2218 C Compute the local reference systems. For reference system (i), the
2219 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2220 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2221 #ifdef PARVEC
2222       do i=ivec_start,ivec_end
2223 #else
2224       do i=1,nres-1
2225 #endif
2226           if (i.eq.nres-1) then
2227 C Case of the last full residue
2228 C Compute the Z-axis
2229             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2230             costh=dcos(pi-theta(nres))
2231             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2232             do k=1,3
2233               uz(k,i)=fac*uz(k,i)
2234             enddo
2235 C Compute the derivatives of uz
2236             uzder(1,1,1)= 0.0d0
2237             uzder(2,1,1)=-dc_norm(3,i-1)
2238             uzder(3,1,1)= dc_norm(2,i-1)
2239             uzder(1,2,1)= dc_norm(3,i-1)
2240             uzder(2,2,1)= 0.0d0
2241             uzder(3,2,1)=-dc_norm(1,i-1)
2242             uzder(1,3,1)=-dc_norm(2,i-1)
2243             uzder(2,3,1)= dc_norm(1,i-1)
2244             uzder(3,3,1)= 0.0d0
2245             uzder(1,1,2)= 0.0d0
2246             uzder(2,1,2)= dc_norm(3,i)
2247             uzder(3,1,2)=-dc_norm(2,i)
2248             uzder(1,2,2)=-dc_norm(3,i)
2249             uzder(2,2,2)= 0.0d0
2250             uzder(3,2,2)= dc_norm(1,i)
2251             uzder(1,3,2)= dc_norm(2,i)
2252             uzder(2,3,2)=-dc_norm(1,i)
2253             uzder(3,3,2)= 0.0d0
2254 C Compute the Y-axis
2255             facy=fac
2256             do k=1,3
2257               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2258             enddo
2259 C Compute the derivatives of uy
2260             do j=1,3
2261               do k=1,3
2262                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2263      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2264                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2265               enddo
2266               uyder(j,j,1)=uyder(j,j,1)-costh
2267               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2268             enddo
2269             do j=1,2
2270               do k=1,3
2271                 do l=1,3
2272                   uygrad(l,k,j,i)=uyder(l,k,j)
2273                   uzgrad(l,k,j,i)=uzder(l,k,j)
2274                 enddo
2275               enddo
2276             enddo
2277             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2278             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2279             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2280             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2281           else
2282 C Other residues
2283 C Compute the Z-axis
2284             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2285             costh=dcos(pi-theta(i+2))
2286             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2287             do k=1,3
2288               uz(k,i)=fac*uz(k,i)
2289             enddo
2290 C Compute the derivatives of uz
2291             uzder(1,1,1)= 0.0d0
2292             uzder(2,1,1)=-dc_norm(3,i+1)
2293             uzder(3,1,1)= dc_norm(2,i+1)
2294             uzder(1,2,1)= dc_norm(3,i+1)
2295             uzder(2,2,1)= 0.0d0
2296             uzder(3,2,1)=-dc_norm(1,i+1)
2297             uzder(1,3,1)=-dc_norm(2,i+1)
2298             uzder(2,3,1)= dc_norm(1,i+1)
2299             uzder(3,3,1)= 0.0d0
2300             uzder(1,1,2)= 0.0d0
2301             uzder(2,1,2)= dc_norm(3,i)
2302             uzder(3,1,2)=-dc_norm(2,i)
2303             uzder(1,2,2)=-dc_norm(3,i)
2304             uzder(2,2,2)= 0.0d0
2305             uzder(3,2,2)= dc_norm(1,i)
2306             uzder(1,3,2)= dc_norm(2,i)
2307             uzder(2,3,2)=-dc_norm(1,i)
2308             uzder(3,3,2)= 0.0d0
2309 C Compute the Y-axis
2310             facy=fac
2311             do k=1,3
2312               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2313             enddo
2314 C Compute the derivatives of uy
2315             do j=1,3
2316               do k=1,3
2317                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2318      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2319                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2320               enddo
2321               uyder(j,j,1)=uyder(j,j,1)-costh
2322               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2323             enddo
2324             do j=1,2
2325               do k=1,3
2326                 do l=1,3
2327                   uygrad(l,k,j,i)=uyder(l,k,j)
2328                   uzgrad(l,k,j,i)=uzder(l,k,j)
2329                 enddo
2330               enddo
2331             enddo
2332             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2333             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2334             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2335             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2336           endif
2337       enddo
2338       do i=1,nres-1
2339         vbld_inv_temp(1)=vbld_inv(i+1)
2340         if (i.lt.nres-1) then
2341           vbld_inv_temp(2)=vbld_inv(i+2)
2342           else
2343           vbld_inv_temp(2)=vbld_inv(i)
2344           endif
2345         do j=1,2
2346           do k=1,3
2347             do l=1,3
2348               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2349               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2350             enddo
2351           enddo
2352         enddo
2353       enddo
2354 #if defined(PARVEC) && defined(MPI)
2355       if (nfgtasks1.gt.1) then
2356         time00=MPI_Wtime()
2357 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2358 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2359 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2360         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2361      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2362      &   FG_COMM1,IERR)
2363         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2364      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2365      &   FG_COMM1,IERR)
2366         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2367      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2368      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2369         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2370      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2371      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2372         time_gather=time_gather+MPI_Wtime()-time00
2373       endif
2374 c      if (fg_rank.eq.0) then
2375 c        write (iout,*) "Arrays UY and UZ"
2376 c        do i=1,nres-1
2377 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2378 c     &     (uz(k,i),k=1,3)
2379 c        enddo
2380 c      endif
2381 #endif
2382       return
2383       end
2384 C-----------------------------------------------------------------------------
2385       subroutine check_vecgrad
2386       implicit real*8 (a-h,o-z)
2387       include 'DIMENSIONS'
2388       include 'COMMON.IOUNITS'
2389       include 'COMMON.GEO'
2390       include 'COMMON.VAR'
2391       include 'COMMON.LOCAL'
2392       include 'COMMON.CHAIN'
2393       include 'COMMON.VECTORS'
2394       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2395       dimension uyt(3,maxres),uzt(3,maxres)
2396       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2397       double precision delta /1.0d-7/
2398       call vec_and_deriv
2399 cd      do i=1,nres
2400 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2401 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2402 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2403 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2404 cd     &     (dc_norm(if90,i),if90=1,3)
2405 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2406 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2407 cd          write(iout,'(a)')
2408 cd      enddo
2409       do i=1,nres
2410         do j=1,2
2411           do k=1,3
2412             do l=1,3
2413               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2414               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2415             enddo
2416           enddo
2417         enddo
2418       enddo
2419       call vec_and_deriv
2420       do i=1,nres
2421         do j=1,3
2422           uyt(j,i)=uy(j,i)
2423           uzt(j,i)=uz(j,i)
2424         enddo
2425       enddo
2426       do i=1,nres
2427 cd        write (iout,*) 'i=',i
2428         do k=1,3
2429           erij(k)=dc_norm(k,i)
2430         enddo
2431         do j=1,3
2432           do k=1,3
2433             dc_norm(k,i)=erij(k)
2434           enddo
2435           dc_norm(j,i)=dc_norm(j,i)+delta
2436 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2437 c          do k=1,3
2438 c            dc_norm(k,i)=dc_norm(k,i)/fac
2439 c          enddo
2440 c          write (iout,*) (dc_norm(k,i),k=1,3)
2441 c          write (iout,*) (erij(k),k=1,3)
2442           call vec_and_deriv
2443           do k=1,3
2444             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2445             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2446             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2447             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2448           enddo
2449 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2450 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2451 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2452         enddo
2453         do k=1,3
2454           dc_norm(k,i)=erij(k)
2455         enddo
2456 cd        do k=1,3
2457 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2458 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2459 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2460 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2461 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2462 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2463 cd          write (iout,'(a)')
2464 cd        enddo
2465       enddo
2466       return
2467       end
2468 C--------------------------------------------------------------------------
2469       subroutine set_matrices
2470       implicit real*8 (a-h,o-z)
2471       include 'DIMENSIONS'
2472 #ifdef MPI
2473       include "mpif.h"
2474       include "COMMON.SETUP"
2475       integer IERR
2476       integer status(MPI_STATUS_SIZE)
2477 #endif
2478       include 'COMMON.IOUNITS'
2479       include 'COMMON.GEO'
2480       include 'COMMON.VAR'
2481       include 'COMMON.LOCAL'
2482       include 'COMMON.CHAIN'
2483       include 'COMMON.DERIV'
2484       include 'COMMON.INTERACT'
2485       include 'COMMON.CONTACTS'
2486       include 'COMMON.TORSION'
2487       include 'COMMON.VECTORS'
2488       include 'COMMON.FFIELD'
2489       double precision auxvec(2),auxmat(2,2)
2490 C
2491 C Compute the virtual-bond-torsional-angle dependent quantities needed
2492 C to calculate the el-loc multibody terms of various order.
2493 C
2494 #ifdef PARMAT
2495       do i=ivec_start+2,ivec_end+2
2496 #else
2497       do i=3,nres+1
2498 #endif
2499         if (i .lt. nres+1) then
2500           sin1=dsin(phi(i))
2501           cos1=dcos(phi(i))
2502           sintab(i-2)=sin1
2503           costab(i-2)=cos1
2504           obrot(1,i-2)=cos1
2505           obrot(2,i-2)=sin1
2506           sin2=dsin(2*phi(i))
2507           cos2=dcos(2*phi(i))
2508           sintab2(i-2)=sin2
2509           costab2(i-2)=cos2
2510           obrot2(1,i-2)=cos2
2511           obrot2(2,i-2)=sin2
2512           Ug(1,1,i-2)=-cos1
2513           Ug(1,2,i-2)=-sin1
2514           Ug(2,1,i-2)=-sin1
2515           Ug(2,2,i-2)= cos1
2516           Ug2(1,1,i-2)=-cos2
2517           Ug2(1,2,i-2)=-sin2
2518           Ug2(2,1,i-2)=-sin2
2519           Ug2(2,2,i-2)= cos2
2520         else
2521           costab(i-2)=1.0d0
2522           sintab(i-2)=0.0d0
2523           obrot(1,i-2)=1.0d0
2524           obrot(2,i-2)=0.0d0
2525           obrot2(1,i-2)=0.0d0
2526           obrot2(2,i-2)=0.0d0
2527           Ug(1,1,i-2)=1.0d0
2528           Ug(1,2,i-2)=0.0d0
2529           Ug(2,1,i-2)=0.0d0
2530           Ug(2,2,i-2)=1.0d0
2531           Ug2(1,1,i-2)=0.0d0
2532           Ug2(1,2,i-2)=0.0d0
2533           Ug2(2,1,i-2)=0.0d0
2534           Ug2(2,2,i-2)=0.0d0
2535         endif
2536         if (i .gt. 3 .and. i .lt. nres+1) then
2537           obrot_der(1,i-2)=-sin1
2538           obrot_der(2,i-2)= cos1
2539           Ugder(1,1,i-2)= sin1
2540           Ugder(1,2,i-2)=-cos1
2541           Ugder(2,1,i-2)=-cos1
2542           Ugder(2,2,i-2)=-sin1
2543           dwacos2=cos2+cos2
2544           dwasin2=sin2+sin2
2545           obrot2_der(1,i-2)=-dwasin2
2546           obrot2_der(2,i-2)= dwacos2
2547           Ug2der(1,1,i-2)= dwasin2
2548           Ug2der(1,2,i-2)=-dwacos2
2549           Ug2der(2,1,i-2)=-dwacos2
2550           Ug2der(2,2,i-2)=-dwasin2
2551         else
2552           obrot_der(1,i-2)=0.0d0
2553           obrot_der(2,i-2)=0.0d0
2554           Ugder(1,1,i-2)=0.0d0
2555           Ugder(1,2,i-2)=0.0d0
2556           Ugder(2,1,i-2)=0.0d0
2557           Ugder(2,2,i-2)=0.0d0
2558           obrot2_der(1,i-2)=0.0d0
2559           obrot2_der(2,i-2)=0.0d0
2560           Ug2der(1,1,i-2)=0.0d0
2561           Ug2der(1,2,i-2)=0.0d0
2562           Ug2der(2,1,i-2)=0.0d0
2563           Ug2der(2,2,i-2)=0.0d0
2564         endif
2565 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2566         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2567           iti = itortyp(itype(i-2))
2568         else
2569           iti=ntortyp+1
2570         endif
2571 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2572         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2573           iti1 = itortyp(itype(i-1))
2574         else
2575           iti1=ntortyp+1
2576         endif
2577 cd        write (iout,*) '*******i',i,' iti1',iti
2578 cd        write (iout,*) 'b1',b1(:,iti)
2579 cd        write (iout,*) 'b2',b2(:,iti)
2580 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2581 c        if (i .gt. iatel_s+2) then
2582         if (i .gt. nnt+2) then
2583           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2584           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2585           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2586      &    then
2587           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2588           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2589           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2590           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2591           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2592           endif
2593         else
2594           do k=1,2
2595             Ub2(k,i-2)=0.0d0
2596             Ctobr(k,i-2)=0.0d0
2597             Dtobr2(k,i-2)=0.0d0
2598             do l=1,2
2599               EUg(l,k,i-2)=0.0d0
2600               CUg(l,k,i-2)=0.0d0
2601               DUg(l,k,i-2)=0.0d0
2602               DtUg2(l,k,i-2)=0.0d0
2603             enddo
2604           enddo
2605         endif
2606         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2607         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2608         do k=1,2
2609           muder(k,i-2)=Ub2der(k,i-2)
2610         enddo
2611 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2612         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2613           iti1 = itortyp(itype(i-1))
2614         else
2615           iti1=ntortyp+1
2616         endif
2617         do k=1,2
2618           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2619         enddo
2620 cd        write (iout,*) 'mu ',mu(:,i-2)
2621 cd        write (iout,*) 'mu1',mu1(:,i-2)
2622 cd        write (iout,*) 'mu2',mu2(:,i-2)
2623         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2624      &  then
2625         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2626         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2627         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2628         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2629         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2630 C Vectors and matrices dependent on a single virtual-bond dihedral.
2631         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2632         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2633         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2634         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2635         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2636         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2637         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2638         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2639         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2640         endif
2641       enddo
2642 C Matrices dependent on two consecutive virtual-bond dihedrals.
2643 C The order of matrices is from left to right.
2644       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2645      &then
2646 c      do i=max0(ivec_start,2),ivec_end
2647       do i=2,nres-1
2648         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2649         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2650         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2651         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2652         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2653         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2654         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2655         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2656       enddo
2657       endif
2658 #if defined(MPI) && defined(PARMAT)
2659 #ifdef DEBUG
2660 c      if (fg_rank.eq.0) then
2661         write (iout,*) "Arrays UG and UGDER before GATHER"
2662         do i=1,nres-1
2663           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2664      &     ((ug(l,k,i),l=1,2),k=1,2),
2665      &     ((ugder(l,k,i),l=1,2),k=1,2)
2666         enddo
2667         write (iout,*) "Arrays UG2 and UG2DER"
2668         do i=1,nres-1
2669           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2670      &     ((ug2(l,k,i),l=1,2),k=1,2),
2671      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2672         enddo
2673         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2674         do i=1,nres-1
2675           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2676      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2677      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2678         enddo
2679         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2680         do i=1,nres-1
2681           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2682      &     costab(i),sintab(i),costab2(i),sintab2(i)
2683         enddo
2684         write (iout,*) "Array MUDER"
2685         do i=1,nres-1
2686           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2687         enddo
2688 c      endif
2689 #endif
2690       if (nfgtasks.gt.1) then
2691         time00=MPI_Wtime()
2692 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2693 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2694 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2695 #ifdef MATGATHER
2696         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2697      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2698      &   FG_COMM1,IERR)
2699         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2700      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2701      &   FG_COMM1,IERR)
2702         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2703      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2704      &   FG_COMM1,IERR)
2705         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2706      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2707      &   FG_COMM1,IERR)
2708         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2709      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2710      &   FG_COMM1,IERR)
2711         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2712      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2713      &   FG_COMM1,IERR)
2714         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2715      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2716      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2717         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2718      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2719      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2720         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2721      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2722      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2723         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2724      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2725      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2726         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2727      &  then
2728         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2729      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2730      &   FG_COMM1,IERR)
2731         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2732      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2733      &   FG_COMM1,IERR)
2734         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2735      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2736      &   FG_COMM1,IERR)
2737        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2738      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2739      &   FG_COMM1,IERR)
2740         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2741      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2742      &   FG_COMM1,IERR)
2743         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2744      &   ivec_count(fg_rank1),
2745      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2746      &   FG_COMM1,IERR)
2747         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2748      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2749      &   FG_COMM1,IERR)
2750         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2751      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2752      &   FG_COMM1,IERR)
2753         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2754      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2755      &   FG_COMM1,IERR)
2756         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2757      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2758      &   FG_COMM1,IERR)
2759         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2760      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2761      &   FG_COMM1,IERR)
2762         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2763      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2764      &   FG_COMM1,IERR)
2765         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2766      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2767      &   FG_COMM1,IERR)
2768         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2769      &   ivec_count(fg_rank1),
2770      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2771      &   FG_COMM1,IERR)
2772         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2773      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2774      &   FG_COMM1,IERR)
2775        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2776      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2777      &   FG_COMM1,IERR)
2778         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2779      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2780      &   FG_COMM1,IERR)
2781        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2782      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2783      &   FG_COMM1,IERR)
2784         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2785      &   ivec_count(fg_rank1),
2786      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2787      &   FG_COMM1,IERR)
2788         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2789      &   ivec_count(fg_rank1),
2790      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2791      &   FG_COMM1,IERR)
2792         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2793      &   ivec_count(fg_rank1),
2794      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2795      &   MPI_MAT2,FG_COMM1,IERR)
2796         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2797      &   ivec_count(fg_rank1),
2798      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2799      &   MPI_MAT2,FG_COMM1,IERR)
2800         endif
2801 #else
2802 c Passes matrix info through the ring
2803       isend=fg_rank1
2804       irecv=fg_rank1-1
2805       if (irecv.lt.0) irecv=nfgtasks1-1
2806       iprev=irecv
2807       inext=fg_rank1+1
2808       if (inext.ge.nfgtasks1) inext=0
2809       do i=1,nfgtasks1-1
2810 c        write (iout,*) "isend",isend," irecv",irecv
2811 c        call flush(iout)
2812         lensend=lentyp(isend)
2813         lenrecv=lentyp(irecv)
2814 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2815 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2816 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2817 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2818 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2819 c        write (iout,*) "Gather ROTAT1"
2820 c        call flush(iout)
2821 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2822 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2823 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2824 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2825 c        write (iout,*) "Gather ROTAT2"
2826 c        call flush(iout)
2827         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2828      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2829      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2830      &   iprev,4400+irecv,FG_COMM,status,IERR)
2831 c        write (iout,*) "Gather ROTAT_OLD"
2832 c        call flush(iout)
2833         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2834      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2835      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2836      &   iprev,5500+irecv,FG_COMM,status,IERR)
2837 c        write (iout,*) "Gather PRECOMP11"
2838 c        call flush(iout)
2839         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2840      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2841      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2842      &   iprev,6600+irecv,FG_COMM,status,IERR)
2843 c        write (iout,*) "Gather PRECOMP12"
2844 c        call flush(iout)
2845         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2846      &  then
2847         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2848      &   MPI_ROTAT2(lensend),inext,7700+isend,
2849      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2850      &   iprev,7700+irecv,FG_COMM,status,IERR)
2851 c        write (iout,*) "Gather PRECOMP21"
2852 c        call flush(iout)
2853         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2854      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2855      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2856      &   iprev,8800+irecv,FG_COMM,status,IERR)
2857 c        write (iout,*) "Gather PRECOMP22"
2858 c        call flush(iout)
2859         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2860      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2861      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2862      &   MPI_PRECOMP23(lenrecv),
2863      &   iprev,9900+irecv,FG_COMM,status,IERR)
2864 c        write (iout,*) "Gather PRECOMP23"
2865 c        call flush(iout)
2866         endif
2867         isend=irecv
2868         irecv=irecv-1
2869         if (irecv.lt.0) irecv=nfgtasks1-1
2870       enddo
2871 #endif
2872         time_gather=time_gather+MPI_Wtime()-time00
2873       endif
2874 #ifdef DEBUG
2875 c      if (fg_rank.eq.0) then
2876         write (iout,*) "Arrays UG and UGDER"
2877         do i=1,nres-1
2878           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2879      &     ((ug(l,k,i),l=1,2),k=1,2),
2880      &     ((ugder(l,k,i),l=1,2),k=1,2)
2881         enddo
2882         write (iout,*) "Arrays UG2 and UG2DER"
2883         do i=1,nres-1
2884           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2885      &     ((ug2(l,k,i),l=1,2),k=1,2),
2886      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2887         enddo
2888         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2889         do i=1,nres-1
2890           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2891      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2892      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2893         enddo
2894         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2895         do i=1,nres-1
2896           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2897      &     costab(i),sintab(i),costab2(i),sintab2(i)
2898         enddo
2899         write (iout,*) "Array MUDER"
2900         do i=1,nres-1
2901           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2902         enddo
2903 c      endif
2904 #endif
2905 #endif
2906 cd      do i=1,nres
2907 cd        iti = itortyp(itype(i))
2908 cd        write (iout,*) i
2909 cd        do j=1,2
2910 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2911 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2912 cd        enddo
2913 cd      enddo
2914       return
2915       end
2916 C--------------------------------------------------------------------------
2917       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2918 C
2919 C This subroutine calculates the average interaction energy and its gradient
2920 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2921 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2922 C The potential depends both on the distance of peptide-group centers and on
2923 C the orientation of the CA-CA virtual bonds.
2924 C
2925       implicit real*8 (a-h,o-z)
2926 #ifdef MPI
2927       include 'mpif.h'
2928 #endif
2929       include 'DIMENSIONS'
2930       include 'COMMON.CONTROL'
2931       include 'COMMON.SETUP'
2932       include 'COMMON.IOUNITS'
2933       include 'COMMON.GEO'
2934       include 'COMMON.VAR'
2935       include 'COMMON.LOCAL'
2936       include 'COMMON.CHAIN'
2937       include 'COMMON.DERIV'
2938       include 'COMMON.INTERACT'
2939       include 'COMMON.CONTACTS'
2940       include 'COMMON.TORSION'
2941       include 'COMMON.VECTORS'
2942       include 'COMMON.FFIELD'
2943       include 'COMMON.TIME1'
2944       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2945      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2946       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2947      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2948       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2949      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2950      &    num_conti,j1,j2
2951 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2952 #ifdef MOMENT
2953       double precision scal_el /1.0d0/
2954 #else
2955       double precision scal_el /0.5d0/
2956 #endif
2957 C 12/13/98
2958 C 13-go grudnia roku pamietnego...
2959       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2960      &                   0.0d0,1.0d0,0.0d0,
2961      &                   0.0d0,0.0d0,1.0d0/
2962 cd      write(iout,*) 'In EELEC'
2963 cd      do i=1,nloctyp
2964 cd        write(iout,*) 'Type',i
2965 cd        write(iout,*) 'B1',B1(:,i)
2966 cd        write(iout,*) 'B2',B2(:,i)
2967 cd        write(iout,*) 'CC',CC(:,:,i)
2968 cd        write(iout,*) 'DD',DD(:,:,i)
2969 cd        write(iout,*) 'EE',EE(:,:,i)
2970 cd      enddo
2971 cd      call check_vecgrad
2972 cd      stop
2973       if (icheckgrad.eq.1) then
2974         do i=1,nres-1
2975           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2976           do k=1,3
2977             dc_norm(k,i)=dc(k,i)*fac
2978           enddo
2979 c          write (iout,*) 'i',i,' fac',fac
2980         enddo
2981       endif
2982       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2983      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2984      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2985 c        call vec_and_deriv
2986 #ifdef TIMING
2987         time01=MPI_Wtime()
2988 #endif
2989         call set_matrices
2990 #ifdef TIMING
2991         time_mat=time_mat+MPI_Wtime()-time01
2992 #endif
2993       endif
2994 cd      do i=1,nres-1
2995 cd        write (iout,*) 'i=',i
2996 cd        do k=1,3
2997 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2998 cd        enddo
2999 cd        do k=1,3
3000 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3001 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3002 cd        enddo
3003 cd      enddo
3004       t_eelecij=0.0d0
3005       ees=0.0D0
3006       evdw1=0.0D0
3007       eel_loc=0.0d0
3008       eello_turn3=0.0d0
3009       eello_turn4=0.0d0
3010       ind=0
3011       do i=1,nres
3012         num_cont_hb(i)=0
3013       enddo
3014 cd      print '(a)','Enter EELEC'
3015 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3016       do i=1,nres
3017         gel_loc_loc(i)=0.0d0
3018         gcorr_loc(i)=0.0d0
3019       enddo
3020 c
3021 c
3022 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3023 C
3024 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3025 C
3026       do i=iturn3_start,iturn3_end
3027         dxi=dc(1,i)
3028         dyi=dc(2,i)
3029         dzi=dc(3,i)
3030         dx_normi=dc_norm(1,i)
3031         dy_normi=dc_norm(2,i)
3032         dz_normi=dc_norm(3,i)
3033         xmedi=c(1,i)+0.5d0*dxi
3034         ymedi=c(2,i)+0.5d0*dyi
3035         zmedi=c(3,i)+0.5d0*dzi
3036         num_conti=0
3037         call eelecij(i,i+2,ees,evdw1,eel_loc)
3038         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3039         num_cont_hb(i)=num_conti
3040       enddo
3041       do i=iturn4_start,iturn4_end
3042         dxi=dc(1,i)
3043         dyi=dc(2,i)
3044         dzi=dc(3,i)
3045         dx_normi=dc_norm(1,i)
3046         dy_normi=dc_norm(2,i)
3047         dz_normi=dc_norm(3,i)
3048         xmedi=c(1,i)+0.5d0*dxi
3049         ymedi=c(2,i)+0.5d0*dyi
3050         zmedi=c(3,i)+0.5d0*dzi
3051         num_conti=num_cont_hb(i)
3052         call eelecij(i,i+3,ees,evdw1,eel_loc)
3053         if (wturn4.gt.0.0d0) call eturn4(i,eello_turn4)
3054         num_cont_hb(i)=num_conti
3055       enddo   ! i
3056 c
3057 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3058 c
3059       do i=iatel_s,iatel_e
3060         dxi=dc(1,i)
3061         dyi=dc(2,i)
3062         dzi=dc(3,i)
3063         dx_normi=dc_norm(1,i)
3064         dy_normi=dc_norm(2,i)
3065         dz_normi=dc_norm(3,i)
3066         xmedi=c(1,i)+0.5d0*dxi
3067         ymedi=c(2,i)+0.5d0*dyi
3068         zmedi=c(3,i)+0.5d0*dzi
3069 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3070         num_conti=num_cont_hb(i)
3071         do j=ielstart(i),ielend(i)
3072           call eelecij(i,j,ees,evdw1,eel_loc)
3073         enddo ! j
3074         num_cont_hb(i)=num_conti
3075       enddo   ! i
3076 c      write (iout,*) "Number of loop steps in EELEC:",ind
3077 cd      do i=1,nres
3078 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3079 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3080 cd      enddo
3081 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3082 ccc      eel_loc=eel_loc+eello_turn3
3083 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3084       return
3085       end
3086 C-------------------------------------------------------------------------------
3087       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3088       implicit real*8 (a-h,o-z)
3089       include 'DIMENSIONS'
3090 #ifdef MPI
3091       include "mpif.h"
3092 #endif
3093       include 'COMMON.CONTROL'
3094       include 'COMMON.IOUNITS'
3095       include 'COMMON.GEO'
3096       include 'COMMON.VAR'
3097       include 'COMMON.LOCAL'
3098       include 'COMMON.CHAIN'
3099       include 'COMMON.DERIV'
3100       include 'COMMON.INTERACT'
3101       include 'COMMON.CONTACTS'
3102       include 'COMMON.TORSION'
3103       include 'COMMON.VECTORS'
3104       include 'COMMON.FFIELD'
3105       include 'COMMON.TIME1'
3106       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3107      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3108       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3109      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3110       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3111      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3112      &    num_conti,j1,j2
3113 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3114 #ifdef MOMENT
3115       double precision scal_el /1.0d0/
3116 #else
3117       double precision scal_el /0.5d0/
3118 #endif
3119 C 12/13/98
3120 C 13-go grudnia roku pamietnego...
3121       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3122      &                   0.0d0,1.0d0,0.0d0,
3123      &                   0.0d0,0.0d0,1.0d0/
3124 c          time00=MPI_Wtime()
3125 cd      write (iout,*) "eelecij",i,j
3126 c          ind=ind+1
3127           iteli=itel(i)
3128           itelj=itel(j)
3129           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3130           aaa=app(iteli,itelj)
3131           bbb=bpp(iteli,itelj)
3132           ael6i=ael6(iteli,itelj)
3133           ael3i=ael3(iteli,itelj)
3134           dxj=dc(1,j)
3135           dyj=dc(2,j)
3136           dzj=dc(3,j)
3137           dx_normj=dc_norm(1,j)
3138           dy_normj=dc_norm(2,j)
3139           dz_normj=dc_norm(3,j)
3140           xj=c(1,j)+0.5D0*dxj-xmedi
3141           yj=c(2,j)+0.5D0*dyj-ymedi
3142           zj=c(3,j)+0.5D0*dzj-zmedi
3143           rij=xj*xj+yj*yj+zj*zj
3144           rrmij=1.0D0/rij
3145           rij=dsqrt(rij)
3146           rmij=1.0D0/rij
3147           r3ij=rrmij*rmij
3148           r6ij=r3ij*r3ij
3149           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3150           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3151           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3152           fac=cosa-3.0D0*cosb*cosg
3153           ev1=aaa*r6ij*r6ij
3154 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3155           if (j.eq.i+2) ev1=scal_el*ev1
3156           ev2=bbb*r6ij
3157           fac3=ael6i*r6ij
3158           fac4=ael3i*r3ij
3159           evdwij=ev1+ev2
3160           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3161           el2=fac4*fac
3162           eesij=el1+el2
3163 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3164           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3165           ees=ees+eesij
3166           evdw1=evdw1+evdwij
3167 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3168 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3169 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3170 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3171
3172           if (energy_dec) then
3173               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3174               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3175           endif
3176
3177 C
3178 C Calculate contributions to the Cartesian gradient.
3179 C
3180 #ifdef SPLITELE
3181           facvdw=-6*rrmij*(ev1+evdwij)
3182           facel=-3*rrmij*(el1+eesij)
3183           fac1=fac
3184           erij(1)=xj*rmij
3185           erij(2)=yj*rmij
3186           erij(3)=zj*rmij
3187 *
3188 * Radial derivatives. First process both termini of the fragment (i,j)
3189 *
3190           ggg(1)=facel*xj
3191           ggg(2)=facel*yj
3192           ggg(3)=facel*zj
3193 c          do k=1,3
3194 c            ghalf=0.5D0*ggg(k)
3195 c            gelc(k,i)=gelc(k,i)+ghalf
3196 c            gelc(k,j)=gelc(k,j)+ghalf
3197 c          enddo
3198 c 9/28/08 AL Gradient compotents will be summed only at the end
3199           do k=1,3
3200             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3201             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3202           enddo
3203 *
3204 * Loop over residues i+1 thru j-1.
3205 *
3206 cgrad          do k=i+1,j-1
3207 cgrad            do l=1,3
3208 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3209 cgrad            enddo
3210 cgrad          enddo
3211           ggg(1)=facvdw*xj
3212           ggg(2)=facvdw*yj
3213           ggg(3)=facvdw*zj
3214 c          do k=1,3
3215 c            ghalf=0.5D0*ggg(k)
3216 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3217 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3218 c          enddo
3219 c 9/28/08 AL Gradient compotents will be summed only at the end
3220           do k=1,3
3221             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3222             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3223           enddo
3224 *
3225 * Loop over residues i+1 thru j-1.
3226 *
3227 cgrad          do k=i+1,j-1
3228 cgrad            do l=1,3
3229 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3230 cgrad            enddo
3231 cgrad          enddo
3232 #else
3233           facvdw=ev1+evdwij
3234           facel=el1+eesij
3235           fac1=fac
3236           fac=-3*rrmij*(facvdw+facvdw+facel)
3237           erij(1)=xj*rmij
3238           erij(2)=yj*rmij
3239           erij(3)=zj*rmij
3240 *
3241 * Radial derivatives. First process both termini of the fragment (i,j)
3242 *
3243           ggg(1)=fac*xj
3244           ggg(2)=fac*yj
3245           ggg(3)=fac*zj
3246 c          do k=1,3
3247 c            ghalf=0.5D0*ggg(k)
3248 c            gelc(k,i)=gelc(k,i)+ghalf
3249 c            gelc(k,j)=gelc(k,j)+ghalf
3250 c          enddo
3251 c 9/28/08 AL Gradient compotents will be summed only at the end
3252           do k=1,3
3253             gelc_long(k,j)=gelc(k,j)+ggg(k)
3254             gelc_long(k,i)=gelc(k,i)-ggg(k)
3255           enddo
3256 *
3257 * Loop over residues i+1 thru j-1.
3258 *
3259 cgrad          do k=i+1,j-1
3260 cgrad            do l=1,3
3261 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3262 cgrad            enddo
3263 cgrad          enddo
3264 c 9/28/08 AL Gradient compotents will be summed only at the end
3265           ggg(1)=facvdw*xj
3266           ggg(2)=facvdw*yj
3267           ggg(3)=facvdw*zj
3268           do k=1,3
3269             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3270             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3271           enddo
3272 #endif
3273 *
3274 * Angular part
3275 *
3276           ecosa=2.0D0*fac3*fac1+fac4
3277           fac4=-3.0D0*fac4
3278           fac3=-6.0D0*fac3
3279           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3280           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3281           do k=1,3
3282             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3283             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3284           enddo
3285 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3286 cd   &          (dcosg(k),k=1,3)
3287           do k=1,3
3288             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3289           enddo
3290 c          do k=1,3
3291 c            ghalf=0.5D0*ggg(k)
3292 c            gelc(k,i)=gelc(k,i)+ghalf
3293 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3294 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3295 c            gelc(k,j)=gelc(k,j)+ghalf
3296 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3297 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3298 c          enddo
3299 cgrad          do k=i+1,j-1
3300 cgrad            do l=1,3
3301 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3302 cgrad            enddo
3303 cgrad          enddo
3304           do k=1,3
3305             gelc(k,i)=gelc(k,i)
3306      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3307      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3308             gelc(k,j)=gelc(k,j)
3309      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3310      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3311             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3312             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3313           enddo
3314           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3315      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3316      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3317 C
3318 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3319 C   energy of a peptide unit is assumed in the form of a second-order
3320 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3321 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3322 C   are computed for EVERY pair of non-contiguous peptide groups.
3323 C
3324           if (j.lt.nres-1) then
3325             j1=j+1
3326             j2=j-1
3327           else
3328             j1=j-1
3329             j2=j-2
3330           endif
3331           kkk=0
3332           do k=1,2
3333             do l=1,2
3334               kkk=kkk+1
3335               muij(kkk)=mu(k,i)*mu(l,j)
3336             enddo
3337           enddo
3338 cd         write (iout,*) 'EELEC: i',i,' j',j
3339 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3340 cd          write(iout,*) 'muij',muij
3341           ury=scalar(uy(1,i),erij)
3342           urz=scalar(uz(1,i),erij)
3343           vry=scalar(uy(1,j),erij)
3344           vrz=scalar(uz(1,j),erij)
3345           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3346           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3347           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3348           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3349           fac=dsqrt(-ael6i)*r3ij
3350           a22=a22*fac
3351           a23=a23*fac
3352           a32=a32*fac
3353           a33=a33*fac
3354 cd          write (iout,'(4i5,4f10.5)')
3355 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3356 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3357 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3358 cd     &      uy(:,j),uz(:,j)
3359 cd          write (iout,'(4f10.5)')
3360 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3361 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3362 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3363 cd           write (iout,'(9f10.5/)')
3364 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3365 C Derivatives of the elements of A in virtual-bond vectors
3366           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3367           do k=1,3
3368             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3369             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3370             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3371             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3372             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3373             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3374             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3375             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3376             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3377             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3378             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3379             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3380           enddo
3381 C Compute radial contributions to the gradient
3382           facr=-3.0d0*rrmij
3383           a22der=a22*facr
3384           a23der=a23*facr
3385           a32der=a32*facr
3386           a33der=a33*facr
3387           agg(1,1)=a22der*xj
3388           agg(2,1)=a22der*yj
3389           agg(3,1)=a22der*zj
3390           agg(1,2)=a23der*xj
3391           agg(2,2)=a23der*yj
3392           agg(3,2)=a23der*zj
3393           agg(1,3)=a32der*xj
3394           agg(2,3)=a32der*yj
3395           agg(3,3)=a32der*zj
3396           agg(1,4)=a33der*xj
3397           agg(2,4)=a33der*yj
3398           agg(3,4)=a33der*zj
3399 C Add the contributions coming from er
3400           fac3=-3.0d0*fac
3401           do k=1,3
3402             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3403             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3404             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3405             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3406           enddo
3407           do k=1,3
3408 C Derivatives in DC(i)
3409 cgrad            ghalf1=0.5d0*agg(k,1)
3410 cgrad            ghalf2=0.5d0*agg(k,2)
3411 cgrad            ghalf3=0.5d0*agg(k,3)
3412 cgrad            ghalf4=0.5d0*agg(k,4)
3413             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3414      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3415             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3416      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3417             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3418      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3419             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3420      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3421 C Derivatives in DC(i+1)
3422             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3423      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3424             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3425      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3426             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3427      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3428             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3429      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3430 C Derivatives in DC(j)
3431             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3432      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3433             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3434      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3435             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3436      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3437             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3438      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3439 C Derivatives in DC(j+1) or DC(nres-1)
3440             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3441      &      -3.0d0*vryg(k,3)*ury)
3442             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3443      &      -3.0d0*vrzg(k,3)*ury)
3444             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3445      &      -3.0d0*vryg(k,3)*urz)
3446             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3447      &      -3.0d0*vrzg(k,3)*urz)
3448 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3449 cgrad              do l=1,4
3450 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3451 cgrad              enddo
3452 cgrad            endif
3453           enddo
3454           acipa(1,1)=a22
3455           acipa(1,2)=a23
3456           acipa(2,1)=a32
3457           acipa(2,2)=a33
3458           a22=-a22
3459           a23=-a23
3460           do l=1,2
3461             do k=1,3
3462               agg(k,l)=-agg(k,l)
3463               aggi(k,l)=-aggi(k,l)
3464               aggi1(k,l)=-aggi1(k,l)
3465               aggj(k,l)=-aggj(k,l)
3466               aggj1(k,l)=-aggj1(k,l)
3467             enddo
3468           enddo
3469           if (j.lt.nres-1) then
3470             a22=-a22
3471             a32=-a32
3472             do l=1,3,2
3473               do k=1,3
3474                 agg(k,l)=-agg(k,l)
3475                 aggi(k,l)=-aggi(k,l)
3476                 aggi1(k,l)=-aggi1(k,l)
3477                 aggj(k,l)=-aggj(k,l)
3478                 aggj1(k,l)=-aggj1(k,l)
3479               enddo
3480             enddo
3481           else
3482             a22=-a22
3483             a23=-a23
3484             a32=-a32
3485             a33=-a33
3486             do l=1,4
3487               do k=1,3
3488                 agg(k,l)=-agg(k,l)
3489                 aggi(k,l)=-aggi(k,l)
3490                 aggi1(k,l)=-aggi1(k,l)
3491                 aggj(k,l)=-aggj(k,l)
3492                 aggj1(k,l)=-aggj1(k,l)
3493               enddo
3494             enddo
3495           endif
3496           ENDIF ! WCORR
3497           IF (wel_loc.gt.0.0d0) THEN
3498 C Contribution to the local-electrostatic energy coming from the i-j pair
3499           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3500      &     +a33*muij(4)
3501 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3502
3503           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3504      &            'eelloc',i,j,eel_loc_ij
3505
3506           eel_loc=eel_loc+eel_loc_ij
3507 C Partial derivatives in virtual-bond dihedral angles gamma
3508           if (i.gt.1)
3509      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3510      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3511      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3512           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3513      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3514      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3515 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3516           do l=1,3
3517             ggg(l)=agg(l,1)*muij(1)+
3518      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3519             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3520             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3521 cgrad            ghalf=0.5d0*ggg(l)
3522 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3523 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3524           enddo
3525 cgrad          do k=i+1,j2
3526 cgrad            do l=1,3
3527 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3528 cgrad            enddo
3529 cgrad          enddo
3530 C Remaining derivatives of eello
3531           do l=1,3
3532             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3533      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3534             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3535      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3536             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3537      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3538             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3539      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3540           enddo
3541           ENDIF
3542 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3543 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3544           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3545      &       .and. num_conti.le.maxconts) then
3546 c            write (iout,*) i,j," entered corr"
3547 C
3548 C Calculate the contact function. The ith column of the array JCONT will
3549 C contain the numbers of atoms that make contacts with the atom I (of numbers
3550 C greater than I). The arrays FACONT and GACONT will contain the values of
3551 C the contact function and its derivative.
3552 c           r0ij=1.02D0*rpp(iteli,itelj)
3553 c           r0ij=1.11D0*rpp(iteli,itelj)
3554             r0ij=2.20D0*rpp(iteli,itelj)
3555 c           r0ij=1.55D0*rpp(iteli,itelj)
3556             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3557             if (fcont.gt.0.0D0) then
3558               num_conti=num_conti+1
3559               if (num_conti.gt.maxconts) then
3560                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3561      &                         ' will skip next contacts for this conf.'
3562               else
3563                 jcont_hb(num_conti,i)=j
3564 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3565 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3566                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3567      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3568 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3569 C  terms.
3570                 d_cont(num_conti,i)=rij
3571 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3572 C     --- Electrostatic-interaction matrix ---
3573                 a_chuj(1,1,num_conti,i)=a22
3574                 a_chuj(1,2,num_conti,i)=a23
3575                 a_chuj(2,1,num_conti,i)=a32
3576                 a_chuj(2,2,num_conti,i)=a33
3577 C     --- Gradient of rij
3578                 do kkk=1,3
3579                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3580                 enddo
3581                 kkll=0
3582                 do k=1,2
3583                   do l=1,2
3584                     kkll=kkll+1
3585                     do m=1,3
3586                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3587                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3588                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3589                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3590                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3591                     enddo
3592                   enddo
3593                 enddo
3594                 ENDIF
3595                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3596 C Calculate contact energies
3597                 cosa4=4.0D0*cosa
3598                 wij=cosa-3.0D0*cosb*cosg
3599                 cosbg1=cosb+cosg
3600                 cosbg2=cosb-cosg
3601 c               fac3=dsqrt(-ael6i)/r0ij**3
3602                 fac3=dsqrt(-ael6i)*r3ij
3603 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3604                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3605                 if (ees0tmp.gt.0) then
3606                   ees0pij=dsqrt(ees0tmp)
3607                 else
3608                   ees0pij=0
3609                 endif
3610 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3611                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3612                 if (ees0tmp.gt.0) then
3613                   ees0mij=dsqrt(ees0tmp)
3614                 else
3615                   ees0mij=0
3616                 endif
3617 c               ees0mij=0.0D0
3618                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3619                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3620 C Diagnostics. Comment out or remove after debugging!
3621 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3622 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3623 c               ees0m(num_conti,i)=0.0D0
3624 C End diagnostics.
3625 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3626 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3627 C Angular derivatives of the contact function
3628                 ees0pij1=fac3/ees0pij
3629                 ees0mij1=fac3/ees0mij
3630                 fac3p=-3.0D0*fac3*rrmij
3631                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3632                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3633 c               ees0mij1=0.0D0
3634                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3635                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3636                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3637                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3638                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3639                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3640                 ecosap=ecosa1+ecosa2
3641                 ecosbp=ecosb1+ecosb2
3642                 ecosgp=ecosg1+ecosg2
3643                 ecosam=ecosa1-ecosa2
3644                 ecosbm=ecosb1-ecosb2
3645                 ecosgm=ecosg1-ecosg2
3646 C Diagnostics
3647 c               ecosap=ecosa1
3648 c               ecosbp=ecosb1
3649 c               ecosgp=ecosg1
3650 c               ecosam=0.0D0
3651 c               ecosbm=0.0D0
3652 c               ecosgm=0.0D0
3653 C End diagnostics
3654                 facont_hb(num_conti,i)=fcont
3655                 fprimcont=fprimcont/rij
3656 cd              facont_hb(num_conti,i)=1.0D0
3657 C Following line is for diagnostics.
3658 cd              fprimcont=0.0D0
3659                 do k=1,3
3660                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3661                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3662                 enddo
3663                 do k=1,3
3664                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3665                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3666                 enddo
3667                 gggp(1)=gggp(1)+ees0pijp*xj
3668                 gggp(2)=gggp(2)+ees0pijp*yj
3669                 gggp(3)=gggp(3)+ees0pijp*zj
3670                 gggm(1)=gggm(1)+ees0mijp*xj
3671                 gggm(2)=gggm(2)+ees0mijp*yj
3672                 gggm(3)=gggm(3)+ees0mijp*zj
3673 C Derivatives due to the contact function
3674                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3675                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3676                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3677                 do k=1,3
3678 c
3679 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3680 c          following the change of gradient-summation algorithm.
3681 c
3682 cgrad                  ghalfp=0.5D0*gggp(k)
3683 cgrad                  ghalfm=0.5D0*gggm(k)
3684                   gacontp_hb1(k,num_conti,i)=!ghalfp
3685      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3686      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3687                   gacontp_hb2(k,num_conti,i)=!ghalfp
3688      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3689      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3690                   gacontp_hb3(k,num_conti,i)=gggp(k)
3691                   gacontm_hb1(k,num_conti,i)=!ghalfm
3692      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3693      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3694                   gacontm_hb2(k,num_conti,i)=!ghalfm
3695      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3696      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3697                   gacontm_hb3(k,num_conti,i)=gggm(k)
3698                 enddo
3699 C Diagnostics. Comment out or remove after debugging!
3700 cdiag           do k=1,3
3701 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3702 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3703 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3704 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3705 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3706 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3707 cdiag           enddo
3708               ENDIF ! wcorr
3709               endif  ! num_conti.le.maxconts
3710             endif  ! fcont.gt.0
3711           endif    ! j.gt.i+1
3712           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3713             do k=1,4
3714               do l=1,3
3715                 ghalf=0.5d0*agg(l,k)
3716                 aggi(l,k)=aggi(l,k)+ghalf
3717                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3718                 aggj(l,k)=aggj(l,k)+ghalf
3719               enddo
3720             enddo
3721             if (j.eq.nres-1 .and. i.lt.j-2) then
3722               do k=1,4
3723                 do l=1,3
3724                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3725                 enddo
3726               enddo
3727             endif
3728           endif
3729 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3730       return
3731       end
3732 C-----------------------------------------------------------------------------
3733       subroutine eturn3(i,eello_turn3)
3734 C Third- and fourth-order contributions from turns
3735       implicit real*8 (a-h,o-z)
3736       include 'DIMENSIONS'
3737       include 'COMMON.IOUNITS'
3738       include 'COMMON.GEO'
3739       include 'COMMON.VAR'
3740       include 'COMMON.LOCAL'
3741       include 'COMMON.CHAIN'
3742       include 'COMMON.DERIV'
3743       include 'COMMON.INTERACT'
3744       include 'COMMON.CONTACTS'
3745       include 'COMMON.TORSION'
3746       include 'COMMON.VECTORS'
3747       include 'COMMON.FFIELD'
3748       include 'COMMON.CONTROL'
3749       dimension ggg(3)
3750       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3751      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3752      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3753       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3754      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3755       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3756      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3757      &    num_conti,j1,j2
3758       j=i+2
3759 c      write (iout,*) "eturn3",i,j,j1,j2
3760       a_temp(1,1)=a22
3761       a_temp(1,2)=a23
3762       a_temp(2,1)=a32
3763       a_temp(2,2)=a33
3764 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3765 C
3766 C               Third-order contributions
3767 C
3768 C                 (i+2)o----(i+3)
3769 C                      | |
3770 C                      | |
3771 C                 (i+1)o----i
3772 C
3773 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3774 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3775         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3776         call transpose2(auxmat(1,1),auxmat1(1,1))
3777         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3778         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3779         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3780      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3781 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3782 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3783 cd     &    ' eello_turn3_num',4*eello_turn3_num
3784 C Derivatives in gamma(i)
3785         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3786         call transpose2(auxmat2(1,1),auxmat3(1,1))
3787         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3788         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3789 C Derivatives in gamma(i+1)
3790         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3791         call transpose2(auxmat2(1,1),auxmat3(1,1))
3792         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3793         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3794      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3795 C Cartesian derivatives
3796         do l=1,3
3797 c            ghalf1=0.5d0*agg(l,1)
3798 c            ghalf2=0.5d0*agg(l,2)
3799 c            ghalf3=0.5d0*agg(l,3)
3800 c            ghalf4=0.5d0*agg(l,4)
3801           a_temp(1,1)=aggi(l,1)!+ghalf1
3802           a_temp(1,2)=aggi(l,2)!+ghalf2
3803           a_temp(2,1)=aggi(l,3)!+ghalf3
3804           a_temp(2,2)=aggi(l,4)!+ghalf4
3805           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3806           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3807      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3808           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3809           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3810           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3811           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3812           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3813           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3814      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3815           a_temp(1,1)=aggj(l,1)!+ghalf1
3816           a_temp(1,2)=aggj(l,2)!+ghalf2
3817           a_temp(2,1)=aggj(l,3)!+ghalf3
3818           a_temp(2,2)=aggj(l,4)!+ghalf4
3819           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3820           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3821      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3822           a_temp(1,1)=aggj1(l,1)
3823           a_temp(1,2)=aggj1(l,2)
3824           a_temp(2,1)=aggj1(l,3)
3825           a_temp(2,2)=aggj1(l,4)
3826           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3827           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3828      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3829         enddo
3830       return
3831       end
3832 C-------------------------------------------------------------------------------
3833       subroutine eturn4(i,eello_turn4)
3834 C Third- and fourth-order contributions from turns
3835       implicit real*8 (a-h,o-z)
3836       include 'DIMENSIONS'
3837       include 'COMMON.IOUNITS'
3838       include 'COMMON.GEO'
3839       include 'COMMON.VAR'
3840       include 'COMMON.LOCAL'
3841       include 'COMMON.CHAIN'
3842       include 'COMMON.DERIV'
3843       include 'COMMON.INTERACT'
3844       include 'COMMON.CONTACTS'
3845       include 'COMMON.TORSION'
3846       include 'COMMON.VECTORS'
3847       include 'COMMON.FFIELD'
3848       include 'COMMON.CONTROL'
3849       dimension ggg(3)
3850       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3851      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3852      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3853       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3854      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3855       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3856      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3857      &    num_conti,j1,j2
3858       j=i+3
3859 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3860 C
3861 C               Fourth-order contributions
3862 C
3863 C                 (i+3)o----(i+4)
3864 C                     /  |
3865 C               (i+2)o   |
3866 C                     \  |
3867 C                 (i+1)o----i
3868 C
3869 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3870 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3871 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3872         a_temp(1,1)=a22
3873         a_temp(1,2)=a23
3874         a_temp(2,1)=a32
3875         a_temp(2,2)=a33
3876         iti1=itortyp(itype(i+1))
3877         iti2=itortyp(itype(i+2))
3878         iti3=itortyp(itype(i+3))
3879 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3880         call transpose2(EUg(1,1,i+1),e1t(1,1))
3881         call transpose2(Eug(1,1,i+2),e2t(1,1))
3882         call transpose2(Eug(1,1,i+3),e3t(1,1))
3883         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3884         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3885         s1=scalar2(b1(1,iti2),auxvec(1))
3886         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3887         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3888         s2=scalar2(b1(1,iti1),auxvec(1))
3889         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3890         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3891         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3892         eello_turn4=eello_turn4-(s1+s2+s3)
3893         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3894      &      'eturn4',i,j,-(s1+s2+s3)
3895 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3896 cd     &    ' eello_turn4_num',8*eello_turn4_num
3897 C Derivatives in gamma(i)
3898         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3899         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3900         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3901         s1=scalar2(b1(1,iti2),auxvec(1))
3902         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3903         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3904         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3905 C Derivatives in gamma(i+1)
3906         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3907         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3908         s2=scalar2(b1(1,iti1),auxvec(1))
3909         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3910         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3911         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3912         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3913 C Derivatives in gamma(i+2)
3914         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3915         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3916         s1=scalar2(b1(1,iti2),auxvec(1))
3917         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3918         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3919         s2=scalar2(b1(1,iti1),auxvec(1))
3920         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3921         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3922         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3923         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3924 C Cartesian derivatives
3925 C Derivatives of this turn contributions in DC(i+2)
3926         if (j.lt.nres-1) then
3927           do l=1,3
3928             a_temp(1,1)=agg(l,1)
3929             a_temp(1,2)=agg(l,2)
3930             a_temp(2,1)=agg(l,3)
3931             a_temp(2,2)=agg(l,4)
3932             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3933             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3934             s1=scalar2(b1(1,iti2),auxvec(1))
3935             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3936             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3937             s2=scalar2(b1(1,iti1),auxvec(1))
3938             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3939             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3940             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3941             ggg(l)=-(s1+s2+s3)
3942             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3943           enddo
3944         endif
3945 C Remaining derivatives of this turn contribution
3946         do l=1,3
3947           a_temp(1,1)=aggi(l,1)
3948           a_temp(1,2)=aggi(l,2)
3949           a_temp(2,1)=aggi(l,3)
3950           a_temp(2,2)=aggi(l,4)
3951           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3952           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3953           s1=scalar2(b1(1,iti2),auxvec(1))
3954           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3955           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3956           s2=scalar2(b1(1,iti1),auxvec(1))
3957           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3958           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3959           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3960           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3961           a_temp(1,1)=aggi1(l,1)
3962           a_temp(1,2)=aggi1(l,2)
3963           a_temp(2,1)=aggi1(l,3)
3964           a_temp(2,2)=aggi1(l,4)
3965           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3966           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3967           s1=scalar2(b1(1,iti2),auxvec(1))
3968           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3969           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3970           s2=scalar2(b1(1,iti1),auxvec(1))
3971           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3972           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3973           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3974           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3975           a_temp(1,1)=aggj(l,1)
3976           a_temp(1,2)=aggj(l,2)
3977           a_temp(2,1)=aggj(l,3)
3978           a_temp(2,2)=aggj(l,4)
3979           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3980           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3981           s1=scalar2(b1(1,iti2),auxvec(1))
3982           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3983           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3984           s2=scalar2(b1(1,iti1),auxvec(1))
3985           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3986           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3987           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3988           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3989           a_temp(1,1)=aggj1(l,1)
3990           a_temp(1,2)=aggj1(l,2)
3991           a_temp(2,1)=aggj1(l,3)
3992           a_temp(2,2)=aggj1(l,4)
3993           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3994           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3995           s1=scalar2(b1(1,iti2),auxvec(1))
3996           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3997           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3998           s2=scalar2(b1(1,iti1),auxvec(1))
3999           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4000           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4001           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4002 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4003           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4004         enddo
4005       return
4006       end
4007 C-----------------------------------------------------------------------------
4008       subroutine vecpr(u,v,w)
4009       implicit real*8(a-h,o-z)
4010       dimension u(3),v(3),w(3)
4011       w(1)=u(2)*v(3)-u(3)*v(2)
4012       w(2)=-u(1)*v(3)+u(3)*v(1)
4013       w(3)=u(1)*v(2)-u(2)*v(1)
4014       return
4015       end
4016 C-----------------------------------------------------------------------------
4017       subroutine unormderiv(u,ugrad,unorm,ungrad)
4018 C This subroutine computes the derivatives of a normalized vector u, given
4019 C the derivatives computed without normalization conditions, ugrad. Returns
4020 C ungrad.
4021       implicit none
4022       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4023       double precision vec(3)
4024       double precision scalar
4025       integer i,j
4026 c      write (2,*) 'ugrad',ugrad
4027 c      write (2,*) 'u',u
4028       do i=1,3
4029         vec(i)=scalar(ugrad(1,i),u(1))
4030       enddo
4031 c      write (2,*) 'vec',vec
4032       do i=1,3
4033         do j=1,3
4034           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4035         enddo
4036       enddo
4037 c      write (2,*) 'ungrad',ungrad
4038       return
4039       end
4040 C-----------------------------------------------------------------------------
4041       subroutine escp_soft_sphere(evdw2,evdw2_14)
4042 C
4043 C This subroutine calculates the excluded-volume interaction energy between
4044 C peptide-group centers and side chains and its gradient in virtual-bond and
4045 C side-chain vectors.
4046 C
4047       implicit real*8 (a-h,o-z)
4048       include 'DIMENSIONS'
4049       include 'COMMON.GEO'
4050       include 'COMMON.VAR'
4051       include 'COMMON.LOCAL'
4052       include 'COMMON.CHAIN'
4053       include 'COMMON.DERIV'
4054       include 'COMMON.INTERACT'
4055       include 'COMMON.FFIELD'
4056       include 'COMMON.IOUNITS'
4057       include 'COMMON.CONTROL'
4058       dimension ggg(3)
4059       evdw2=0.0D0
4060       evdw2_14=0.0d0
4061       r0_scp=4.5d0
4062 cd    print '(a)','Enter ESCP'
4063 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4064       do i=iatscp_s,iatscp_e
4065         iteli=itel(i)
4066         xi=0.5D0*(c(1,i)+c(1,i+1))
4067         yi=0.5D0*(c(2,i)+c(2,i+1))
4068         zi=0.5D0*(c(3,i)+c(3,i+1))
4069
4070         do iint=1,nscp_gr(i)
4071
4072         do j=iscpstart(i,iint),iscpend(i,iint)
4073           itypj=itype(j)
4074 C Uncomment following three lines for SC-p interactions
4075 c         xj=c(1,nres+j)-xi
4076 c         yj=c(2,nres+j)-yi
4077 c         zj=c(3,nres+j)-zi
4078 C Uncomment following three lines for Ca-p interactions
4079           xj=c(1,j)-xi
4080           yj=c(2,j)-yi
4081           zj=c(3,j)-zi
4082           rij=xj*xj+yj*yj+zj*zj
4083           r0ij=r0_scp
4084           r0ijsq=r0ij*r0ij
4085           if (rij.lt.r0ijsq) then
4086             evdwij=0.25d0*(rij-r0ijsq)**2
4087             fac=rij-r0ijsq
4088           else
4089             evdwij=0.0d0
4090             fac=0.0d0
4091           endif
4092           evdw2=evdw2+evdwij
4093 C
4094 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4095 C
4096           ggg(1)=xj*fac
4097           ggg(2)=yj*fac
4098           ggg(3)=zj*fac
4099 cgrad          if (j.lt.i) then
4100 cd          write (iout,*) 'j<i'
4101 C Uncomment following three lines for SC-p interactions
4102 c           do k=1,3
4103 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4104 c           enddo
4105 cgrad          else
4106 cd          write (iout,*) 'j>i'
4107 cgrad            do k=1,3
4108 cgrad              ggg(k)=-ggg(k)
4109 C Uncomment following line for SC-p interactions
4110 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4111 cgrad            enddo
4112 cgrad          endif
4113 cgrad          do k=1,3
4114 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4115 cgrad          enddo
4116 cgrad          kstart=min0(i+1,j)
4117 cgrad          kend=max0(i-1,j-1)
4118 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4119 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4120 cgrad          do k=kstart,kend
4121 cgrad            do l=1,3
4122 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4123 cgrad            enddo
4124 cgrad          enddo
4125           do k=1,3
4126             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4127             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4128           enddo
4129         enddo
4130
4131         enddo ! iint
4132       enddo ! i
4133       return
4134       end
4135 C-----------------------------------------------------------------------------
4136       subroutine escp(evdw2,evdw2_14)
4137 C
4138 C This subroutine calculates the excluded-volume interaction energy between
4139 C peptide-group centers and side chains and its gradient in virtual-bond and
4140 C side-chain vectors.
4141 C
4142       implicit real*8 (a-h,o-z)
4143       include 'DIMENSIONS'
4144       include 'COMMON.GEO'
4145       include 'COMMON.VAR'
4146       include 'COMMON.LOCAL'
4147       include 'COMMON.CHAIN'
4148       include 'COMMON.DERIV'
4149       include 'COMMON.INTERACT'
4150       include 'COMMON.FFIELD'
4151       include 'COMMON.IOUNITS'
4152       include 'COMMON.CONTROL'
4153       dimension ggg(3)
4154       evdw2=0.0D0
4155       evdw2_14=0.0d0
4156 cd    print '(a)','Enter ESCP'
4157 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4158       do i=iatscp_s,iatscp_e
4159         iteli=itel(i)
4160         xi=0.5D0*(c(1,i)+c(1,i+1))
4161         yi=0.5D0*(c(2,i)+c(2,i+1))
4162         zi=0.5D0*(c(3,i)+c(3,i+1))
4163
4164         do iint=1,nscp_gr(i)
4165
4166         do j=iscpstart(i,iint),iscpend(i,iint)
4167           itypj=itype(j)
4168 C Uncomment following three lines for SC-p interactions
4169 c         xj=c(1,nres+j)-xi
4170 c         yj=c(2,nres+j)-yi
4171 c         zj=c(3,nres+j)-zi
4172 C Uncomment following three lines for Ca-p interactions
4173           xj=c(1,j)-xi
4174           yj=c(2,j)-yi
4175           zj=c(3,j)-zi
4176           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4177           fac=rrij**expon2
4178           e1=fac*fac*aad(itypj,iteli)
4179           e2=fac*bad(itypj,iteli)
4180           if (iabs(j-i) .le. 2) then
4181             e1=scal14*e1
4182             e2=scal14*e2
4183             evdw2_14=evdw2_14+e1+e2
4184           endif
4185           evdwij=e1+e2
4186           evdw2=evdw2+evdwij
4187           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4188      &        'evdw2',i,j,evdwij
4189 C
4190 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4191 C
4192           fac=-(evdwij+e1)*rrij
4193           ggg(1)=xj*fac
4194           ggg(2)=yj*fac
4195           ggg(3)=zj*fac
4196 cgrad          if (j.lt.i) then
4197 cd          write (iout,*) 'j<i'
4198 C Uncomment following three lines for SC-p interactions
4199 c           do k=1,3
4200 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4201 c           enddo
4202 cgrad          else
4203 cd          write (iout,*) 'j>i'
4204 cgrad            do k=1,3
4205 cgrad              ggg(k)=-ggg(k)
4206 C Uncomment following line for SC-p interactions
4207 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4208 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4209 cgrad            enddo
4210 cgrad          endif
4211 cgrad          do k=1,3
4212 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4213 cgrad          enddo
4214 cgrad          kstart=min0(i+1,j)
4215 cgrad          kend=max0(i-1,j-1)
4216 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4217 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4218 cgrad          do k=kstart,kend
4219 cgrad            do l=1,3
4220 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4221 cgrad            enddo
4222 cgrad          enddo
4223           do k=1,3
4224             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4225             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4226           enddo
4227         enddo
4228
4229         enddo ! iint
4230       enddo ! i
4231       do i=1,nct
4232         do j=1,3
4233           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4234           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4235           gradx_scp(j,i)=expon*gradx_scp(j,i)
4236         enddo
4237       enddo
4238 C******************************************************************************
4239 C
4240 C                              N O T E !!!
4241 C
4242 C To save time the factor EXPON has been extracted from ALL components
4243 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4244 C use!
4245 C
4246 C******************************************************************************
4247       return
4248       end
4249 C--------------------------------------------------------------------------
4250       subroutine edis(ehpb)
4251 C
4252 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4253 C
4254       implicit real*8 (a-h,o-z)
4255       include 'DIMENSIONS'
4256       include 'COMMON.SBRIDGE'
4257       include 'COMMON.CHAIN'
4258       include 'COMMON.DERIV'
4259       include 'COMMON.VAR'
4260       include 'COMMON.INTERACT'
4261       include 'COMMON.IOUNITS'
4262       dimension ggg(3)
4263       ehpb=0.0D0
4264 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4265 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4266       if (link_end.eq.0) return
4267       do i=link_start,link_end
4268 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4269 C CA-CA distance used in regularization of structure.
4270         ii=ihpb(i)
4271         jj=jhpb(i)
4272 C iii and jjj point to the residues for which the distance is assigned.
4273         if (ii.gt.nres) then
4274           iii=ii-nres
4275           jjj=jj-nres
4276         else
4277           iii=ii
4278           jjj=jj
4279         endif
4280 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4281 c     &    dhpb(i),dhpb1(i),forcon(i)
4282 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4283 C    distance and angle dependent SS bond potential.
4284         if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4285           call ssbond_ene(iii,jjj,eij)
4286           ehpb=ehpb+2*eij
4287 cd          write (iout,*) "eij",eij
4288         else if (ii.gt.nres .and. jj.gt.nres) then
4289 c Restraints from contact prediction
4290           dd=dist(ii,jj)
4291           if (dhpb1(i).gt.0.0d0) then
4292             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4293             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4294 c            write (iout,*) "beta nmr",
4295 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4296           else
4297             dd=dist(ii,jj)
4298             rdis=dd-dhpb(i)
4299 C Get the force constant corresponding to this distance.
4300             waga=forcon(i)
4301 C Calculate the contribution to energy.
4302             ehpb=ehpb+waga*rdis*rdis
4303 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
4304 C
4305 C Evaluate gradient.
4306 C
4307             fac=waga*rdis/dd
4308           endif
4309           do j=1,3
4310             ggg(j)=fac*(c(j,jj)-c(j,ii))
4311           enddo
4312           do j=1,3
4313             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4314             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4315           enddo
4316           do k=1,3
4317             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4318             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4319           enddo
4320         else
4321 C Calculate the distance between the two points and its difference from the
4322 C target distance.
4323           dd=dist(ii,jj)
4324           if (dhpb1(i).gt.0.0d0) then
4325             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4326             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4327 c            write (iout,*) "alph nmr",
4328 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4329           else
4330             rdis=dd-dhpb(i)
4331 C Get the force constant corresponding to this distance.
4332             waga=forcon(i)
4333 C Calculate the contribution to energy.
4334             ehpb=ehpb+waga*rdis*rdis
4335 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
4336 C
4337 C Evaluate gradient.
4338 C
4339             fac=waga*rdis/dd
4340           endif
4341 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4342 cd   &   ' waga=',waga,' fac=',fac
4343             do j=1,3
4344               ggg(j)=fac*(c(j,jj)-c(j,ii))
4345             enddo
4346 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4347 C If this is a SC-SC distance, we need to calculate the contributions to the
4348 C Cartesian gradient in the SC vectors (ghpbx).
4349           if (iii.lt.ii) then
4350           do j=1,3
4351             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4352             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4353           enddo
4354           endif
4355 cgrad        do j=iii,jjj-1
4356 cgrad          do k=1,3
4357 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4358 cgrad          enddo
4359 cgrad        enddo
4360           do k=1,3
4361             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4362             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4363           enddo
4364         endif
4365       enddo
4366       ehpb=0.5D0*ehpb
4367       return
4368       end
4369 C--------------------------------------------------------------------------
4370       subroutine ssbond_ene(i,j,eij)
4371 C
4372 C Calculate the distance and angle dependent SS-bond potential energy
4373 C using a free-energy function derived based on RHF/6-31G** ab initio
4374 C calculations of diethyl disulfide.
4375 C
4376 C A. Liwo and U. Kozlowska, 11/24/03
4377 C
4378       implicit real*8 (a-h,o-z)
4379       include 'DIMENSIONS'
4380       include 'COMMON.SBRIDGE'
4381       include 'COMMON.CHAIN'
4382       include 'COMMON.DERIV'
4383       include 'COMMON.LOCAL'
4384       include 'COMMON.INTERACT'
4385       include 'COMMON.VAR'
4386       include 'COMMON.IOUNITS'
4387       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4388       itypi=itype(i)
4389       xi=c(1,nres+i)
4390       yi=c(2,nres+i)
4391       zi=c(3,nres+i)
4392       dxi=dc_norm(1,nres+i)
4393       dyi=dc_norm(2,nres+i)
4394       dzi=dc_norm(3,nres+i)
4395 c      dsci_inv=dsc_inv(itypi)
4396       dsci_inv=vbld_inv(nres+i)
4397       itypj=itype(j)
4398 c      dscj_inv=dsc_inv(itypj)
4399       dscj_inv=vbld_inv(nres+j)
4400       xj=c(1,nres+j)-xi
4401       yj=c(2,nres+j)-yi
4402       zj=c(3,nres+j)-zi
4403       dxj=dc_norm(1,nres+j)
4404       dyj=dc_norm(2,nres+j)
4405       dzj=dc_norm(3,nres+j)
4406       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4407       rij=dsqrt(rrij)
4408       erij(1)=xj*rij
4409       erij(2)=yj*rij
4410       erij(3)=zj*rij
4411       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4412       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4413       om12=dxi*dxj+dyi*dyj+dzi*dzj
4414       do k=1,3
4415         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4416         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4417       enddo
4418       rij=1.0d0/rij
4419       deltad=rij-d0cm
4420       deltat1=1.0d0-om1
4421       deltat2=1.0d0+om2
4422       deltat12=om2-om1+2.0d0
4423       cosphi=om12-om1*om2
4424       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4425      &  +akct*deltad*deltat12
4426      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4427 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4428 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4429 c     &  " deltat12",deltat12," eij",eij
4430       ed=2*akcm*deltad+akct*deltat12
4431       pom1=akct*deltad
4432       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4433       eom1=-2*akth*deltat1-pom1-om2*pom2
4434       eom2= 2*akth*deltat2+pom1-om1*pom2
4435       eom12=pom2
4436       do k=1,3
4437         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4438         ghpbx(k,i)=ghpbx(k,i)-ggk
4439      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4440      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4441         ghpbx(k,j)=ghpbx(k,j)+ggk
4442      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4443      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4444         ghpbc(k,i)=ghpbc(k,i)-ggk
4445         ghpbc(k,j)=ghpbc(k,j)+ggk
4446       enddo
4447 C
4448 C Calculate the components of the gradient in DC and X
4449 C
4450 cgrad      do k=i,j-1
4451 cgrad        do l=1,3
4452 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4453 cgrad        enddo
4454 cgrad      enddo
4455       return
4456       end
4457 C--------------------------------------------------------------------------
4458       subroutine ebond(estr)
4459 c
4460 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4461 c
4462       implicit real*8 (a-h,o-z)
4463       include 'DIMENSIONS'
4464       include 'COMMON.LOCAL'
4465       include 'COMMON.GEO'
4466       include 'COMMON.INTERACT'
4467       include 'COMMON.DERIV'
4468       include 'COMMON.VAR'
4469       include 'COMMON.CHAIN'
4470       include 'COMMON.IOUNITS'
4471       include 'COMMON.NAMES'
4472       include 'COMMON.FFIELD'
4473       include 'COMMON.CONTROL'
4474       include 'COMMON.SETUP'
4475       double precision u(3),ud(3)
4476       estr=0.0d0
4477       do i=ibondp_start,ibondp_end
4478         diff = vbld(i)-vbldp0
4479 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4480         estr=estr+diff*diff
4481         do j=1,3
4482           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4483         enddo
4484 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4485       enddo
4486       estr=0.5d0*AKP*estr
4487 c
4488 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4489 c
4490       do i=ibond_start,ibond_end
4491         iti=itype(i)
4492         if (iti.ne.10) then
4493           nbi=nbondterm(iti)
4494           if (nbi.eq.1) then
4495             diff=vbld(i+nres)-vbldsc0(1,iti)
4496 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4497 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4498             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4499             do j=1,3
4500               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4501             enddo
4502           else
4503             do j=1,nbi
4504               diff=vbld(i+nres)-vbldsc0(j,iti)
4505               ud(j)=aksc(j,iti)*diff
4506               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4507             enddo
4508             uprod=u(1)
4509             do j=2,nbi
4510               uprod=uprod*u(j)
4511             enddo
4512             usum=0.0d0
4513             usumsqder=0.0d0
4514             do j=1,nbi
4515               uprod1=1.0d0
4516               uprod2=1.0d0
4517               do k=1,nbi
4518                 if (k.ne.j) then
4519                   uprod1=uprod1*u(k)
4520                   uprod2=uprod2*u(k)*u(k)
4521                 endif
4522               enddo
4523               usum=usum+uprod1
4524               usumsqder=usumsqder+ud(j)*uprod2
4525             enddo
4526             estr=estr+uprod/usum
4527             do j=1,3
4528              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4529             enddo
4530           endif
4531         endif
4532       enddo
4533       return
4534       end
4535 #ifdef CRYST_THETA
4536 C--------------------------------------------------------------------------
4537       subroutine ebend(etheta)
4538 C
4539 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4540 C angles gamma and its derivatives in consecutive thetas and gammas.
4541 C
4542       implicit real*8 (a-h,o-z)
4543       include 'DIMENSIONS'
4544       include 'COMMON.LOCAL'
4545       include 'COMMON.GEO'
4546       include 'COMMON.INTERACT'
4547       include 'COMMON.DERIV'
4548       include 'COMMON.VAR'
4549       include 'COMMON.CHAIN'
4550       include 'COMMON.IOUNITS'
4551       include 'COMMON.NAMES'
4552       include 'COMMON.FFIELD'
4553       include 'COMMON.CONTROL'
4554       common /calcthet/ term1,term2,termm,diffak,ratak,
4555      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4556      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4557       double precision y(2),z(2)
4558       delta=0.02d0*pi
4559 c      time11=dexp(-2*time)
4560 c      time12=1.0d0
4561       etheta=0.0D0
4562 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4563       do i=ithet_start,ithet_end
4564 C Zero the energy function and its derivative at 0 or pi.
4565         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4566         it=itype(i-1)
4567         if (i.gt.3) then
4568 #ifdef OSF
4569           phii=phi(i)
4570           if (phii.ne.phii) phii=150.0
4571 #else
4572           phii=phi(i)
4573 #endif
4574           y(1)=dcos(phii)
4575           y(2)=dsin(phii)
4576         else
4577           y(1)=0.0D0
4578           y(2)=0.0D0
4579         endif
4580         if (i.lt.nres) then
4581 #ifdef OSF
4582           phii1=phi(i+1)
4583           if (phii1.ne.phii1) phii1=150.0
4584           phii1=pinorm(phii1)
4585           z(1)=cos(phii1)
4586 #else
4587           phii1=phi(i+1)
4588           z(1)=dcos(phii1)
4589 #endif
4590           z(2)=dsin(phii1)
4591         else
4592           z(1)=0.0D0
4593           z(2)=0.0D0
4594         endif
4595 C Calculate the "mean" value of theta from the part of the distribution
4596 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4597 C In following comments this theta will be referred to as t_c.
4598         thet_pred_mean=0.0d0
4599         do k=1,2
4600           athetk=athet(k,it)
4601           bthetk=bthet(k,it)
4602           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4603         enddo
4604         dthett=thet_pred_mean*ssd
4605         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4606 C Derivatives of the "mean" values in gamma1 and gamma2.
4607         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
4608         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
4609         if (theta(i).gt.pi-delta) then
4610           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4611      &         E_tc0)
4612           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4613           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4614           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4615      &        E_theta)
4616           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4617      &        E_tc)
4618         else if (theta(i).lt.delta) then
4619           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4620           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4621           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4622      &        E_theta)
4623           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4624           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4625      &        E_tc)
4626         else
4627           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4628      &        E_theta,E_tc)
4629         endif
4630         etheta=etheta+ethetai
4631         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4632      &      'ebend',i,ethetai
4633         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4634         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4635         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4636       enddo
4637 C Ufff.... We've done all this!!!
4638       return
4639       end
4640 C---------------------------------------------------------------------------
4641       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4642      &     E_tc)
4643       implicit real*8 (a-h,o-z)
4644       include 'DIMENSIONS'
4645       include 'COMMON.LOCAL'
4646       include 'COMMON.IOUNITS'
4647       common /calcthet/ term1,term2,termm,diffak,ratak,
4648      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4649      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4650 C Calculate the contributions to both Gaussian lobes.
4651 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4652 C The "polynomial part" of the "standard deviation" of this part of
4653 C the distribution.
4654         sig=polthet(3,it)
4655         do j=2,0,-1
4656           sig=sig*thet_pred_mean+polthet(j,it)
4657         enddo
4658 C Derivative of the "interior part" of the "standard deviation of the"
4659 C gamma-dependent Gaussian lobe in t_c.
4660         sigtc=3*polthet(3,it)
4661         do j=2,1,-1
4662           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4663         enddo
4664         sigtc=sig*sigtc
4665 C Set the parameters of both Gaussian lobes of the distribution.
4666 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4667         fac=sig*sig+sigc0(it)
4668         sigcsq=fac+fac
4669         sigc=1.0D0/sigcsq
4670 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4671         sigsqtc=-4.0D0*sigcsq*sigtc
4672 c       print *,i,sig,sigtc,sigsqtc
4673 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4674         sigtc=-sigtc/(fac*fac)
4675 C Following variable is sigma(t_c)**(-2)
4676         sigcsq=sigcsq*sigcsq
4677         sig0i=sig0(it)
4678         sig0inv=1.0D0/sig0i**2
4679         delthec=thetai-thet_pred_mean
4680         delthe0=thetai-theta0i
4681         term1=-0.5D0*sigcsq*delthec*delthec
4682         term2=-0.5D0*sig0inv*delthe0*delthe0
4683 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4684 C NaNs in taking the logarithm. We extract the largest exponent which is added
4685 C to the energy (this being the log of the distribution) at the end of energy
4686 C term evaluation for this virtual-bond angle.
4687         if (term1.gt.term2) then
4688           termm=term1
4689           term2=dexp(term2-termm)
4690           term1=1.0d0
4691         else
4692           termm=term2
4693           term1=dexp(term1-termm)
4694           term2=1.0d0
4695         endif
4696 C The ratio between the gamma-independent and gamma-dependent lobes of
4697 C the distribution is a Gaussian function of thet_pred_mean too.
4698         diffak=gthet(2,it)-thet_pred_mean
4699         ratak=diffak/gthet(3,it)**2
4700         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4701 C Let's differentiate it in thet_pred_mean NOW.
4702         aktc=ak*ratak
4703 C Now put together the distribution terms to make complete distribution.
4704         termexp=term1+ak*term2
4705         termpre=sigc+ak*sig0i
4706 C Contribution of the bending energy from this theta is just the -log of
4707 C the sum of the contributions from the two lobes and the pre-exponential
4708 C factor. Simple enough, isn't it?
4709         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4710 C NOW the derivatives!!!
4711 C 6/6/97 Take into account the deformation.
4712         E_theta=(delthec*sigcsq*term1
4713      &       +ak*delthe0*sig0inv*term2)/termexp
4714         E_tc=((sigtc+aktc*sig0i)/termpre
4715      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4716      &       aktc*term2)/termexp)
4717       return
4718       end
4719 c-----------------------------------------------------------------------------
4720       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4721       implicit real*8 (a-h,o-z)
4722       include 'DIMENSIONS'
4723       include 'COMMON.LOCAL'
4724       include 'COMMON.IOUNITS'
4725       common /calcthet/ term1,term2,termm,diffak,ratak,
4726      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4727      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4728       delthec=thetai-thet_pred_mean
4729       delthe0=thetai-theta0i
4730 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4731       t3 = thetai-thet_pred_mean
4732       t6 = t3**2
4733       t9 = term1
4734       t12 = t3*sigcsq
4735       t14 = t12+t6*sigsqtc
4736       t16 = 1.0d0
4737       t21 = thetai-theta0i
4738       t23 = t21**2
4739       t26 = term2
4740       t27 = t21*t26
4741       t32 = termexp
4742       t40 = t32**2
4743       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4744      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4745      & *(-t12*t9-ak*sig0inv*t27)
4746       return
4747       end
4748 #else
4749 C--------------------------------------------------------------------------
4750       subroutine ebend(etheta)
4751 C
4752 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4753 C angles gamma and its derivatives in consecutive thetas and gammas.
4754 C ab initio-derived potentials from
4755 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4756 C
4757       implicit real*8 (a-h,o-z)
4758       include 'DIMENSIONS'
4759       include 'COMMON.LOCAL'
4760       include 'COMMON.GEO'
4761       include 'COMMON.INTERACT'
4762       include 'COMMON.DERIV'
4763       include 'COMMON.VAR'
4764       include 'COMMON.CHAIN'
4765       include 'COMMON.IOUNITS'
4766       include 'COMMON.NAMES'
4767       include 'COMMON.FFIELD'
4768       include 'COMMON.CONTROL'
4769       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4770      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4771      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4772      & sinph1ph2(maxdouble,maxdouble)
4773       logical lprn /.false./, lprn1 /.false./
4774       etheta=0.0D0
4775       do i=ithet_start,ithet_end
4776         dethetai=0.0d0
4777         dephii=0.0d0
4778         dephii1=0.0d0
4779         theti2=0.5d0*theta(i)
4780         ityp2=ithetyp(itype(i-1))
4781         do k=1,nntheterm
4782           coskt(k)=dcos(k*theti2)
4783           sinkt(k)=dsin(k*theti2)
4784         enddo
4785         if (i.gt.3) then
4786 #ifdef OSF
4787           phii=phi(i)
4788           if (phii.ne.phii) phii=150.0
4789 #else
4790           phii=phi(i)
4791 #endif
4792           ityp1=ithetyp(itype(i-2))
4793           do k=1,nsingle
4794             cosph1(k)=dcos(k*phii)
4795             sinph1(k)=dsin(k*phii)
4796           enddo
4797         else
4798           phii=0.0d0
4799           ityp1=nthetyp+1
4800           do k=1,nsingle
4801             cosph1(k)=0.0d0
4802             sinph1(k)=0.0d0
4803           enddo
4804         endif
4805         if (i.lt.nres) then
4806 #ifdef OSF
4807           phii1=phi(i+1)
4808           if (phii1.ne.phii1) phii1=150.0
4809           phii1=pinorm(phii1)
4810 #else
4811           phii1=phi(i+1)
4812 #endif
4813           ityp3=ithetyp(itype(i))
4814           do k=1,nsingle
4815             cosph2(k)=dcos(k*phii1)
4816             sinph2(k)=dsin(k*phii1)
4817           enddo
4818         else
4819           phii1=0.0d0
4820           ityp3=nthetyp+1
4821           do k=1,nsingle
4822             cosph2(k)=0.0d0
4823             sinph2(k)=0.0d0
4824           enddo
4825         endif
4826         ethetai=aa0thet(ityp1,ityp2,ityp3)
4827         do k=1,ndouble
4828           do l=1,k-1
4829             ccl=cosph1(l)*cosph2(k-l)
4830             ssl=sinph1(l)*sinph2(k-l)
4831             scl=sinph1(l)*cosph2(k-l)
4832             csl=cosph1(l)*sinph2(k-l)
4833             cosph1ph2(l,k)=ccl-ssl
4834             cosph1ph2(k,l)=ccl+ssl
4835             sinph1ph2(l,k)=scl+csl
4836             sinph1ph2(k,l)=scl-csl
4837           enddo
4838         enddo
4839         if (lprn) then
4840         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4841      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4842         write (iout,*) "coskt and sinkt"
4843         do k=1,nntheterm
4844           write (iout,*) k,coskt(k),sinkt(k)
4845         enddo
4846         endif
4847         do k=1,ntheterm
4848           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4849           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4850      &      *coskt(k)
4851           if (lprn)
4852      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4853      &     " ethetai",ethetai
4854         enddo
4855         if (lprn) then
4856         write (iout,*) "cosph and sinph"
4857         do k=1,nsingle
4858           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4859         enddo
4860         write (iout,*) "cosph1ph2 and sinph2ph2"
4861         do k=2,ndouble
4862           do l=1,k-1
4863             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4864      &         sinph1ph2(l,k),sinph1ph2(k,l)
4865           enddo
4866         enddo
4867         write(iout,*) "ethetai",ethetai
4868         endif
4869         do m=1,ntheterm2
4870           do k=1,nsingle
4871             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4872      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4873      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4874      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4875             ethetai=ethetai+sinkt(m)*aux
4876             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4877             dephii=dephii+k*sinkt(m)*(
4878      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4879      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4880             dephii1=dephii1+k*sinkt(m)*(
4881      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4882      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4883             if (lprn)
4884      &      write (iout,*) "m",m," k",k," bbthet",
4885      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4886      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4887      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4888      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4889           enddo
4890         enddo
4891         if (lprn)
4892      &  write(iout,*) "ethetai",ethetai
4893         do m=1,ntheterm3
4894           do k=2,ndouble
4895             do l=1,k-1
4896               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4897      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4898      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4899      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4900               ethetai=ethetai+sinkt(m)*aux
4901               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4902               dephii=dephii+l*sinkt(m)*(
4903      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4904      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4905      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4906      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4907               dephii1=dephii1+(k-l)*sinkt(m)*(
4908      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4909      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4910      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
4911      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4912               if (lprn) then
4913               write (iout,*) "m",m," k",k," l",l," ffthet",
4914      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
4915      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
4916      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
4917      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4918               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4919      &            cosph1ph2(k,l)*sinkt(m),
4920      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4921               endif
4922             enddo
4923           enddo
4924         enddo
4925 10      continue
4926         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4927      &   i,theta(i)*rad2deg,phii*rad2deg,
4928      &   phii1*rad2deg,ethetai
4929         etheta=etheta+ethetai
4930         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4931         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4932         gloc(nphi+i-2,icg)=wang*dethetai
4933       enddo
4934       return
4935       end
4936 #endif
4937 #ifdef CRYST_SC
4938 c-----------------------------------------------------------------------------
4939       subroutine esc(escloc)
4940 C Calculate the local energy of a side chain and its derivatives in the
4941 C corresponding virtual-bond valence angles THETA and the spherical angles
4942 C ALPHA and OMEGA.
4943       implicit real*8 (a-h,o-z)
4944       include 'DIMENSIONS'
4945       include 'COMMON.GEO'
4946       include 'COMMON.LOCAL'
4947       include 'COMMON.VAR'
4948       include 'COMMON.INTERACT'
4949       include 'COMMON.DERIV'
4950       include 'COMMON.CHAIN'
4951       include 'COMMON.IOUNITS'
4952       include 'COMMON.NAMES'
4953       include 'COMMON.FFIELD'
4954       include 'COMMON.CONTROL'
4955       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4956      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4957       common /sccalc/ time11,time12,time112,theti,it,nlobit
4958       delta=0.02d0*pi
4959       escloc=0.0D0
4960 c     write (iout,'(a)') 'ESC'
4961       do i=loc_start,loc_end
4962         it=itype(i)
4963         if (it.eq.10) goto 1
4964         nlobit=nlob(it)
4965 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4966 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4967         theti=theta(i+1)-pipol
4968         x(1)=dtan(theti)
4969         x(2)=alph(i)
4970         x(3)=omeg(i)
4971
4972         if (x(2).gt.pi-delta) then
4973           xtemp(1)=x(1)
4974           xtemp(2)=pi-delta
4975           xtemp(3)=x(3)
4976           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4977           xtemp(2)=pi
4978           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4979           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4980      &        escloci,dersc(2))
4981           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4982      &        ddersc0(1),dersc(1))
4983           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4984      &        ddersc0(3),dersc(3))
4985           xtemp(2)=pi-delta
4986           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4987           xtemp(2)=pi
4988           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4989           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4990      &            dersc0(2),esclocbi,dersc02)
4991           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4992      &            dersc12,dersc01)
4993           call splinthet(x(2),0.5d0*delta,ss,ssd)
4994           dersc0(1)=dersc01
4995           dersc0(2)=dersc02
4996           dersc0(3)=0.0d0
4997           do k=1,3
4998             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4999           enddo
5000           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5001 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5002 c    &             esclocbi,ss,ssd
5003           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5004 c         escloci=esclocbi
5005 c         write (iout,*) escloci
5006         else if (x(2).lt.delta) then
5007           xtemp(1)=x(1)
5008           xtemp(2)=delta
5009           xtemp(3)=x(3)
5010           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5011           xtemp(2)=0.0d0
5012           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5013           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5014      &        escloci,dersc(2))
5015           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5016      &        ddersc0(1),dersc(1))
5017           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5018      &        ddersc0(3),dersc(3))
5019           xtemp(2)=delta
5020           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5021           xtemp(2)=0.0d0
5022           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5023           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5024      &            dersc0(2),esclocbi,dersc02)
5025           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5026      &            dersc12,dersc01)
5027           dersc0(1)=dersc01
5028           dersc0(2)=dersc02
5029           dersc0(3)=0.0d0
5030           call splinthet(x(2),0.5d0*delta,ss,ssd)
5031           do k=1,3
5032             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5033           enddo
5034           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5035 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5036 c    &             esclocbi,ss,ssd
5037           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5038 c         write (iout,*) escloci
5039         else
5040           call enesc(x,escloci,dersc,ddummy,.false.)
5041         endif
5042
5043         escloc=escloc+escloci
5044         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5045      &     'escloc',i,escloci
5046 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5047
5048         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5049      &   wscloc*dersc(1)
5050         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5051         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5052     1   continue
5053       enddo
5054       return
5055       end
5056 C---------------------------------------------------------------------------
5057       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5058       implicit real*8 (a-h,o-z)
5059       include 'DIMENSIONS'
5060       include 'COMMON.GEO'
5061       include 'COMMON.LOCAL'
5062       include 'COMMON.IOUNITS'
5063       common /sccalc/ time11,time12,time112,theti,it,nlobit
5064       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5065       double precision contr(maxlob,-1:1)
5066       logical mixed
5067 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5068         escloc_i=0.0D0
5069         do j=1,3
5070           dersc(j)=0.0D0
5071           if (mixed) ddersc(j)=0.0d0
5072         enddo
5073         x3=x(3)
5074
5075 C Because of periodicity of the dependence of the SC energy in omega we have
5076 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5077 C To avoid underflows, first compute & store the exponents.
5078
5079         do iii=-1,1
5080
5081           x(3)=x3+iii*dwapi
5082
5083           do j=1,nlobit
5084             do k=1,3
5085               z(k)=x(k)-censc(k,j,it)
5086             enddo
5087             do k=1,3
5088               Axk=0.0D0
5089               do l=1,3
5090                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5091               enddo
5092               Ax(k,j,iii)=Axk
5093             enddo
5094             expfac=0.0D0
5095             do k=1,3
5096               expfac=expfac+Ax(k,j,iii)*z(k)
5097             enddo
5098             contr(j,iii)=expfac
5099           enddo ! j
5100
5101         enddo ! iii
5102
5103         x(3)=x3
5104 C As in the case of ebend, we want to avoid underflows in exponentiation and
5105 C subsequent NaNs and INFs in energy calculation.
5106 C Find the largest exponent
5107         emin=contr(1,-1)
5108         do iii=-1,1
5109           do j=1,nlobit
5110             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5111           enddo
5112         enddo
5113         emin=0.5D0*emin
5114 cd      print *,'it=',it,' emin=',emin
5115
5116 C Compute the contribution to SC energy and derivatives
5117         do iii=-1,1
5118
5119           do j=1,nlobit
5120 #ifdef OSF
5121             adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin
5122             if(adexp.ne.adexp) adexp=1.0
5123             expfac=dexp(adexp)
5124 #else
5125             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
5126 #endif
5127 cd          print *,'j=',j,' expfac=',expfac
5128             escloc_i=escloc_i+expfac
5129             do k=1,3
5130               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5131             enddo
5132             if (mixed) then
5133               do k=1,3,2
5134                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5135      &            +gaussc(k,2,j,it))*expfac
5136               enddo
5137             endif
5138           enddo
5139
5140         enddo ! iii
5141
5142         dersc(1)=dersc(1)/cos(theti)**2
5143         ddersc(1)=ddersc(1)/cos(theti)**2
5144         ddersc(3)=ddersc(3)
5145
5146         escloci=-(dlog(escloc_i)-emin)
5147         do j=1,3
5148           dersc(j)=dersc(j)/escloc_i
5149         enddo
5150         if (mixed) then
5151           do j=1,3,2
5152             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5153           enddo
5154         endif
5155       return
5156       end
5157 C------------------------------------------------------------------------------
5158       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5159       implicit real*8 (a-h,o-z)
5160       include 'DIMENSIONS'
5161       include 'COMMON.GEO'
5162       include 'COMMON.LOCAL'
5163       include 'COMMON.IOUNITS'
5164       common /sccalc/ time11,time12,time112,theti,it,nlobit
5165       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5166       double precision contr(maxlob)
5167       logical mixed
5168
5169       escloc_i=0.0D0
5170
5171       do j=1,3
5172         dersc(j)=0.0D0
5173       enddo
5174
5175       do j=1,nlobit
5176         do k=1,2
5177           z(k)=x(k)-censc(k,j,it)
5178         enddo
5179         z(3)=dwapi
5180         do k=1,3
5181           Axk=0.0D0
5182           do l=1,3
5183             Axk=Axk+gaussc(l,k,j,it)*z(l)
5184           enddo
5185           Ax(k,j)=Axk
5186         enddo
5187         expfac=0.0D0
5188         do k=1,3
5189           expfac=expfac+Ax(k,j)*z(k)
5190         enddo
5191         contr(j)=expfac
5192       enddo ! j
5193
5194 C As in the case of ebend, we want to avoid underflows in exponentiation and
5195 C subsequent NaNs and INFs in energy calculation.
5196 C Find the largest exponent
5197       emin=contr(1)
5198       do j=1,nlobit
5199         if (emin.gt.contr(j)) emin=contr(j)
5200       enddo
5201       emin=0.5D0*emin
5202
5203 C Compute the contribution to SC energy and derivatives
5204
5205       dersc12=0.0d0
5206       do j=1,nlobit
5207         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
5208         escloc_i=escloc_i+expfac
5209         do k=1,2
5210           dersc(k)=dersc(k)+Ax(k,j)*expfac
5211         enddo
5212         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5213      &            +gaussc(1,2,j,it))*expfac
5214         dersc(3)=0.0d0
5215       enddo
5216
5217       dersc(1)=dersc(1)/cos(theti)**2
5218       dersc12=dersc12/cos(theti)**2
5219       escloci=-(dlog(escloc_i)-emin)
5220       do j=1,2
5221         dersc(j)=dersc(j)/escloc_i
5222       enddo
5223       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5224       return
5225       end
5226 #else
5227 c----------------------------------------------------------------------------------
5228       subroutine esc(escloc)
5229 C Calculate the local energy of a side chain and its derivatives in the
5230 C corresponding virtual-bond valence angles THETA and the spherical angles
5231 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5232 C added by Urszula Kozlowska. 07/11/2007
5233 C
5234       implicit real*8 (a-h,o-z)
5235       include 'DIMENSIONS'
5236       include 'COMMON.GEO'
5237       include 'COMMON.LOCAL'
5238       include 'COMMON.VAR'
5239       include 'COMMON.SCROT'
5240       include 'COMMON.INTERACT'
5241       include 'COMMON.DERIV'
5242       include 'COMMON.CHAIN'
5243       include 'COMMON.IOUNITS'
5244       include 'COMMON.NAMES'
5245       include 'COMMON.FFIELD'
5246       include 'COMMON.CONTROL'
5247       include 'COMMON.VECTORS'
5248       double precision x_prime(3),y_prime(3),z_prime(3)
5249      &    , sumene,dsc_i,dp2_i,x(65),
5250      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5251      &    de_dxx,de_dyy,de_dzz,de_dt
5252       double precision s1_t,s1_6_t,s2_t,s2_6_t
5253       double precision
5254      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5255      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5256      & dt_dCi(3),dt_dCi1(3)
5257       common /sccalc/ time11,time12,time112,theti,it,nlobit
5258       delta=0.02d0*pi
5259       escloc=0.0D0
5260       do i=loc_start,loc_end
5261         costtab(i+1) =dcos(theta(i+1))
5262         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5263         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5264         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5265         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5266         cosfac=dsqrt(cosfac2)
5267         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5268         sinfac=dsqrt(sinfac2)
5269         it=itype(i)
5270         if (it.eq.10) goto 1
5271 c
5272 C  Compute the axes of tghe local cartesian coordinates system; store in
5273 c   x_prime, y_prime and z_prime
5274 c
5275         do j=1,3
5276           x_prime(j) = 0.00
5277           y_prime(j) = 0.00
5278           z_prime(j) = 0.00
5279         enddo
5280 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5281 C     &   dc_norm(3,i+nres)
5282         do j = 1,3
5283           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5284           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5285         enddo
5286         do j = 1,3
5287           z_prime(j) = -uz(j,i-1)
5288         enddo
5289 c       write (2,*) "i",i
5290 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5291 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5292 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5293 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5294 c      & " xy",scalar(x_prime(1),y_prime(1)),
5295 c      & " xz",scalar(x_prime(1),z_prime(1)),
5296 c      & " yy",scalar(y_prime(1),y_prime(1)),
5297 c      & " yz",scalar(y_prime(1),z_prime(1)),
5298 c      & " zz",scalar(z_prime(1),z_prime(1))
5299 c
5300 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5301 C to local coordinate system. Store in xx, yy, zz.
5302 c
5303         xx=0.0d0
5304         yy=0.0d0
5305         zz=0.0d0
5306         do j = 1,3
5307           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5308           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5309           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5310         enddo
5311
5312         xxtab(i)=xx
5313         yytab(i)=yy
5314         zztab(i)=zz
5315 C
5316 C Compute the energy of the ith side cbain
5317 C
5318 c        write (2,*) "xx",xx," yy",yy," zz",zz
5319         it=itype(i)
5320         do j = 1,65
5321           x(j) = sc_parmin(j,it)
5322         enddo
5323 #ifdef CHECK_COORD
5324 Cc diagnostics - remove later
5325         xx1 = dcos(alph(2))
5326         yy1 = dsin(alph(2))*dcos(omeg(2))
5327         zz1 = -dsin(alph(2))*dsin(omeg(2))
5328         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5329      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5330      &    xx1,yy1,zz1
5331 C,"  --- ", xx_w,yy_w,zz_w
5332 c end diagnostics
5333 #endif
5334         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5335      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5336      &   + x(10)*yy*zz
5337         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5338      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5339      & + x(20)*yy*zz
5340         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5341      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5342      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5343      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5344      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5345      &  +x(40)*xx*yy*zz
5346         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5347      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5348      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5349      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5350      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5351      &  +x(60)*xx*yy*zz
5352         dsc_i   = 0.743d0+x(61)
5353         dp2_i   = 1.9d0+x(62)
5354         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5355      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5356         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5357      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5358         s1=(1+x(63))/(0.1d0 + dscp1)
5359         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5360         s2=(1+x(65))/(0.1d0 + dscp2)
5361         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5362         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5363      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5364 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5365 c     &   sumene4,
5366 c     &   dscp1,dscp2,sumene
5367 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5368         escloc = escloc + sumene
5369 c        write (2,*) "i",i," escloc",sumene,escloc
5370 #ifdef DEBUG
5371 C
5372 C This section to check the numerical derivatives of the energy of ith side
5373 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5374 C #define DEBUG in the code to turn it on.
5375 C
5376         write (2,*) "sumene               =",sumene
5377         aincr=1.0d-7
5378         xxsave=xx
5379         xx=xx+aincr
5380         write (2,*) xx,yy,zz
5381         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5382         de_dxx_num=(sumenep-sumene)/aincr
5383         xx=xxsave
5384         write (2,*) "xx+ sumene from enesc=",sumenep
5385         yysave=yy
5386         yy=yy+aincr
5387         write (2,*) xx,yy,zz
5388         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5389         de_dyy_num=(sumenep-sumene)/aincr
5390         yy=yysave
5391         write (2,*) "yy+ sumene from enesc=",sumenep
5392         zzsave=zz
5393         zz=zz+aincr
5394         write (2,*) xx,yy,zz
5395         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5396         de_dzz_num=(sumenep-sumene)/aincr
5397         zz=zzsave
5398         write (2,*) "zz+ sumene from enesc=",sumenep
5399         costsave=cost2tab(i+1)
5400         sintsave=sint2tab(i+1)
5401         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5402         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5403         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5404         de_dt_num=(sumenep-sumene)/aincr
5405         write (2,*) " t+ sumene from enesc=",sumenep
5406         cost2tab(i+1)=costsave
5407         sint2tab(i+1)=sintsave
5408 C End of diagnostics section.
5409 #endif
5410 C
5411 C Compute the gradient of esc
5412 C
5413         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5414         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5415         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5416         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5417         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5418         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5419         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5420         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5421         pom1=(sumene3*sint2tab(i+1)+sumene1)
5422      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5423         pom2=(sumene4*cost2tab(i+1)+sumene2)
5424      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5425         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5426         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5427      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5428      &  +x(40)*yy*zz
5429         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5430         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5431      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5432      &  +x(60)*yy*zz
5433         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5434      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5435      &        +(pom1+pom2)*pom_dx
5436 #ifdef DEBUG
5437         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5438 #endif
5439 C
5440         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5441         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5442      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5443      &  +x(40)*xx*zz
5444         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5445         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5446      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5447      &  +x(59)*zz**2 +x(60)*xx*zz
5448         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5449      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5450      &        +(pom1-pom2)*pom_dy
5451 #ifdef DEBUG
5452         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5453 #endif
5454 C
5455         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5456      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5457      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5458      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5459      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5460      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5461      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5462      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5463 #ifdef DEBUG
5464         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5465 #endif
5466 C
5467         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5468      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5469      &  +pom1*pom_dt1+pom2*pom_dt2
5470 #ifdef DEBUG
5471         write(2,*), "de_dt = ", de_dt,de_dt_num
5472 #endif
5473 c
5474 C
5475        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5476        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5477        cosfac2xx=cosfac2*xx
5478        sinfac2yy=sinfac2*yy
5479        do k = 1,3
5480          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5481      &      vbld_inv(i+1)
5482          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5483      &      vbld_inv(i)
5484          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5485          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5486 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5487 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5488 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5489 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5490          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5491          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5492          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5493          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5494          dZZ_Ci1(k)=0.0d0
5495          dZZ_Ci(k)=0.0d0
5496          do j=1,3
5497            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5498            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5499          enddo
5500
5501          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5502          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5503          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5504 c
5505          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5506          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5507        enddo
5508
5509        do k=1,3
5510          dXX_Ctab(k,i)=dXX_Ci(k)
5511          dXX_C1tab(k,i)=dXX_Ci1(k)
5512          dYY_Ctab(k,i)=dYY_Ci(k)
5513          dYY_C1tab(k,i)=dYY_Ci1(k)
5514          dZZ_Ctab(k,i)=dZZ_Ci(k)
5515          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5516          dXX_XYZtab(k,i)=dXX_XYZ(k)
5517          dYY_XYZtab(k,i)=dYY_XYZ(k)
5518          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5519        enddo
5520
5521        do k = 1,3
5522 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5523 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5524 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5525 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5526 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5527 c     &    dt_dci(k)
5528 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5529 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5530          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5531      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5532          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5533      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5534          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5535      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5536        enddo
5537 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5538 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5539
5540 C to check gradient call subroutine check_grad
5541
5542     1 continue
5543       enddo
5544       return
5545       end
5546 c------------------------------------------------------------------------------
5547       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5548       implicit none
5549       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5550      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5551       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5552      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5553      &   + x(10)*yy*zz
5554       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5555      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5556      & + x(20)*yy*zz
5557       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5558      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5559      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5560      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5561      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5562      &  +x(40)*xx*yy*zz
5563       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5564      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5565      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5566      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5567      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5568      &  +x(60)*xx*yy*zz
5569       dsc_i   = 0.743d0+x(61)
5570       dp2_i   = 1.9d0+x(62)
5571       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5572      &          *(xx*cost2+yy*sint2))
5573       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5574      &          *(xx*cost2-yy*sint2))
5575       s1=(1+x(63))/(0.1d0 + dscp1)
5576       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5577       s2=(1+x(65))/(0.1d0 + dscp2)
5578       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5579       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5580      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5581       enesc=sumene
5582       return
5583       end
5584 #endif
5585 c------------------------------------------------------------------------------
5586       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5587 C
5588 C This procedure calculates two-body contact function g(rij) and its derivative:
5589 C
5590 C           eps0ij                                     !       x < -1
5591 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5592 C            0                                         !       x > 1
5593 C
5594 C where x=(rij-r0ij)/delta
5595 C
5596 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5597 C
5598       implicit none
5599       double precision rij,r0ij,eps0ij,fcont,fprimcont
5600       double precision x,x2,x4,delta
5601 c     delta=0.02D0*r0ij
5602 c      delta=0.2D0*r0ij
5603       x=(rij-r0ij)/delta
5604       if (x.lt.-1.0D0) then
5605         fcont=eps0ij
5606         fprimcont=0.0D0
5607       else if (x.le.1.0D0) then
5608         x2=x*x
5609         x4=x2*x2
5610         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5611         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5612       else
5613         fcont=0.0D0
5614         fprimcont=0.0D0
5615       endif
5616       return
5617       end
5618 c------------------------------------------------------------------------------
5619       subroutine splinthet(theti,delta,ss,ssder)
5620       implicit real*8 (a-h,o-z)
5621       include 'DIMENSIONS'
5622       include 'COMMON.VAR'
5623       include 'COMMON.GEO'
5624       thetup=pi-delta
5625       thetlow=delta
5626       if (theti.gt.pipol) then
5627         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5628       else
5629         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5630         ssder=-ssder
5631       endif
5632       return
5633       end
5634 c------------------------------------------------------------------------------
5635       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5636       implicit none
5637       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5638       double precision ksi,ksi2,ksi3,a1,a2,a3
5639       a1=fprim0*delta/(f1-f0)
5640       a2=3.0d0-2.0d0*a1
5641       a3=a1-2.0d0
5642       ksi=(x-x0)/delta
5643       ksi2=ksi*ksi
5644       ksi3=ksi2*ksi
5645       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5646       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5647       return
5648       end
5649 c------------------------------------------------------------------------------
5650       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5651       implicit none
5652       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5653       double precision ksi,ksi2,ksi3,a1,a2,a3
5654       ksi=(x-x0)/delta
5655       ksi2=ksi*ksi
5656       ksi3=ksi2*ksi
5657       a1=fprim0x*delta
5658       a2=3*(f1x-f0x)-2*fprim0x*delta
5659       a3=fprim0x*delta-2*(f1x-f0x)
5660       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5661       return
5662       end
5663 C-----------------------------------------------------------------------------
5664 #ifdef CRYST_TOR
5665 C-----------------------------------------------------------------------------
5666       subroutine etor(etors,edihcnstr)
5667       implicit real*8 (a-h,o-z)
5668       include 'DIMENSIONS'
5669       include 'COMMON.VAR'
5670       include 'COMMON.GEO'
5671       include 'COMMON.LOCAL'
5672       include 'COMMON.TORSION'
5673       include 'COMMON.INTERACT'
5674       include 'COMMON.DERIV'
5675       include 'COMMON.CHAIN'
5676       include 'COMMON.NAMES'
5677       include 'COMMON.IOUNITS'
5678       include 'COMMON.FFIELD'
5679       include 'COMMON.TORCNSTR'
5680       include 'COMMON.CONTROL'
5681       logical lprn
5682 C Set lprn=.true. for debugging
5683       lprn=.false.
5684 c      lprn=.true.
5685       etors=0.0D0
5686       do i=iphi_start,iphi_end
5687       etors_ii=0.0D0
5688         itori=itortyp(itype(i-2))
5689         itori1=itortyp(itype(i-1))
5690         phii=phi(i)
5691         gloci=0.0D0
5692 C Proline-Proline pair is a special case...
5693         if (itori.eq.3 .and. itori1.eq.3) then
5694           if (phii.gt.-dwapi3) then
5695             cosphi=dcos(3*phii)
5696             fac=1.0D0/(1.0D0-cosphi)
5697             etorsi=v1(1,3,3)*fac
5698             etorsi=etorsi+etorsi
5699             etors=etors+etorsi-v1(1,3,3)
5700             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5701             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5702           endif
5703           do j=1,3
5704             v1ij=v1(j+1,itori,itori1)
5705             v2ij=v2(j+1,itori,itori1)
5706             cosphi=dcos(j*phii)
5707             sinphi=dsin(j*phii)
5708             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5709             if (energy_dec) etors_ii=etors_ii+
5710      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5711             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5712           enddo
5713         else
5714           do j=1,nterm_old
5715             v1ij=v1(j,itori,itori1)
5716             v2ij=v2(j,itori,itori1)
5717             cosphi=dcos(j*phii)
5718             sinphi=dsin(j*phii)
5719             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5720             if (energy_dec) etors_ii=etors_ii+
5721      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5722             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5723           enddo
5724         endif
5725         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5726      &        'etor',i,etors_ii
5727         if (lprn)
5728      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5729      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5730      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5731         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5732         write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5733       enddo
5734 ! 6/20/98 - dihedral angle constraints
5735       edihcnstr=0.0d0
5736       do i=1,ndih_constr
5737         itori=idih_constr(i)
5738         phii=phi(itori)
5739         difi=phii-phi0(i)
5740         if (difi.gt.drange(i)) then
5741           difi=difi-drange(i)
5742           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5743           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5744         else if (difi.lt.-drange(i)) then
5745           difi=difi+drange(i)
5746           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5747           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5748         endif
5749 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5750 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5751       enddo
5752 !      write (iout,*) 'edihcnstr',edihcnstr
5753       return
5754       end
5755 c------------------------------------------------------------------------------
5756       subroutine etor_d(etors_d)
5757       etors_d=0.0d0
5758       return
5759       end
5760 c----------------------------------------------------------------------------
5761 #else
5762       subroutine etor(etors,edihcnstr)
5763       implicit real*8 (a-h,o-z)
5764       include 'DIMENSIONS'
5765       include 'COMMON.VAR'
5766       include 'COMMON.GEO'
5767       include 'COMMON.LOCAL'
5768       include 'COMMON.TORSION'
5769       include 'COMMON.INTERACT'
5770       include 'COMMON.DERIV'
5771       include 'COMMON.CHAIN'
5772       include 'COMMON.NAMES'
5773       include 'COMMON.IOUNITS'
5774       include 'COMMON.FFIELD'
5775       include 'COMMON.TORCNSTR'
5776       include 'COMMON.CONTROL'
5777       logical lprn
5778 C Set lprn=.true. for debugging
5779       lprn=.false.
5780 c     lprn=.true.
5781       etors=0.0D0
5782       do i=iphi_start,iphi_end
5783       etors_ii=0.0D0
5784         itori=itortyp(itype(i-2))
5785         itori1=itortyp(itype(i-1))
5786         phii=phi(i)
5787         gloci=0.0D0
5788 C Regular cosine and sine terms
5789         do j=1,nterm(itori,itori1)
5790           v1ij=v1(j,itori,itori1)
5791           v2ij=v2(j,itori,itori1)
5792           cosphi=dcos(j*phii)
5793           sinphi=dsin(j*phii)
5794           etors=etors+v1ij*cosphi+v2ij*sinphi
5795           if (energy_dec) etors_ii=etors_ii+
5796      &                v1ij*cosphi+v2ij*sinphi
5797           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5798         enddo
5799 C Lorentz terms
5800 C                         v1
5801 C  E = SUM ----------------------------------- - v1
5802 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5803 C
5804         cosphi=dcos(0.5d0*phii)
5805         sinphi=dsin(0.5d0*phii)
5806         do j=1,nlor(itori,itori1)
5807           vl1ij=vlor1(j,itori,itori1)
5808           vl2ij=vlor2(j,itori,itori1)
5809           vl3ij=vlor3(j,itori,itori1)
5810           pom=vl2ij*cosphi+vl3ij*sinphi
5811           pom1=1.0d0/(pom*pom+1.0d0)
5812           etors=etors+vl1ij*pom1
5813           if (energy_dec) etors_ii=etors_ii+
5814      &                vl1ij*pom1
5815           pom=-pom*pom1*pom1
5816           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5817         enddo
5818 C Subtract the constant term
5819         etors=etors-v0(itori,itori1)
5820           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5821      &         'etor',i,etors_ii-v0(itori,itori1)
5822         if (lprn)
5823      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5824      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5825      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5826         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5827 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5828       enddo
5829 ! 6/20/98 - dihedral angle constraints
5830       edihcnstr=0.0d0
5831 c      do i=1,ndih_constr
5832       do i=idihconstr_start,idihconstr_end
5833         itori=idih_constr(i)
5834         phii=phi(itori)
5835         difi=pinorm(phii-phi0(i))
5836         if (difi.gt.drange(i)) then
5837           difi=difi-drange(i)
5838           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5839           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5840         else if (difi.lt.-drange(i)) then
5841           difi=difi+drange(i)
5842           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5843           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5844         else
5845           difi=0.0
5846         endif
5847 c        write (iout,*) "gloci", gloc(i-3,icg)
5848 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5849 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5850 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5851       enddo
5852 cd       write (iout,*) 'edihcnstr',edihcnstr
5853       return
5854       end
5855 c----------------------------------------------------------------------------
5856       subroutine etor_d(etors_d)
5857 C 6/23/01 Compute double torsional energy
5858       implicit real*8 (a-h,o-z)
5859       include 'DIMENSIONS'
5860       include 'COMMON.VAR'
5861       include 'COMMON.GEO'
5862       include 'COMMON.LOCAL'
5863       include 'COMMON.TORSION'
5864       include 'COMMON.INTERACT'
5865       include 'COMMON.DERIV'
5866       include 'COMMON.CHAIN'
5867       include 'COMMON.NAMES'
5868       include 'COMMON.IOUNITS'
5869       include 'COMMON.FFIELD'
5870       include 'COMMON.TORCNSTR'
5871       logical lprn
5872 C Set lprn=.true. for debugging
5873       lprn=.false.
5874 c     lprn=.true.
5875       etors_d=0.0D0
5876       do i=iphid_start,iphid_end
5877         itori=itortyp(itype(i-2))
5878         itori1=itortyp(itype(i-1))
5879         itori2=itortyp(itype(i))
5880         phii=phi(i)
5881         phii1=phi(i+1)
5882         gloci1=0.0D0
5883         gloci2=0.0D0
5884         do j=1,ntermd_1(itori,itori1,itori2)
5885           v1cij=v1c(1,j,itori,itori1,itori2)
5886           v1sij=v1s(1,j,itori,itori1,itori2)
5887           v2cij=v1c(2,j,itori,itori1,itori2)
5888           v2sij=v1s(2,j,itori,itori1,itori2)
5889           cosphi1=dcos(j*phii)
5890           sinphi1=dsin(j*phii)
5891           cosphi2=dcos(j*phii1)
5892           sinphi2=dsin(j*phii1)
5893           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5894      &     v2cij*cosphi2+v2sij*sinphi2
5895           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5896           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5897         enddo
5898         do k=2,ntermd_2(itori,itori1,itori2)
5899           do l=1,k-1
5900             v1cdij = v2c(k,l,itori,itori1,itori2)
5901             v2cdij = v2c(l,k,itori,itori1,itori2)
5902             v1sdij = v2s(k,l,itori,itori1,itori2)
5903             v2sdij = v2s(l,k,itori,itori1,itori2)
5904             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5905             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5906             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5907             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5908             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5909      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5910             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5911      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5912             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5913      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5914           enddo
5915         enddo
5916         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5917         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5918 c        write (iout,*) "gloci", gloc(i-3,icg)
5919       enddo
5920       return
5921       end
5922 #endif
5923 c------------------------------------------------------------------------------
5924       subroutine eback_sc_corr(esccor)
5925 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5926 c        conformational states; temporarily implemented as differences
5927 c        between UNRES torsional potentials (dependent on three types of
5928 c        residues) and the torsional potentials dependent on all 20 types
5929 c        of residues computed from AM1  energy surfaces of terminally-blocked
5930 c        amino-acid residues.
5931       implicit real*8 (a-h,o-z)
5932       include 'DIMENSIONS'
5933       include 'COMMON.VAR'
5934       include 'COMMON.GEO'
5935       include 'COMMON.LOCAL'
5936       include 'COMMON.TORSION'
5937       include 'COMMON.SCCOR'
5938       include 'COMMON.INTERACT'
5939       include 'COMMON.DERIV'
5940       include 'COMMON.CHAIN'
5941       include 'COMMON.NAMES'
5942       include 'COMMON.IOUNITS'
5943       include 'COMMON.FFIELD'
5944       include 'COMMON.CONTROL'
5945       logical lprn
5946 C Set lprn=.true. for debugging
5947       lprn=.false.
5948 c      lprn=.true.
5949 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
5950       esccor=0.0D0
5951       do i=itau_start,itau_end
5952         esccor_ii=0.0D0
5953         isccori=isccortyp(itype(i-2))
5954         isccori1=isccortyp(itype(i-1))
5955         phii=phi(i)
5956 cccc  Added 9 May 2012
5957 cc Tauangle is torsional engle depending on the value of first digit
5958 c(see comment below)
5959 cc Omicron is flat angle depending on the value of first digit
5960 c(see comment below)
5961
5962
5963         do intertyp=1,3 !intertyp
5964 cc Added 09 May 2012 (Adasko)
5965 cc  Intertyp means interaction type of backbone mainchain correlation:
5966 c   1 = SC...Ca...Ca...Ca
5967 c   2 = Ca...Ca...Ca...SC
5968 c   3 = SC...Ca...Ca...SCi
5969         gloci=0.0D0
5970         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5971      &      (itype(i-1).eq.10).or.(itype(i-2).eq.21).or.
5972      &      (itype(i-1).eq.21)))
5973      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5974      &     .or.(itype(i-2).eq.21)))
5975      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5976      &      (itype(i-1).eq.21)))) cycle
5977         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle
5978         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21))
5979      & cycle
5980         do j=1,nterm_sccor(isccori,isccori1)
5981           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5982           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5983           cosphi=dcos(j*tauangle(intertyp,i))
5984           sinphi=dsin(j*tauangle(intertyp,i))
5985           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5986           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5987         enddo
5988         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5989 c        write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
5990 c     &gloc_sc(intertyp,i-3,icg)
5991         if (lprn)
5992      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5993      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5994      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
5995      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
5996         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5997        enddo !intertyp
5998       enddo
5999 c        do i=1,nres
6000 c        write (iout,*) "W@T@F",  gloc_sc(1,i,icg),gloc(i,icg)
6001 c        enddo
6002       return
6003       end
6004 c----------------------------------------------------------------------------
6005       subroutine multibody(ecorr)
6006 C This subroutine calculates multi-body contributions to energy following
6007 C the idea of Skolnick et al. If side chains I and J make a contact and
6008 C at the same time side chains I+1 and J+1 make a contact, an extra
6009 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6010       implicit real*8 (a-h,o-z)
6011       include 'DIMENSIONS'
6012       include 'COMMON.IOUNITS'
6013       include 'COMMON.DERIV'
6014       include 'COMMON.INTERACT'
6015       include 'COMMON.CONTACTS'
6016       double precision gx(3),gx1(3)
6017       logical lprn
6018
6019 C Set lprn=.true. for debugging
6020       lprn=.false.
6021
6022       if (lprn) then
6023         write (iout,'(a)') 'Contact function values:'
6024         do i=nnt,nct-2
6025           write (iout,'(i2,20(1x,i2,f10.5))')
6026      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6027         enddo
6028       endif
6029       ecorr=0.0D0
6030       do i=nnt,nct
6031         do j=1,3
6032           gradcorr(j,i)=0.0D0
6033           gradxorr(j,i)=0.0D0
6034         enddo
6035       enddo
6036       do i=nnt,nct-2
6037
6038         DO ISHIFT = 3,4
6039
6040         i1=i+ishift
6041         num_conti=num_cont(i)
6042         num_conti1=num_cont(i1)
6043         do jj=1,num_conti
6044           j=jcont(jj,i)
6045           do kk=1,num_conti1
6046             j1=jcont(kk,i1)
6047             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6048 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6049 cd   &                   ' ishift=',ishift
6050 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6051 C The system gains extra energy.
6052               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6053             endif   ! j1==j+-ishift
6054           enddo     ! kk
6055         enddo       ! jj
6056
6057         ENDDO ! ISHIFT
6058
6059       enddo         ! i
6060       return
6061       end
6062 c------------------------------------------------------------------------------
6063       double precision function esccorr(i,j,k,l,jj,kk)
6064       implicit real*8 (a-h,o-z)
6065       include 'DIMENSIONS'
6066       include 'COMMON.IOUNITS'
6067       include 'COMMON.DERIV'
6068       include 'COMMON.INTERACT'
6069       include 'COMMON.CONTACTS'
6070       double precision gx(3),gx1(3)
6071       logical lprn
6072       lprn=.false.
6073       eij=facont(jj,i)
6074       ekl=facont(kk,k)
6075 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6076 C Calculate the multi-body contribution to energy.
6077 C Calculate multi-body contributions to the gradient.
6078 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6079 cd   & k,l,(gacont(m,kk,k),m=1,3)
6080       do m=1,3
6081         gx(m) =ekl*gacont(m,jj,i)
6082         gx1(m)=eij*gacont(m,kk,k)
6083         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6084         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6085         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6086         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6087       enddo
6088       do m=i,j-1
6089         do ll=1,3
6090           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6091         enddo
6092       enddo
6093       do m=k,l-1
6094         do ll=1,3
6095           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6096         enddo
6097       enddo
6098       esccorr=-eij*ekl
6099       return
6100       end
6101 c------------------------------------------------------------------------------
6102       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6103 C This subroutine calculates multi-body contributions to hydrogen-bonding
6104       implicit real*8 (a-h,o-z)
6105       include 'DIMENSIONS'
6106       include 'COMMON.IOUNITS'
6107 #ifdef MPI
6108       include "mpif.h"
6109       parameter (max_cont=maxconts)
6110       parameter (max_dim=26)
6111       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6112       double precision zapas(max_dim,maxconts,max_fg_procs),
6113      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6114       common /przechowalnia/ zapas
6115       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6116      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6117 #endif
6118       include 'COMMON.SETUP'
6119       include 'COMMON.FFIELD'
6120       include 'COMMON.DERIV'
6121       include 'COMMON.INTERACT'
6122       include 'COMMON.CONTACTS'
6123       include 'COMMON.CONTROL'
6124       include 'COMMON.LOCAL'
6125       double precision gx(3),gx1(3),time00
6126       logical lprn,ldone
6127
6128 C Set lprn=.true. for debugging
6129       lprn=.false.
6130 #ifdef MPI
6131       n_corr=0
6132       n_corr1=0
6133       if (nfgtasks.le.1) goto 30
6134       if (lprn) then
6135         write (iout,'(a)') 'Contact function values before RECEIVE:'
6136         do i=nnt,nct-2
6137           write (iout,'(2i3,50(1x,i2,f5.2))')
6138      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6139      &    j=1,num_cont_hb(i))
6140         enddo
6141       endif
6142       call flush(iout)
6143       do i=1,ntask_cont_from
6144         ncont_recv(i)=0
6145       enddo
6146       do i=1,ntask_cont_to
6147         ncont_sent(i)=0
6148       enddo
6149 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6150 c     & ntask_cont_to
6151 C Make the list of contacts to send to send to other procesors
6152 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6153 c      call flush(iout)
6154       do i=iturn3_start,iturn3_end
6155 c        write (iout,*) "make contact list turn3",i," num_cont",
6156 c     &    num_cont_hb(i)
6157         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6158       enddo
6159       do i=iturn4_start,iturn4_end
6160 c        write (iout,*) "make contact list turn4",i," num_cont",
6161 c     &   num_cont_hb(i)
6162         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6163       enddo
6164       do ii=1,nat_sent
6165         i=iat_sent(ii)
6166 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6167 c     &    num_cont_hb(i)
6168         do j=1,num_cont_hb(i)
6169         do k=1,4
6170           jjc=jcont_hb(j,i)
6171           iproc=iint_sent_local(k,jjc,ii)
6172 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6173           if (iproc.gt.0) then
6174             ncont_sent(iproc)=ncont_sent(iproc)+1
6175             nn=ncont_sent(iproc)
6176             zapas(1,nn,iproc)=i
6177             zapas(2,nn,iproc)=jjc
6178             zapas(3,nn,iproc)=facont_hb(j,i)
6179             zapas(4,nn,iproc)=ees0p(j,i)
6180             zapas(5,nn,iproc)=ees0m(j,i)
6181             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6182             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6183             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6184             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6185             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6186             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6187             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6188             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6189             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6190             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6191             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6192             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6193             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6194             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6195             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6196             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6197             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6198             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6199             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6200             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6201             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6202           endif
6203         enddo
6204         enddo
6205       enddo
6206       if (lprn) then
6207       write (iout,*)
6208      &  "Numbers of contacts to be sent to other processors",
6209      &  (ncont_sent(i),i=1,ntask_cont_to)
6210       write (iout,*) "Contacts sent"
6211       do ii=1,ntask_cont_to
6212         nn=ncont_sent(ii)
6213         iproc=itask_cont_to(ii)
6214         write (iout,*) nn," contacts to processor",iproc,
6215      &   " of CONT_TO_COMM group"
6216         do i=1,nn
6217           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6218         enddo
6219       enddo
6220       call flush(iout)
6221       endif
6222       CorrelType=477
6223       CorrelID=fg_rank+1
6224       CorrelType1=478
6225       CorrelID1=nfgtasks+fg_rank+1
6226       ireq=0
6227 C Receive the numbers of needed contacts from other processors
6228       do ii=1,ntask_cont_from
6229         iproc=itask_cont_from(ii)
6230         ireq=ireq+1
6231         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6232      &    FG_COMM,req(ireq),IERR)
6233       enddo
6234 c      write (iout,*) "IRECV ended"
6235 c      call flush(iout)
6236 C Send the number of contacts needed by other processors
6237       do ii=1,ntask_cont_to
6238         iproc=itask_cont_to(ii)
6239         ireq=ireq+1
6240         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6241      &    FG_COMM,req(ireq),IERR)
6242       enddo
6243 c      write (iout,*) "ISEND ended"
6244 c      write (iout,*) "number of requests (nn)",ireq
6245       call flush(iout)
6246       if (ireq.gt.0)
6247      &  call MPI_Waitall(ireq,req,status_array,ierr)
6248 c      write (iout,*)
6249 c     &  "Numbers of contacts to be received from other processors",
6250 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6251 c      call flush(iout)
6252 C Receive contacts
6253       ireq=0
6254       do ii=1,ntask_cont_from
6255         iproc=itask_cont_from(ii)
6256         nn=ncont_recv(ii)
6257 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6258 c     &   " of CONT_TO_COMM group"
6259         call flush(iout)
6260         if (nn.gt.0) then
6261           ireq=ireq+1
6262           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6263      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6264 c          write (iout,*) "ireq,req",ireq,req(ireq)
6265         endif
6266       enddo
6267 C Send the contacts to processors that need them
6268       do ii=1,ntask_cont_to
6269         iproc=itask_cont_to(ii)
6270         nn=ncont_sent(ii)
6271 c        write (iout,*) nn," contacts to processor",iproc,
6272 c     &   " of CONT_TO_COMM group"
6273         if (nn.gt.0) then
6274           ireq=ireq+1
6275           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6276      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6277 c          write (iout,*) "ireq,req",ireq,req(ireq)
6278 c          do i=1,nn
6279 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6280 c          enddo
6281         endif
6282       enddo
6283 c      write (iout,*) "number of requests (contacts)",ireq
6284 c      write (iout,*) "req",(req(i),i=1,4)
6285 c      call flush(iout)
6286       if (ireq.gt.0)
6287      & call MPI_Waitall(ireq,req,status_array,ierr)
6288       do iii=1,ntask_cont_from
6289         iproc=itask_cont_from(iii)
6290         nn=ncont_recv(iii)
6291         if (lprn) then
6292         write (iout,*) "Received",nn," contacts from processor",iproc,
6293      &   " of CONT_FROM_COMM group"
6294         call flush(iout)
6295         do i=1,nn
6296           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6297         enddo
6298         call flush(iout)
6299         endif
6300         do i=1,nn
6301           ii=zapas_recv(1,i,iii)
6302 c Flag the received contacts to prevent double-counting
6303           jj=-zapas_recv(2,i,iii)
6304 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6305 c          call flush(iout)
6306           nnn=num_cont_hb(ii)+1
6307           num_cont_hb(ii)=nnn
6308           jcont_hb(nnn,ii)=jj
6309           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6310           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6311           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6312           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6313           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6314           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6315           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6316           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6317           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6318           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6319           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6320           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6321           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6322           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6323           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6324           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6325           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6326           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6327           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6328           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6329           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6330           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6331           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6332           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6333         enddo
6334       enddo
6335       call flush(iout)
6336       if (lprn) then
6337         write (iout,'(a)') 'Contact function values after receive:'
6338         do i=nnt,nct-2
6339           write (iout,'(2i3,50(1x,i3,f5.2))')
6340      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6341      &    j=1,num_cont_hb(i))
6342         enddo
6343         call flush(iout)
6344       endif
6345    30 continue
6346 #endif
6347       if (lprn) then
6348         write (iout,'(a)') 'Contact function values:'
6349         do i=nnt,nct-2
6350           write (iout,'(2i3,50(1x,i3,f5.2))')
6351      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6352      &    j=1,num_cont_hb(i))
6353         enddo
6354       endif
6355       ecorr=0.0D0
6356 C Remove the loop below after debugging !!!
6357       do i=nnt,nct
6358         do j=1,3
6359           gradcorr(j,i)=0.0D0
6360           gradxorr(j,i)=0.0D0
6361         enddo
6362       enddo
6363 C Calculate the local-electrostatic correlation terms
6364       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6365         i1=i+1
6366         num_conti=num_cont_hb(i)
6367         num_conti1=num_cont_hb(i+1)
6368         do jj=1,num_conti
6369           j=jcont_hb(jj,i)
6370           jp=iabs(j)
6371           do kk=1,num_conti1
6372             j1=jcont_hb(kk,i1)
6373             jp1=iabs(j1)
6374 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6375 c     &         ' jj=',jj,' kk=',kk
6376             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6377      &          .or. j.lt.0 .and. j1.gt.0) .and.
6378      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6379 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6380 C The system gains extra energy.
6381               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6382               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6383      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6384               n_corr=n_corr+1
6385             else if (j1.eq.j) then
6386 C Contacts I-J and I-(J+1) occur simultaneously.
6387 C The system loses extra energy.
6388 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6389             endif
6390           enddo ! kk
6391           do kk=1,num_conti
6392             j1=jcont_hb(kk,i)
6393 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6394 c    &         ' jj=',jj,' kk=',kk
6395             if (j1.eq.j+1) then
6396 C Contacts I-J and (I+1)-J occur simultaneously.
6397 C The system loses extra energy.
6398 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6399             endif ! j1==j+1
6400           enddo ! kk
6401         enddo ! jj
6402       enddo ! i
6403       return
6404       end
6405 c------------------------------------------------------------------------------
6406       subroutine add_hb_contact(ii,jj,itask)
6407       implicit real*8 (a-h,o-z)
6408       include "DIMENSIONS"
6409       include "COMMON.IOUNITS"
6410       integer max_cont
6411       integer max_dim
6412       parameter (max_cont=maxconts)
6413       parameter (max_dim=26)
6414       include "COMMON.CONTACTS"
6415       double precision zapas(max_dim,maxconts,max_fg_procs),
6416      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6417       common /przechowalnia/ zapas
6418       integer i,j,ii,jj,iproc,itask(4),nn
6419 c      write (iout,*) "itask",itask
6420       do i=1,2
6421         iproc=itask(i)
6422         if (iproc.gt.0) then
6423           do j=1,num_cont_hb(ii)
6424             jjc=jcont_hb(j,ii)
6425 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6426             if (jjc.eq.jj) then
6427               ncont_sent(iproc)=ncont_sent(iproc)+1
6428               nn=ncont_sent(iproc)
6429               zapas(1,nn,iproc)=ii
6430               zapas(2,nn,iproc)=jjc
6431               zapas(3,nn,iproc)=facont_hb(j,ii)
6432               zapas(4,nn,iproc)=ees0p(j,ii)
6433               zapas(5,nn,iproc)=ees0m(j,ii)
6434               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6435               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6436               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6437               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6438               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6439               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6440               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6441               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6442               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6443               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6444               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6445               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6446               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6447               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6448               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6449               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6450               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6451               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6452               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6453               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6454               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6455               exit
6456             endif
6457           enddo
6458         endif
6459       enddo
6460       return
6461       end
6462 c------------------------------------------------------------------------------
6463       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6464      &  n_corr1)
6465 C This subroutine calculates multi-body contributions to hydrogen-bonding
6466       implicit real*8 (a-h,o-z)
6467       include 'DIMENSIONS'
6468       include 'COMMON.IOUNITS'
6469 #ifdef MPI
6470       include "mpif.h"
6471       parameter (max_cont=maxconts)
6472       parameter (max_dim=70)
6473       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6474       double precision zapas(max_dim,maxconts,max_fg_procs),
6475      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6476       common /przechowalnia/ zapas
6477       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6478      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6479 #endif
6480       include 'COMMON.SETUP'
6481       include 'COMMON.FFIELD'
6482       include 'COMMON.DERIV'
6483       include 'COMMON.LOCAL'
6484       include 'COMMON.INTERACT'
6485       include 'COMMON.CONTACTS'
6486       include 'COMMON.CHAIN'
6487       include 'COMMON.CONTROL'
6488       double precision gx(3),gx1(3)
6489       integer num_cont_hb_old(maxres)
6490       logical lprn,ldone
6491       double precision eello4,eello5,eelo6,eello_turn6
6492       external eello4,eello5,eello6,eello_turn6
6493 C Set lprn=.true. for debugging
6494       lprn=.false.
6495       eturn6=0.0d0
6496 #ifdef MPI
6497       do i=1,nres
6498         num_cont_hb_old(i)=num_cont_hb(i)
6499       enddo
6500       n_corr=0
6501       n_corr1=0
6502       if (nfgtasks.le.1) goto 30
6503       if (lprn) then
6504         write (iout,'(a)') 'Contact function values before RECEIVE:'
6505         do i=nnt,nct-2
6506           write (iout,'(2i3,50(1x,i2,f5.2))')
6507      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6508      &    j=1,num_cont_hb(i))
6509         enddo
6510       endif
6511       call flush(iout)
6512       do i=1,ntask_cont_from
6513         ncont_recv(i)=0
6514       enddo
6515       do i=1,ntask_cont_to
6516         ncont_sent(i)=0
6517       enddo
6518 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6519 c     & ntask_cont_to
6520 C Make the list of contacts to send to send to other procesors
6521       do i=iturn3_start,iturn3_end
6522 c        write (iout,*) "make contact list turn3",i," num_cont",
6523 c     &    num_cont_hb(i)
6524         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6525       enddo
6526       do i=iturn4_start,iturn4_end
6527 c        write (iout,*) "make contact list turn4",i," num_cont",
6528 c     &   num_cont_hb(i)
6529         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6530       enddo
6531       do ii=1,nat_sent
6532         i=iat_sent(ii)
6533 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6534 c     &    num_cont_hb(i)
6535         do j=1,num_cont_hb(i)
6536         do k=1,4
6537           jjc=jcont_hb(j,i)
6538           iproc=iint_sent_local(k,jjc,ii)
6539 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6540           if (iproc.ne.0) then
6541             ncont_sent(iproc)=ncont_sent(iproc)+1
6542             nn=ncont_sent(iproc)
6543             zapas(1,nn,iproc)=i
6544             zapas(2,nn,iproc)=jjc
6545             zapas(3,nn,iproc)=d_cont(j,i)
6546             ind=3
6547             do kk=1,3
6548               ind=ind+1
6549               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6550             enddo
6551             do kk=1,2
6552               do ll=1,2
6553                 ind=ind+1
6554                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6555               enddo
6556             enddo
6557             do jj=1,5
6558               do kk=1,3
6559                 do ll=1,2
6560                   do mm=1,2
6561                     ind=ind+1
6562                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6563                   enddo
6564                 enddo
6565               enddo
6566             enddo
6567           endif
6568         enddo
6569         enddo
6570       enddo
6571       if (lprn) then
6572       write (iout,*)
6573      &  "Numbers of contacts to be sent to other processors",
6574      &  (ncont_sent(i),i=1,ntask_cont_to)
6575       write (iout,*) "Contacts sent"
6576       do ii=1,ntask_cont_to
6577         nn=ncont_sent(ii)
6578         iproc=itask_cont_to(ii)
6579         write (iout,*) nn," contacts to processor",iproc,
6580      &   " of CONT_TO_COMM group"
6581         do i=1,nn
6582           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6583         enddo
6584       enddo
6585       call flush(iout)
6586       endif
6587       CorrelType=477
6588       CorrelID=fg_rank+1
6589       CorrelType1=478
6590       CorrelID1=nfgtasks+fg_rank+1
6591       ireq=0
6592 C Receive the numbers of needed contacts from other processors
6593       do ii=1,ntask_cont_from
6594         iproc=itask_cont_from(ii)
6595         ireq=ireq+1
6596         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6597      &    FG_COMM,req(ireq),IERR)
6598       enddo
6599 c      write (iout,*) "IRECV ended"
6600 c      call flush(iout)
6601 C Send the number of contacts needed by other processors
6602       do ii=1,ntask_cont_to
6603         iproc=itask_cont_to(ii)
6604         ireq=ireq+1
6605         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6606      &    FG_COMM,req(ireq),IERR)
6607       enddo
6608 c      write (iout,*) "ISEND ended"
6609 c      write (iout,*) "number of requests (nn)",ireq
6610       call flush(iout)
6611       if (ireq.gt.0)
6612      &  call MPI_Waitall(ireq,req,status_array,ierr)
6613 c      write (iout,*)
6614 c     &  "Numbers of contacts to be received from other processors",
6615 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6616 c      call flush(iout)
6617 C Receive contacts
6618       ireq=0
6619       do ii=1,ntask_cont_from
6620         iproc=itask_cont_from(ii)
6621         nn=ncont_recv(ii)
6622 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6623 c     &   " of CONT_TO_COMM group"
6624         call flush(iout)
6625         if (nn.gt.0) then
6626           ireq=ireq+1
6627           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6628      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6629 c          write (iout,*) "ireq,req",ireq,req(ireq)
6630         endif
6631       enddo
6632 C Send the contacts to processors that need them
6633       do ii=1,ntask_cont_to
6634         iproc=itask_cont_to(ii)
6635         nn=ncont_sent(ii)
6636 c        write (iout,*) nn," contacts to processor",iproc,
6637 c     &   " of CONT_TO_COMM group"
6638         if (nn.gt.0) then
6639           ireq=ireq+1
6640           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6641      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6642 c          write (iout,*) "ireq,req",ireq,req(ireq)
6643 c          do i=1,nn
6644 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6645 c          enddo
6646         endif
6647       enddo
6648 c      write (iout,*) "number of requests (contacts)",ireq
6649 c      write (iout,*) "req",(req(i),i=1,4)
6650 c      call flush(iout)
6651       if (ireq.gt.0)
6652      & call MPI_Waitall(ireq,req,status_array,ierr)
6653       do iii=1,ntask_cont_from
6654         iproc=itask_cont_from(iii)
6655         nn=ncont_recv(iii)
6656         if (lprn) then
6657         write (iout,*) "Received",nn," contacts from processor",iproc,
6658      &   " of CONT_FROM_COMM group"
6659         call flush(iout)
6660         do i=1,nn
6661           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6662         enddo
6663         call flush(iout)
6664         endif
6665         do i=1,nn
6666           ii=zapas_recv(1,i,iii)
6667 c Flag the received contacts to prevent double-counting
6668           jj=-zapas_recv(2,i,iii)
6669 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6670 c          call flush(iout)
6671           nnn=num_cont_hb(ii)+1
6672           num_cont_hb(ii)=nnn
6673           jcont_hb(nnn,ii)=jj
6674           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6675           ind=3
6676           do kk=1,3
6677             ind=ind+1
6678             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6679           enddo
6680           do kk=1,2
6681             do ll=1,2
6682               ind=ind+1
6683               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6684             enddo
6685           enddo
6686           do jj=1,5
6687             do kk=1,3
6688               do ll=1,2
6689                 do mm=1,2
6690                   ind=ind+1
6691                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6692                 enddo
6693               enddo
6694             enddo
6695           enddo
6696         enddo
6697       enddo
6698       call flush(iout)
6699       if (lprn) then
6700         write (iout,'(a)') 'Contact function values after receive:'
6701         do i=nnt,nct-2
6702           write (iout,'(2i3,50(1x,i3,5f6.3))')
6703      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6704      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6705         enddo
6706         call flush(iout)
6707       endif
6708    30 continue
6709 #endif
6710       if (lprn) then
6711         write (iout,'(a)') 'Contact function values:'
6712         do i=nnt,nct-2
6713           write (iout,'(2i3,50(1x,i2,5f6.3))')
6714      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6715      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6716         enddo
6717       endif
6718       ecorr=0.0D0
6719       ecorr5=0.0d0
6720       ecorr6=0.0d0
6721 C Remove the loop below after debugging !!!
6722       do i=nnt,nct
6723         do j=1,3
6724           gradcorr(j,i)=0.0D0
6725           gradxorr(j,i)=0.0D0
6726         enddo
6727       enddo
6728 C Calculate the dipole-dipole interaction energies
6729       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6730       do i=iatel_s,iatel_e+1
6731         num_conti=num_cont_hb(i)
6732         do jj=1,num_conti
6733           j=jcont_hb(jj,i)
6734 #ifdef MOMENT
6735           call dipole(i,j,jj)
6736 #endif
6737         enddo
6738       enddo
6739       endif
6740 C Calculate the local-electrostatic correlation terms
6741 c                write (iout,*) "gradcorr5 in eello5 before loop"
6742 c                do iii=1,nres
6743 c                  write (iout,'(i5,3f10.5)')
6744 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6745 c                enddo
6746       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6747 c        write (iout,*) "corr loop i",i
6748         i1=i+1
6749         num_conti=num_cont_hb(i)
6750         num_conti1=num_cont_hb(i+1)
6751         do jj=1,num_conti
6752           j=jcont_hb(jj,i)
6753           jp=iabs(j)
6754           do kk=1,num_conti1
6755             j1=jcont_hb(kk,i1)
6756             jp1=iabs(j1)
6757 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6758 c     &         ' jj=',jj,' kk=',kk
6759 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6760             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6761      &          .or. j.lt.0 .and. j1.gt.0) .and.
6762      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6763 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6764 C The system gains extra energy.
6765               n_corr=n_corr+1
6766               sqd1=dsqrt(d_cont(jj,i))
6767               sqd2=dsqrt(d_cont(kk,i1))
6768               sred_geom = sqd1*sqd2
6769               IF (sred_geom.lt.cutoff_corr) THEN
6770                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6771      &            ekont,fprimcont)
6772 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6773 cd     &         ' jj=',jj,' kk=',kk
6774                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6775                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6776                 do l=1,3
6777                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6778                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6779                 enddo
6780                 n_corr1=n_corr1+1
6781 cd               write (iout,*) 'sred_geom=',sred_geom,
6782 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6783 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6784 cd               write (iout,*) "g_contij",g_contij
6785 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6786 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6787                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6788                 if (wcorr4.gt.0.0d0)
6789      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6790                   if (energy_dec.and.wcorr4.gt.0.0d0)
6791      1                 write (iout,'(a6,4i5,0pf7.3)')
6792      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6793 c                write (iout,*) "gradcorr5 before eello5"
6794 c                do iii=1,nres
6795 c                  write (iout,'(i5,3f10.5)')
6796 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6797 c                enddo
6798                 if (wcorr5.gt.0.0d0)
6799      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6800 c                write (iout,*) "gradcorr5 after eello5"
6801 c                do iii=1,nres
6802 c                  write (iout,'(i5,3f10.5)')
6803 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6804 c                enddo
6805                   if (energy_dec.and.wcorr5.gt.0.0d0)
6806      1                 write (iout,'(a6,4i5,0pf7.3)')
6807      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6808 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6809 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6810                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6811      &               .or. wturn6.eq.0.0d0))then
6812 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6813                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6814                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6815      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6816 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6817 cd     &            'ecorr6=',ecorr6
6818 cd                write (iout,'(4e15.5)') sred_geom,
6819 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6820 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6821 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6822                 else if (wturn6.gt.0.0d0
6823      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6824 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6825                   eturn6=eturn6+eello_turn6(i,jj,kk)
6826                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6827      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6828 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6829                 endif
6830               ENDIF
6831 1111          continue
6832             endif
6833           enddo ! kk
6834         enddo ! jj
6835       enddo ! i
6836       do i=1,nres
6837         num_cont_hb(i)=num_cont_hb_old(i)
6838       enddo
6839 c                write (iout,*) "gradcorr5 in eello5"
6840 c                do iii=1,nres
6841 c                  write (iout,'(i5,3f10.5)')
6842 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6843 c                enddo
6844       return
6845       end
6846 c------------------------------------------------------------------------------
6847       subroutine add_hb_contact_eello(ii,jj,itask)
6848       implicit real*8 (a-h,o-z)
6849       include "DIMENSIONS"
6850       include "COMMON.IOUNITS"
6851       integer max_cont
6852       integer max_dim
6853       parameter (max_cont=maxconts)
6854       parameter (max_dim=70)
6855       include "COMMON.CONTACTS"
6856       double precision zapas(max_dim,maxconts,max_fg_procs),
6857      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6858       common /przechowalnia/ zapas
6859       integer i,j,ii,jj,iproc,itask(4),nn
6860 c      write (iout,*) "itask",itask
6861       do i=1,2
6862         iproc=itask(i)
6863         if (iproc.gt.0) then
6864           do j=1,num_cont_hb(ii)
6865             jjc=jcont_hb(j,ii)
6866 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6867             if (jjc.eq.jj) then
6868               ncont_sent(iproc)=ncont_sent(iproc)+1
6869               nn=ncont_sent(iproc)
6870               zapas(1,nn,iproc)=ii
6871               zapas(2,nn,iproc)=jjc
6872               zapas(3,nn,iproc)=d_cont(j,ii)
6873               ind=3
6874               do kk=1,3
6875                 ind=ind+1
6876                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6877               enddo
6878               do kk=1,2
6879                 do ll=1,2
6880                   ind=ind+1
6881                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6882                 enddo
6883               enddo
6884               do jj=1,5
6885                 do kk=1,3
6886                   do ll=1,2
6887                     do mm=1,2
6888                       ind=ind+1
6889                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6890                     enddo
6891                   enddo
6892                 enddo
6893               enddo
6894               exit
6895             endif
6896           enddo
6897         endif
6898       enddo
6899       return
6900       end
6901 c------------------------------------------------------------------------------
6902       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6903       implicit real*8 (a-h,o-z)
6904       include 'DIMENSIONS'
6905       include 'COMMON.IOUNITS'
6906       include 'COMMON.DERIV'
6907       include 'COMMON.INTERACT'
6908       include 'COMMON.CONTACTS'
6909       double precision gx(3),gx1(3)
6910       logical lprn
6911       lprn=.false.
6912       eij=facont_hb(jj,i)
6913       ekl=facont_hb(kk,k)
6914       ees0pij=ees0p(jj,i)
6915       ees0pkl=ees0p(kk,k)
6916       ees0mij=ees0m(jj,i)
6917       ees0mkl=ees0m(kk,k)
6918       ekont=eij*ekl
6919       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6920 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6921 C Following 4 lines for diagnostics.
6922 cd    ees0pkl=0.0D0
6923 cd    ees0pij=1.0D0
6924 cd    ees0mkl=0.0D0
6925 cd    ees0mij=1.0D0
6926 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6927 c     & 'Contacts ',i,j,
6928 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6929 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6930 c     & 'gradcorr_long'
6931 C Calculate the multi-body contribution to energy.
6932 c      ecorr=ecorr+ekont*ees
6933 C Calculate multi-body contributions to the gradient.
6934       coeffpees0pij=coeffp*ees0pij
6935       coeffmees0mij=coeffm*ees0mij
6936       coeffpees0pkl=coeffp*ees0pkl
6937       coeffmees0mkl=coeffm*ees0mkl
6938       do ll=1,3
6939 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6940         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6941      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6942      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6943         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6944      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6945      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6946 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6947         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6948      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6949      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6950         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6951      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6952      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6953         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6954      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6955      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6956         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6957         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6958         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6959      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6960      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6961         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6962         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6963 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6964       enddo
6965 c      write (iout,*)
6966 cgrad      do m=i+1,j-1
6967 cgrad        do ll=1,3
6968 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6969 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6970 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6971 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6972 cgrad        enddo
6973 cgrad      enddo
6974 cgrad      do m=k+1,l-1
6975 cgrad        do ll=1,3
6976 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6977 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6978 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6979 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6980 cgrad        enddo
6981 cgrad      enddo
6982 c      write (iout,*) "ehbcorr",ekont*ees
6983       ehbcorr=ekont*ees
6984       return
6985       end
6986 #ifdef MOMENT
6987 C---------------------------------------------------------------------------
6988       subroutine dipole(i,j,jj)
6989       implicit real*8 (a-h,o-z)
6990       include 'DIMENSIONS'
6991       include 'COMMON.IOUNITS'
6992       include 'COMMON.CHAIN'
6993       include 'COMMON.FFIELD'
6994       include 'COMMON.DERIV'
6995       include 'COMMON.INTERACT'
6996       include 'COMMON.CONTACTS'
6997       include 'COMMON.TORSION'
6998       include 'COMMON.VAR'
6999       include 'COMMON.GEO'
7000       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7001      &  auxmat(2,2)
7002       iti1 = itortyp(itype(i+1))
7003       if (j.lt.nres-1) then
7004         itj1 = itortyp(itype(j+1))
7005       else
7006         itj1=ntortyp+1
7007       endif
7008       do iii=1,2
7009         dipi(iii,1)=Ub2(iii,i)
7010         dipderi(iii)=Ub2der(iii,i)
7011         dipi(iii,2)=b1(iii,iti1)
7012         dipj(iii,1)=Ub2(iii,j)
7013         dipderj(iii)=Ub2der(iii,j)
7014         dipj(iii,2)=b1(iii,itj1)
7015       enddo
7016       kkk=0
7017       do iii=1,2
7018         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7019         do jjj=1,2
7020           kkk=kkk+1
7021           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7022         enddo
7023       enddo
7024       do kkk=1,5
7025         do lll=1,3
7026           mmm=0
7027           do iii=1,2
7028             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7029      &        auxvec(1))
7030             do jjj=1,2
7031               mmm=mmm+1
7032               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7033             enddo
7034           enddo
7035         enddo
7036       enddo
7037       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7038       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7039       do iii=1,2
7040         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7041       enddo
7042       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7043       do iii=1,2
7044         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7045       enddo
7046       return
7047       end
7048 #endif
7049 C---------------------------------------------------------------------------
7050       subroutine calc_eello(i,j,k,l,jj,kk)
7051 C
7052 C This subroutine computes matrices and vectors needed to calculate
7053 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7054 C
7055       implicit real*8 (a-h,o-z)
7056       include 'DIMENSIONS'
7057       include 'COMMON.IOUNITS'
7058       include 'COMMON.CHAIN'
7059       include 'COMMON.DERIV'
7060       include 'COMMON.INTERACT'
7061       include 'COMMON.CONTACTS'
7062       include 'COMMON.TORSION'
7063       include 'COMMON.VAR'
7064       include 'COMMON.GEO'
7065       include 'COMMON.FFIELD'
7066       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7067      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7068       logical lprn
7069       common /kutas/ lprn
7070 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7071 cd     & ' jj=',jj,' kk=',kk
7072 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7073 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7074 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7075       do iii=1,2
7076         do jjj=1,2
7077           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7078           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7079         enddo
7080       enddo
7081       call transpose2(aa1(1,1),aa1t(1,1))
7082       call transpose2(aa2(1,1),aa2t(1,1))
7083       do kkk=1,5
7084         do lll=1,3
7085           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7086      &      aa1tder(1,1,lll,kkk))
7087           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7088      &      aa2tder(1,1,lll,kkk))
7089         enddo
7090       enddo
7091       if (l.eq.j+1) then
7092 C parallel orientation of the two CA-CA-CA frames.
7093         if (i.gt.1) then
7094           iti=itortyp(itype(i))
7095         else
7096           iti=ntortyp+1
7097         endif
7098         itk1=itortyp(itype(k+1))
7099         itj=itortyp(itype(j))
7100         if (l.lt.nres-1) then
7101           itl1=itortyp(itype(l+1))
7102         else
7103           itl1=ntortyp+1
7104         endif
7105 C A1 kernel(j+1) A2T
7106 cd        do iii=1,2
7107 cd          write (iout,'(3f10.5,5x,3f10.5)')
7108 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7109 cd        enddo
7110         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7111      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7112      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7113 C Following matrices are needed only for 6-th order cumulants
7114         IF (wcorr6.gt.0.0d0) THEN
7115         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7116      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7117      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7118         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7119      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7120      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7121      &   ADtEAderx(1,1,1,1,1,1))
7122         lprn=.false.
7123         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7124      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7125      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7126      &   ADtEA1derx(1,1,1,1,1,1))
7127         ENDIF
7128 C End 6-th order cumulants
7129 cd        lprn=.false.
7130 cd        if (lprn) then
7131 cd        write (2,*) 'In calc_eello6'
7132 cd        do iii=1,2
7133 cd          write (2,*) 'iii=',iii
7134 cd          do kkk=1,5
7135 cd            write (2,*) 'kkk=',kkk
7136 cd            do jjj=1,2
7137 cd              write (2,'(3(2f10.5),5x)')
7138 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7139 cd            enddo
7140 cd          enddo
7141 cd        enddo
7142 cd        endif
7143         call transpose2(EUgder(1,1,k),auxmat(1,1))
7144         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7145         call transpose2(EUg(1,1,k),auxmat(1,1))
7146         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7147         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7148         do iii=1,2
7149           do kkk=1,5
7150             do lll=1,3
7151               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7152      &          EAEAderx(1,1,lll,kkk,iii,1))
7153             enddo
7154           enddo
7155         enddo
7156 C A1T kernel(i+1) A2
7157         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7158      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7159      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7160 C Following matrices are needed only for 6-th order cumulants
7161         IF (wcorr6.gt.0.0d0) THEN
7162         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7163      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7164      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7165         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7166      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7167      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7168      &   ADtEAderx(1,1,1,1,1,2))
7169         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7170      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7171      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7172      &   ADtEA1derx(1,1,1,1,1,2))
7173         ENDIF
7174 C End 6-th order cumulants
7175         call transpose2(EUgder(1,1,l),auxmat(1,1))
7176         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7177         call transpose2(EUg(1,1,l),auxmat(1,1))
7178         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7179         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7180         do iii=1,2
7181           do kkk=1,5
7182             do lll=1,3
7183               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7184      &          EAEAderx(1,1,lll,kkk,iii,2))
7185             enddo
7186           enddo
7187         enddo
7188 C AEAb1 and AEAb2
7189 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7190 C They are needed only when the fifth- or the sixth-order cumulants are
7191 C indluded.
7192         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7193         call transpose2(AEA(1,1,1),auxmat(1,1))
7194         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7195         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7196         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7197         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7198         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7199         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7200         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7201         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7202         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7203         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7204         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7205         call transpose2(AEA(1,1,2),auxmat(1,1))
7206         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7207         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7208         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7209         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7210         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7211         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7212         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7213         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7214         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7215         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7216         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7217 C Calculate the Cartesian derivatives of the vectors.
7218         do iii=1,2
7219           do kkk=1,5
7220             do lll=1,3
7221               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7222               call matvec2(auxmat(1,1),b1(1,iti),
7223      &          AEAb1derx(1,lll,kkk,iii,1,1))
7224               call matvec2(auxmat(1,1),Ub2(1,i),
7225      &          AEAb2derx(1,lll,kkk,iii,1,1))
7226               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7227      &          AEAb1derx(1,lll,kkk,iii,2,1))
7228               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7229      &          AEAb2derx(1,lll,kkk,iii,2,1))
7230               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7231               call matvec2(auxmat(1,1),b1(1,itj),
7232      &          AEAb1derx(1,lll,kkk,iii,1,2))
7233               call matvec2(auxmat(1,1),Ub2(1,j),
7234      &          AEAb2derx(1,lll,kkk,iii,1,2))
7235               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7236      &          AEAb1derx(1,lll,kkk,iii,2,2))
7237               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7238      &          AEAb2derx(1,lll,kkk,iii,2,2))
7239             enddo
7240           enddo
7241         enddo
7242         ENDIF
7243 C End vectors
7244       else
7245 C Antiparallel orientation of the two CA-CA-CA frames.
7246         if (i.gt.1) then
7247           iti=itortyp(itype(i))
7248         else
7249           iti=ntortyp+1
7250         endif
7251         itk1=itortyp(itype(k+1))
7252         itl=itortyp(itype(l))
7253         itj=itortyp(itype(j))
7254         if (j.lt.nres-1) then
7255           itj1=itortyp(itype(j+1))
7256         else
7257           itj1=ntortyp+1
7258         endif
7259 C A2 kernel(j-1)T A1T
7260         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7261      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7262      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7263 C Following matrices are needed only for 6-th order cumulants
7264         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7265      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7266         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7267      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7268      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7269         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7270      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7271      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7272      &   ADtEAderx(1,1,1,1,1,1))
7273         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7274      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7275      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7276      &   ADtEA1derx(1,1,1,1,1,1))
7277         ENDIF
7278 C End 6-th order cumulants
7279         call transpose2(EUgder(1,1,k),auxmat(1,1))
7280         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7281         call transpose2(EUg(1,1,k),auxmat(1,1))
7282         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7283         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7284         do iii=1,2
7285           do kkk=1,5
7286             do lll=1,3
7287               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7288      &          EAEAderx(1,1,lll,kkk,iii,1))
7289             enddo
7290           enddo
7291         enddo
7292 C A2T kernel(i+1)T A1
7293         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7294      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7295      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7296 C Following matrices are needed only for 6-th order cumulants
7297         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7298      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7299         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7300      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7301      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7302         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7303      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7304      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7305      &   ADtEAderx(1,1,1,1,1,2))
7306         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7307      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7308      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7309      &   ADtEA1derx(1,1,1,1,1,2))
7310         ENDIF
7311 C End 6-th order cumulants
7312         call transpose2(EUgder(1,1,j),auxmat(1,1))
7313         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7314         call transpose2(EUg(1,1,j),auxmat(1,1))
7315         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7316         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7317         do iii=1,2
7318           do kkk=1,5
7319             do lll=1,3
7320               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7321      &          EAEAderx(1,1,lll,kkk,iii,2))
7322             enddo
7323           enddo
7324         enddo
7325 C AEAb1 and AEAb2
7326 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7327 C They are needed only when the fifth- or the sixth-order cumulants are
7328 C indluded.
7329         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7330      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7331         call transpose2(AEA(1,1,1),auxmat(1,1))
7332         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7333         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7334         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7335         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7336         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7337         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7338         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7339         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7340         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7341         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7342         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7343         call transpose2(AEA(1,1,2),auxmat(1,1))
7344         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7345         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7346         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7347         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7348         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7349         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7350         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7351         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7352         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7353         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7354         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7355 C Calculate the Cartesian derivatives of the vectors.
7356         do iii=1,2
7357           do kkk=1,5
7358             do lll=1,3
7359               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7360               call matvec2(auxmat(1,1),b1(1,iti),
7361      &          AEAb1derx(1,lll,kkk,iii,1,1))
7362               call matvec2(auxmat(1,1),Ub2(1,i),
7363      &          AEAb2derx(1,lll,kkk,iii,1,1))
7364               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7365      &          AEAb1derx(1,lll,kkk,iii,2,1))
7366               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7367      &          AEAb2derx(1,lll,kkk,iii,2,1))
7368               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7369               call matvec2(auxmat(1,1),b1(1,itl),
7370      &          AEAb1derx(1,lll,kkk,iii,1,2))
7371               call matvec2(auxmat(1,1),Ub2(1,l),
7372      &          AEAb2derx(1,lll,kkk,iii,1,2))
7373               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7374      &          AEAb1derx(1,lll,kkk,iii,2,2))
7375               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7376      &          AEAb2derx(1,lll,kkk,iii,2,2))
7377             enddo
7378           enddo
7379         enddo
7380         ENDIF
7381 C End vectors
7382       endif
7383       return
7384       end
7385 C---------------------------------------------------------------------------
7386       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7387      &  KK,KKderg,AKA,AKAderg,AKAderx)
7388       implicit none
7389       integer nderg
7390       logical transp
7391       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7392      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7393      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7394       integer iii,kkk,lll
7395       integer jjj,mmm
7396       logical lprn
7397       common /kutas/ lprn
7398       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7399       do iii=1,nderg
7400         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7401      &    AKAderg(1,1,iii))
7402       enddo
7403 cd      if (lprn) write (2,*) 'In kernel'
7404       do kkk=1,5
7405 cd        if (lprn) write (2,*) 'kkk=',kkk
7406         do lll=1,3
7407           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7408      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7409 cd          if (lprn) then
7410 cd            write (2,*) 'lll=',lll
7411 cd            write (2,*) 'iii=1'
7412 cd            do jjj=1,2
7413 cd              write (2,'(3(2f10.5),5x)')
7414 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7415 cd            enddo
7416 cd          endif
7417           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7418      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7419 cd          if (lprn) then
7420 cd            write (2,*) 'lll=',lll
7421 cd            write (2,*) 'iii=2'
7422 cd            do jjj=1,2
7423 cd              write (2,'(3(2f10.5),5x)')
7424 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7425 cd            enddo
7426 cd          endif
7427         enddo
7428       enddo
7429       return
7430       end
7431 C---------------------------------------------------------------------------
7432       double precision function eello4(i,j,k,l,jj,kk)
7433       implicit real*8 (a-h,o-z)
7434       include 'DIMENSIONS'
7435       include 'COMMON.IOUNITS'
7436       include 'COMMON.CHAIN'
7437       include 'COMMON.DERIV'
7438       include 'COMMON.INTERACT'
7439       include 'COMMON.CONTACTS'
7440       include 'COMMON.TORSION'
7441       include 'COMMON.VAR'
7442       include 'COMMON.GEO'
7443       double precision pizda(2,2),ggg1(3),ggg2(3)
7444 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7445 cd        eello4=0.0d0
7446 cd        return
7447 cd      endif
7448 cd      print *,'eello4:',i,j,k,l,jj,kk
7449 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7450 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7451 cold      eij=facont_hb(jj,i)
7452 cold      ekl=facont_hb(kk,k)
7453 cold      ekont=eij*ekl
7454       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7455 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7456       gcorr_loc(k-1)=gcorr_loc(k-1)
7457      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7458       if (l.eq.j+1) then
7459         gcorr_loc(l-1)=gcorr_loc(l-1)
7460      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7461       else
7462         gcorr_loc(j-1)=gcorr_loc(j-1)
7463      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7464       endif
7465       do iii=1,2
7466         do kkk=1,5
7467           do lll=1,3
7468             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7469      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7470 cd            derx(lll,kkk,iii)=0.0d0
7471           enddo
7472         enddo
7473       enddo
7474 cd      gcorr_loc(l-1)=0.0d0
7475 cd      gcorr_loc(j-1)=0.0d0
7476 cd      gcorr_loc(k-1)=0.0d0
7477 cd      eel4=1.0d0
7478 cd      write (iout,*)'Contacts have occurred for peptide groups',
7479 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7480 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7481       if (j.lt.nres-1) then
7482         j1=j+1
7483         j2=j-1
7484       else
7485         j1=j-1
7486         j2=j-2
7487       endif
7488       if (l.lt.nres-1) then
7489         l1=l+1
7490         l2=l-1
7491       else
7492         l1=l-1
7493         l2=l-2
7494       endif
7495       do ll=1,3
7496 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7497 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7498         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7499         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7500 cgrad        ghalf=0.5d0*ggg1(ll)
7501         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7502         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7503         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7504         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7505         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7506         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7507 cgrad        ghalf=0.5d0*ggg2(ll)
7508         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7509         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7510         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7511         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7512         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7513         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7514       enddo
7515 cgrad      do m=i+1,j-1
7516 cgrad        do ll=1,3
7517 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7518 cgrad        enddo
7519 cgrad      enddo
7520 cgrad      do m=k+1,l-1
7521 cgrad        do ll=1,3
7522 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7523 cgrad        enddo
7524 cgrad      enddo
7525 cgrad      do m=i+2,j2
7526 cgrad        do ll=1,3
7527 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7528 cgrad        enddo
7529 cgrad      enddo
7530 cgrad      do m=k+2,l2
7531 cgrad        do ll=1,3
7532 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7533 cgrad        enddo
7534 cgrad      enddo
7535 cd      do iii=1,nres-3
7536 cd        write (2,*) iii,gcorr_loc(iii)
7537 cd      enddo
7538       eello4=ekont*eel4
7539 cd      write (2,*) 'ekont',ekont
7540 cd      write (iout,*) 'eello4',ekont*eel4
7541       return
7542       end
7543 C---------------------------------------------------------------------------
7544       double precision function eello5(i,j,k,l,jj,kk)
7545       implicit real*8 (a-h,o-z)
7546       include 'DIMENSIONS'
7547       include 'COMMON.IOUNITS'
7548       include 'COMMON.CHAIN'
7549       include 'COMMON.DERIV'
7550       include 'COMMON.INTERACT'
7551       include 'COMMON.CONTACTS'
7552       include 'COMMON.TORSION'
7553       include 'COMMON.VAR'
7554       include 'COMMON.GEO'
7555       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7556       double precision ggg1(3),ggg2(3)
7557 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7558 C                                                                              C
7559 C                            Parallel chains                                   C
7560 C                                                                              C
7561 C          o             o                   o             o                   C
7562 C         /l\           / \             \   / \           / \   /              C
7563 C        /   \         /   \             \ /   \         /   \ /               C
7564 C       j| o |l1       | o |              o| o |         | o |o                C
7565 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7566 C      \i/   \         /   \ /             /   \         /   \                 C
7567 C       o    k1             o                                                  C
7568 C         (I)          (II)                (III)          (IV)                 C
7569 C                                                                              C
7570 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7571 C                                                                              C
7572 C                            Antiparallel chains                               C
7573 C                                                                              C
7574 C          o             o                   o             o                   C
7575 C         /j\           / \             \   / \           / \   /              C
7576 C        /   \         /   \             \ /   \         /   \ /               C
7577 C      j1| o |l        | o |              o| o |         | o |o                C
7578 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7579 C      \i/   \         /   \ /             /   \         /   \                 C
7580 C       o     k1            o                                                  C
7581 C         (I)          (II)                (III)          (IV)                 C
7582 C                                                                              C
7583 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7584 C                                                                              C
7585 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7586 C                                                                              C
7587 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7588 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7589 cd        eello5=0.0d0
7590 cd        return
7591 cd      endif
7592 cd      write (iout,*)
7593 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7594 cd     &   ' and',k,l
7595       itk=itortyp(itype(k))
7596       itl=itortyp(itype(l))
7597       itj=itortyp(itype(j))
7598       eello5_1=0.0d0
7599       eello5_2=0.0d0
7600       eello5_3=0.0d0
7601       eello5_4=0.0d0
7602 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7603 cd     &   eel5_3_num,eel5_4_num)
7604       do iii=1,2
7605         do kkk=1,5
7606           do lll=1,3
7607             derx(lll,kkk,iii)=0.0d0
7608           enddo
7609         enddo
7610       enddo
7611 cd      eij=facont_hb(jj,i)
7612 cd      ekl=facont_hb(kk,k)
7613 cd      ekont=eij*ekl
7614 cd      write (iout,*)'Contacts have occurred for peptide groups',
7615 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7616 cd      goto 1111
7617 C Contribution from the graph I.
7618 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7619 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7620       call transpose2(EUg(1,1,k),auxmat(1,1))
7621       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7622       vv(1)=pizda(1,1)-pizda(2,2)
7623       vv(2)=pizda(1,2)+pizda(2,1)
7624       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7625      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7626 C Explicit gradient in virtual-dihedral angles.
7627       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7628      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7629      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7630       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7631       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7632       vv(1)=pizda(1,1)-pizda(2,2)
7633       vv(2)=pizda(1,2)+pizda(2,1)
7634       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7635      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7636      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7637       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7638       vv(1)=pizda(1,1)-pizda(2,2)
7639       vv(2)=pizda(1,2)+pizda(2,1)
7640       if (l.eq.j+1) then
7641         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7642      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7643      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7644       else
7645         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7646      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7647      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7648       endif
7649 C Cartesian gradient
7650       do iii=1,2
7651         do kkk=1,5
7652           do lll=1,3
7653             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7654      &        pizda(1,1))
7655             vv(1)=pizda(1,1)-pizda(2,2)
7656             vv(2)=pizda(1,2)+pizda(2,1)
7657             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7658      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7659      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7660           enddo
7661         enddo
7662       enddo
7663 c      goto 1112
7664 c1111  continue
7665 C Contribution from graph II
7666       call transpose2(EE(1,1,itk),auxmat(1,1))
7667       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7668       vv(1)=pizda(1,1)+pizda(2,2)
7669       vv(2)=pizda(2,1)-pizda(1,2)
7670       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7671      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7672 C Explicit gradient in virtual-dihedral angles.
7673       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7674      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7675       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7676       vv(1)=pizda(1,1)+pizda(2,2)
7677       vv(2)=pizda(2,1)-pizda(1,2)
7678       if (l.eq.j+1) then
7679         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7680      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7681      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7682       else
7683         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7684      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7685      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7686       endif
7687 C Cartesian gradient
7688       do iii=1,2
7689         do kkk=1,5
7690           do lll=1,3
7691             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7692      &        pizda(1,1))
7693             vv(1)=pizda(1,1)+pizda(2,2)
7694             vv(2)=pizda(2,1)-pizda(1,2)
7695             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7696      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7697      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7698           enddo
7699         enddo
7700       enddo
7701 cd      goto 1112
7702 cd1111  continue
7703       if (l.eq.j+1) then
7704 cd        goto 1110
7705 C Parallel orientation
7706 C Contribution from graph III
7707         call transpose2(EUg(1,1,l),auxmat(1,1))
7708         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7709         vv(1)=pizda(1,1)-pizda(2,2)
7710         vv(2)=pizda(1,2)+pizda(2,1)
7711         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7712      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7713 C Explicit gradient in virtual-dihedral angles.
7714         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7715      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7716      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7717         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7718         vv(1)=pizda(1,1)-pizda(2,2)
7719         vv(2)=pizda(1,2)+pizda(2,1)
7720         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7721      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7722      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7723         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7724         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7725         vv(1)=pizda(1,1)-pizda(2,2)
7726         vv(2)=pizda(1,2)+pizda(2,1)
7727         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7728      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7729      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7730 C Cartesian gradient
7731         do iii=1,2
7732           do kkk=1,5
7733             do lll=1,3
7734               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7735      &          pizda(1,1))
7736               vv(1)=pizda(1,1)-pizda(2,2)
7737               vv(2)=pizda(1,2)+pizda(2,1)
7738               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7739      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7740      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7741             enddo
7742           enddo
7743         enddo
7744 cd        goto 1112
7745 C Contribution from graph IV
7746 cd1110    continue
7747         call transpose2(EE(1,1,itl),auxmat(1,1))
7748         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7749         vv(1)=pizda(1,1)+pizda(2,2)
7750         vv(2)=pizda(2,1)-pizda(1,2)
7751         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7752      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7753 C Explicit gradient in virtual-dihedral angles.
7754         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7755      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7756         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7757         vv(1)=pizda(1,1)+pizda(2,2)
7758         vv(2)=pizda(2,1)-pizda(1,2)
7759         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7760      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7761      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7762 C Cartesian gradient
7763         do iii=1,2
7764           do kkk=1,5
7765             do lll=1,3
7766               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7767      &          pizda(1,1))
7768               vv(1)=pizda(1,1)+pizda(2,2)
7769               vv(2)=pizda(2,1)-pizda(1,2)
7770               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7771      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7772      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7773             enddo
7774           enddo
7775         enddo
7776       else
7777 C Antiparallel orientation
7778 C Contribution from graph III
7779 c        goto 1110
7780         call transpose2(EUg(1,1,j),auxmat(1,1))
7781         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7782         vv(1)=pizda(1,1)-pizda(2,2)
7783         vv(2)=pizda(1,2)+pizda(2,1)
7784         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7785      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7786 C Explicit gradient in virtual-dihedral angles.
7787         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7788      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7789      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7790         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7791         vv(1)=pizda(1,1)-pizda(2,2)
7792         vv(2)=pizda(1,2)+pizda(2,1)
7793         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7794      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7795      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7796         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7797         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7798         vv(1)=pizda(1,1)-pizda(2,2)
7799         vv(2)=pizda(1,2)+pizda(2,1)
7800         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7801      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7802      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7803 C Cartesian gradient
7804         do iii=1,2
7805           do kkk=1,5
7806             do lll=1,3
7807               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7808      &          pizda(1,1))
7809               vv(1)=pizda(1,1)-pizda(2,2)
7810               vv(2)=pizda(1,2)+pizda(2,1)
7811               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7812      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7813      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7814             enddo
7815           enddo
7816         enddo
7817 cd        goto 1112
7818 C Contribution from graph IV
7819 1110    continue
7820         call transpose2(EE(1,1,itj),auxmat(1,1))
7821         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7822         vv(1)=pizda(1,1)+pizda(2,2)
7823         vv(2)=pizda(2,1)-pizda(1,2)
7824         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7825      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7826 C Explicit gradient in virtual-dihedral angles.
7827         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7828      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7829         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7830         vv(1)=pizda(1,1)+pizda(2,2)
7831         vv(2)=pizda(2,1)-pizda(1,2)
7832         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7833      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7834      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7835 C Cartesian gradient
7836         do iii=1,2
7837           do kkk=1,5
7838             do lll=1,3
7839               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7840      &          pizda(1,1))
7841               vv(1)=pizda(1,1)+pizda(2,2)
7842               vv(2)=pizda(2,1)-pizda(1,2)
7843               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7844      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7845      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7846             enddo
7847           enddo
7848         enddo
7849       endif
7850 1112  continue
7851       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7852 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7853 cd        write (2,*) 'ijkl',i,j,k,l
7854 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7855 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7856 cd      endif
7857 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7858 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7859 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7860 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7861       if (j.lt.nres-1) then
7862         j1=j+1
7863         j2=j-1
7864       else
7865         j1=j-1
7866         j2=j-2
7867       endif
7868       if (l.lt.nres-1) then
7869         l1=l+1
7870         l2=l-1
7871       else
7872         l1=l-1
7873         l2=l-2
7874       endif
7875 cd      eij=1.0d0
7876 cd      ekl=1.0d0
7877 cd      ekont=1.0d0
7878 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7879 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7880 C        summed up outside the subrouine as for the other subroutines
7881 C        handling long-range interactions. The old code is commented out
7882 C        with "cgrad" to keep track of changes.
7883       do ll=1,3
7884 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7885 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7886         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7887         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7888 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7889 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7890 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7891 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7892 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7893 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7894 c     &   gradcorr5ij,
7895 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7896 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7897 cgrad        ghalf=0.5d0*ggg1(ll)
7898 cd        ghalf=0.0d0
7899         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7900         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7901         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7902         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7903         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7904         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7905 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7906 cgrad        ghalf=0.5d0*ggg2(ll)
7907 cd        ghalf=0.0d0
7908         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7909         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7910         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7911         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7912         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7913         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7914       enddo
7915 cd      goto 1112
7916 cgrad      do m=i+1,j-1
7917 cgrad        do ll=1,3
7918 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7919 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7920 cgrad        enddo
7921 cgrad      enddo
7922 cgrad      do m=k+1,l-1
7923 cgrad        do ll=1,3
7924 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7925 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7926 cgrad        enddo
7927 cgrad      enddo
7928 c1112  continue
7929 cgrad      do m=i+2,j2
7930 cgrad        do ll=1,3
7931 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7932 cgrad        enddo
7933 cgrad      enddo
7934 cgrad      do m=k+2,l2
7935 cgrad        do ll=1,3
7936 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7937 cgrad        enddo
7938 cgrad      enddo
7939 cd      do iii=1,nres-3
7940 cd        write (2,*) iii,g_corr5_loc(iii)
7941 cd      enddo
7942       eello5=ekont*eel5
7943 cd      write (2,*) 'ekont',ekont
7944 cd      write (iout,*) 'eello5',ekont*eel5
7945       return
7946       end
7947 c--------------------------------------------------------------------------
7948       double precision function eello6(i,j,k,l,jj,kk)
7949       implicit real*8 (a-h,o-z)
7950       include 'DIMENSIONS'
7951       include 'COMMON.IOUNITS'
7952       include 'COMMON.CHAIN'
7953       include 'COMMON.DERIV'
7954       include 'COMMON.INTERACT'
7955       include 'COMMON.CONTACTS'
7956       include 'COMMON.TORSION'
7957       include 'COMMON.VAR'
7958       include 'COMMON.GEO'
7959       include 'COMMON.FFIELD'
7960       double precision ggg1(3),ggg2(3)
7961 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7962 cd        eello6=0.0d0
7963 cd        return
7964 cd      endif
7965 cd      write (iout,*)
7966 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7967 cd     &   ' and',k,l
7968       eello6_1=0.0d0
7969       eello6_2=0.0d0
7970       eello6_3=0.0d0
7971       eello6_4=0.0d0
7972       eello6_5=0.0d0
7973       eello6_6=0.0d0
7974 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7975 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7976       do iii=1,2
7977         do kkk=1,5
7978           do lll=1,3
7979             derx(lll,kkk,iii)=0.0d0
7980           enddo
7981         enddo
7982       enddo
7983 cd      eij=facont_hb(jj,i)
7984 cd      ekl=facont_hb(kk,k)
7985 cd      ekont=eij*ekl
7986 cd      eij=1.0d0
7987 cd      ekl=1.0d0
7988 cd      ekont=1.0d0
7989       if (l.eq.j+1) then
7990         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7991         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7992         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7993         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7994         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7995         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7996       else
7997         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7998         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7999         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8000         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8001         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8002           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8003         else
8004           eello6_5=0.0d0
8005         endif
8006         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8007       endif
8008 C If turn contributions are considered, they will be handled separately.
8009       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8010 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8011 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8012 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8013 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8014 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8015 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8016 cd      goto 1112
8017       if (j.lt.nres-1) then
8018         j1=j+1
8019         j2=j-1
8020       else
8021         j1=j-1
8022         j2=j-2
8023       endif
8024       if (l.lt.nres-1) then
8025         l1=l+1
8026         l2=l-1
8027       else
8028         l1=l-1
8029         l2=l-2
8030       endif
8031       do ll=1,3
8032 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8033 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8034 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8035 cgrad        ghalf=0.5d0*ggg1(ll)
8036 cd        ghalf=0.0d0
8037         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8038         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8039         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8040         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8041         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8042         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8043         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8044         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8045 cgrad        ghalf=0.5d0*ggg2(ll)
8046 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8047 cd        ghalf=0.0d0
8048         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8049         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8050         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8051         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8052         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8053         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8054       enddo
8055 cd      goto 1112
8056 cgrad      do m=i+1,j-1
8057 cgrad        do ll=1,3
8058 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8059 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8060 cgrad        enddo
8061 cgrad      enddo
8062 cgrad      do m=k+1,l-1
8063 cgrad        do ll=1,3
8064 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8065 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8066 cgrad        enddo
8067 cgrad      enddo
8068 cgrad1112  continue
8069 cgrad      do m=i+2,j2
8070 cgrad        do ll=1,3
8071 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8072 cgrad        enddo
8073 cgrad      enddo
8074 cgrad      do m=k+2,l2
8075 cgrad        do ll=1,3
8076 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8077 cgrad        enddo
8078 cgrad      enddo
8079 cd      do iii=1,nres-3
8080 cd        write (2,*) iii,g_corr6_loc(iii)
8081 cd      enddo
8082       eello6=ekont*eel6
8083 cd      write (2,*) 'ekont',ekont
8084 cd      write (iout,*) 'eello6',ekont*eel6
8085       return
8086       end
8087 c--------------------------------------------------------------------------
8088       double precision function eello6_graph1(i,j,k,l,imat,swap)
8089       implicit real*8 (a-h,o-z)
8090       include 'DIMENSIONS'
8091       include 'COMMON.IOUNITS'
8092       include 'COMMON.CHAIN'
8093       include 'COMMON.DERIV'
8094       include 'COMMON.INTERACT'
8095       include 'COMMON.CONTACTS'
8096       include 'COMMON.TORSION'
8097       include 'COMMON.VAR'
8098       include 'COMMON.GEO'
8099       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8100       logical swap
8101       logical lprn
8102       common /kutas/ lprn
8103 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8104 C
8105 C      Parallel       Antiparallel
8106 C
8107 C          o             o
8108 C         /l\           /j\
8109 C        /   \         /   \
8110 C       /| o |         | o |\
8111 C     \ j|/k\|  /   \  |/k\|l /
8112 C      \ /   \ /     \ /   \ /
8113 C       o     o       o     o
8114 C       i             i
8115 C
8116 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8117       itk=itortyp(itype(k))
8118       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8119       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8120       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8121       call transpose2(EUgC(1,1,k),auxmat(1,1))
8122       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8123       vv1(1)=pizda1(1,1)-pizda1(2,2)
8124       vv1(2)=pizda1(1,2)+pizda1(2,1)
8125       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8126       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8127       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8128       s5=scalar2(vv(1),Dtobr2(1,i))
8129 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8130       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8131       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8132      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8133      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8134      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8135      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8136      & +scalar2(vv(1),Dtobr2der(1,i)))
8137       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8138       vv1(1)=pizda1(1,1)-pizda1(2,2)
8139       vv1(2)=pizda1(1,2)+pizda1(2,1)
8140       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8141       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8142       if (l.eq.j+1) then
8143         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8144      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8145      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8146      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8147      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8148       else
8149         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8150      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8151      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8152      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8153      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8154       endif
8155       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8156       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8157       vv1(1)=pizda1(1,1)-pizda1(2,2)
8158       vv1(2)=pizda1(1,2)+pizda1(2,1)
8159       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8160      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8161      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8162      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8163       do iii=1,2
8164         if (swap) then
8165           ind=3-iii
8166         else
8167           ind=iii
8168         endif
8169         do kkk=1,5
8170           do lll=1,3
8171             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8172             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8173             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8174             call transpose2(EUgC(1,1,k),auxmat(1,1))
8175             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8176      &        pizda1(1,1))
8177             vv1(1)=pizda1(1,1)-pizda1(2,2)
8178             vv1(2)=pizda1(1,2)+pizda1(2,1)
8179             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8180             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8181      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8182             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8183      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8184             s5=scalar2(vv(1),Dtobr2(1,i))
8185             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8186           enddo
8187         enddo
8188       enddo
8189       return
8190       end
8191 c----------------------------------------------------------------------------
8192       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8193       implicit real*8 (a-h,o-z)
8194       include 'DIMENSIONS'
8195       include 'COMMON.IOUNITS'
8196       include 'COMMON.CHAIN'
8197       include 'COMMON.DERIV'
8198       include 'COMMON.INTERACT'
8199       include 'COMMON.CONTACTS'
8200       include 'COMMON.TORSION'
8201       include 'COMMON.VAR'
8202       include 'COMMON.GEO'
8203       logical swap
8204       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8205      & auxvec1(2),auxvec2(1),auxmat1(2,2)
8206       logical lprn
8207       common /kutas/ lprn
8208 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8209 C                                                                              C
8210 C      Parallel       Antiparallel                                             C
8211 C                                                                              C
8212 C          o             o                                                     C
8213 C     \   /l\           /j\   /                                                C
8214 C      \ /   \         /   \ /                                                 C
8215 C       o| o |         | o |o                                                  C
8216 C     \ j|/k\|      \  |/k\|l                                                  C
8217 C      \ /   \       \ /   \                                                   C
8218 C       o             o                                                        C
8219 C       i             i                                                        C
8220 C                                                                              C
8221 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8222 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8223 C AL 7/4/01 s1 would occur in the sixth-order moment,
8224 C           but not in a cluster cumulant
8225 #ifdef MOMENT
8226       s1=dip(1,jj,i)*dip(1,kk,k)
8227 #endif
8228       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8229       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8230       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8231       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8232       call transpose2(EUg(1,1,k),auxmat(1,1))
8233       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8234       vv(1)=pizda(1,1)-pizda(2,2)
8235       vv(2)=pizda(1,2)+pizda(2,1)
8236       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8237 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8238 #ifdef MOMENT
8239       eello6_graph2=-(s1+s2+s3+s4)
8240 #else
8241       eello6_graph2=-(s2+s3+s4)
8242 #endif
8243 c      eello6_graph2=-s3
8244 C Derivatives in gamma(i-1)
8245       if (i.gt.1) then
8246 #ifdef MOMENT
8247         s1=dipderg(1,jj,i)*dip(1,kk,k)
8248 #endif
8249         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8250         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8251         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8252         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8253 #ifdef MOMENT
8254         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8255 #else
8256         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8257 #endif
8258 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8259       endif
8260 C Derivatives in gamma(k-1)
8261 #ifdef MOMENT
8262       s1=dip(1,jj,i)*dipderg(1,kk,k)
8263 #endif
8264       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8265       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8266       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8267       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8268       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8269       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8270       vv(1)=pizda(1,1)-pizda(2,2)
8271       vv(2)=pizda(1,2)+pizda(2,1)
8272       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8273 #ifdef MOMENT
8274       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8275 #else
8276       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8277 #endif
8278 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8279 C Derivatives in gamma(j-1) or gamma(l-1)
8280       if (j.gt.1) then
8281 #ifdef MOMENT
8282         s1=dipderg(3,jj,i)*dip(1,kk,k)
8283 #endif
8284         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8285         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8286         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8287         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8288         vv(1)=pizda(1,1)-pizda(2,2)
8289         vv(2)=pizda(1,2)+pizda(2,1)
8290         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8291 #ifdef MOMENT
8292         if (swap) then
8293           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8294         else
8295           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8296         endif
8297 #endif
8298         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8299 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8300       endif
8301 C Derivatives in gamma(l-1) or gamma(j-1)
8302       if (l.gt.1) then
8303 #ifdef MOMENT
8304         s1=dip(1,jj,i)*dipderg(3,kk,k)
8305 #endif
8306         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8307         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8308         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8309         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8310         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8311         vv(1)=pizda(1,1)-pizda(2,2)
8312         vv(2)=pizda(1,2)+pizda(2,1)
8313         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8314 #ifdef MOMENT
8315         if (swap) then
8316           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8317         else
8318           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8319         endif
8320 #endif
8321         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8322 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8323       endif
8324 C Cartesian derivatives.
8325       if (lprn) then
8326         write (2,*) 'In eello6_graph2'
8327         do iii=1,2
8328           write (2,*) 'iii=',iii
8329           do kkk=1,5
8330             write (2,*) 'kkk=',kkk
8331             do jjj=1,2
8332               write (2,'(3(2f10.5),5x)')
8333      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8334             enddo
8335           enddo
8336         enddo
8337       endif
8338       do iii=1,2
8339         do kkk=1,5
8340           do lll=1,3
8341 #ifdef MOMENT
8342             if (iii.eq.1) then
8343               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8344             else
8345               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8346             endif
8347 #endif
8348             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8349      &        auxvec(1))
8350             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8351             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8352      &        auxvec(1))
8353             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8354             call transpose2(EUg(1,1,k),auxmat(1,1))
8355             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8356      &        pizda(1,1))
8357             vv(1)=pizda(1,1)-pizda(2,2)
8358             vv(2)=pizda(1,2)+pizda(2,1)
8359             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8360 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8361 #ifdef MOMENT
8362             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8363 #else
8364             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8365 #endif
8366             if (swap) then
8367               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8368             else
8369               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8370             endif
8371           enddo
8372         enddo
8373       enddo
8374       return
8375       end
8376 c----------------------------------------------------------------------------
8377       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8378       implicit real*8 (a-h,o-z)
8379       include 'DIMENSIONS'
8380       include 'COMMON.IOUNITS'
8381       include 'COMMON.CHAIN'
8382       include 'COMMON.DERIV'
8383       include 'COMMON.INTERACT'
8384       include 'COMMON.CONTACTS'
8385       include 'COMMON.TORSION'
8386       include 'COMMON.VAR'
8387       include 'COMMON.GEO'
8388       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8389       logical swap
8390 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8391 C                                                                              C
8392 C      Parallel       Antiparallel                                             C
8393 C                                                                              C
8394 C          o             o                                                     C
8395 C         /l\   /   \   /j\                                                    C
8396 C        /   \ /     \ /   \                                                   C
8397 C       /| o |o       o| o |\                                                  C
8398 C       j|/k\|  /      |/k\|l /                                                C
8399 C        /   \ /       /   \ /                                                 C
8400 C       /     o       /     o                                                  C
8401 C       i             i                                                        C
8402 C                                                                              C
8403 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8404 C
8405 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8406 C           energy moment and not to the cluster cumulant.
8407       iti=itortyp(itype(i))
8408       if (j.lt.nres-1) then
8409         itj1=itortyp(itype(j+1))
8410       else
8411         itj1=ntortyp+1
8412       endif
8413       itk=itortyp(itype(k))
8414       itk1=itortyp(itype(k+1))
8415       if (l.lt.nres-1) then
8416         itl1=itortyp(itype(l+1))
8417       else
8418         itl1=ntortyp+1
8419       endif
8420 #ifdef MOMENT
8421       s1=dip(4,jj,i)*dip(4,kk,k)
8422 #endif
8423       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8424       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8425       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8426       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8427       call transpose2(EE(1,1,itk),auxmat(1,1))
8428       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8429       vv(1)=pizda(1,1)+pizda(2,2)
8430       vv(2)=pizda(2,1)-pizda(1,2)
8431       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8432 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8433 cd     & "sum",-(s2+s3+s4)
8434 #ifdef MOMENT
8435       eello6_graph3=-(s1+s2+s3+s4)
8436 #else
8437       eello6_graph3=-(s2+s3+s4)
8438 #endif
8439 c      eello6_graph3=-s4
8440 C Derivatives in gamma(k-1)
8441       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8442       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8443       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8444       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8445 C Derivatives in gamma(l-1)
8446       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8447       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8448       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8449       vv(1)=pizda(1,1)+pizda(2,2)
8450       vv(2)=pizda(2,1)-pizda(1,2)
8451       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8452       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8453 C Cartesian derivatives.
8454       do iii=1,2
8455         do kkk=1,5
8456           do lll=1,3
8457 #ifdef MOMENT
8458             if (iii.eq.1) then
8459               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8460             else
8461               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8462             endif
8463 #endif
8464             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8465      &        auxvec(1))
8466             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8467             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8468      &        auxvec(1))
8469             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8470             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8471      &        pizda(1,1))
8472             vv(1)=pizda(1,1)+pizda(2,2)
8473             vv(2)=pizda(2,1)-pizda(1,2)
8474             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8475 #ifdef MOMENT
8476             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8477 #else
8478             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8479 #endif
8480             if (swap) then
8481               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8482             else
8483               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8484             endif
8485 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8486           enddo
8487         enddo
8488       enddo
8489       return
8490       end
8491 c----------------------------------------------------------------------------
8492       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8493       implicit real*8 (a-h,o-z)
8494       include 'DIMENSIONS'
8495       include 'COMMON.IOUNITS'
8496       include 'COMMON.CHAIN'
8497       include 'COMMON.DERIV'
8498       include 'COMMON.INTERACT'
8499       include 'COMMON.CONTACTS'
8500       include 'COMMON.TORSION'
8501       include 'COMMON.VAR'
8502       include 'COMMON.GEO'
8503       include 'COMMON.FFIELD'
8504       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8505      & auxvec1(2),auxmat1(2,2)
8506       logical swap
8507 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8508 C                                                                              C
8509 C      Parallel       Antiparallel                                             C
8510 C                                                                              C
8511 C          o             o                                                     C
8512 C         /l\   /   \   /j\                                                    C
8513 C        /   \ /     \ /   \                                                   C
8514 C       /| o |o       o| o |\                                                  C
8515 C     \ j|/k\|      \  |/k\|l                                                  C
8516 C      \ /   \       \ /   \                                                   C
8517 C       o     \       o     \                                                  C
8518 C       i             i                                                        C
8519 C                                                                              C
8520 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8521 C
8522 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8523 C           energy moment and not to the cluster cumulant.
8524 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8525       iti=itortyp(itype(i))
8526       itj=itortyp(itype(j))
8527       if (j.lt.nres-1) then
8528         itj1=itortyp(itype(j+1))
8529       else
8530         itj1=ntortyp+1
8531       endif
8532       itk=itortyp(itype(k))
8533       if (k.lt.nres-1) then
8534         itk1=itortyp(itype(k+1))
8535       else
8536         itk1=ntortyp+1
8537       endif
8538       itl=itortyp(itype(l))
8539       if (l.lt.nres-1) then
8540         itl1=itortyp(itype(l+1))
8541       else
8542         itl1=ntortyp+1
8543       endif
8544 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8545 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8546 cd     & ' itl',itl,' itl1',itl1
8547 #ifdef MOMENT
8548       if (imat.eq.1) then
8549         s1=dip(3,jj,i)*dip(3,kk,k)
8550       else
8551         s1=dip(2,jj,j)*dip(2,kk,l)
8552       endif
8553 #endif
8554       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8555       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8556       if (j.eq.l+1) then
8557         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8558         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8559       else
8560         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8561         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8562       endif
8563       call transpose2(EUg(1,1,k),auxmat(1,1))
8564       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8565       vv(1)=pizda(1,1)-pizda(2,2)
8566       vv(2)=pizda(2,1)+pizda(1,2)
8567       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8568 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8569 #ifdef MOMENT
8570       eello6_graph4=-(s1+s2+s3+s4)
8571 #else
8572       eello6_graph4=-(s2+s3+s4)
8573 #endif
8574 C Derivatives in gamma(i-1)
8575       if (i.gt.1) then
8576 #ifdef MOMENT
8577         if (imat.eq.1) then
8578           s1=dipderg(2,jj,i)*dip(3,kk,k)
8579         else
8580           s1=dipderg(4,jj,j)*dip(2,kk,l)
8581         endif
8582 #endif
8583         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8584         if (j.eq.l+1) then
8585           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8586           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8587         else
8588           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8589           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8590         endif
8591         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8592         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8593 cd          write (2,*) 'turn6 derivatives'
8594 #ifdef MOMENT
8595           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8596 #else
8597           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8598 #endif
8599         else
8600 #ifdef MOMENT
8601           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8602 #else
8603           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8604 #endif
8605         endif
8606       endif
8607 C Derivatives in gamma(k-1)
8608 #ifdef MOMENT
8609       if (imat.eq.1) then
8610         s1=dip(3,jj,i)*dipderg(2,kk,k)
8611       else
8612         s1=dip(2,jj,j)*dipderg(4,kk,l)
8613       endif
8614 #endif
8615       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8616       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8617       if (j.eq.l+1) then
8618         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8619         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8620       else
8621         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8622         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8623       endif
8624       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8625       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8626       vv(1)=pizda(1,1)-pizda(2,2)
8627       vv(2)=pizda(2,1)+pizda(1,2)
8628       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8629       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8630 #ifdef MOMENT
8631         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8632 #else
8633         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8634 #endif
8635       else
8636 #ifdef MOMENT
8637         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8638 #else
8639         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8640 #endif
8641       endif
8642 C Derivatives in gamma(j-1) or gamma(l-1)
8643       if (l.eq.j+1 .and. l.gt.1) then
8644         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8645         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8646         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8647         vv(1)=pizda(1,1)-pizda(2,2)
8648         vv(2)=pizda(2,1)+pizda(1,2)
8649         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8650         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8651       else if (j.gt.1) then
8652         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8653         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8654         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8655         vv(1)=pizda(1,1)-pizda(2,2)
8656         vv(2)=pizda(2,1)+pizda(1,2)
8657         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8658         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8659           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8660         else
8661           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8662         endif
8663       endif
8664 C Cartesian derivatives.
8665       do iii=1,2
8666         do kkk=1,5
8667           do lll=1,3
8668 #ifdef MOMENT
8669             if (iii.eq.1) then
8670               if (imat.eq.1) then
8671                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8672               else
8673                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8674               endif
8675             else
8676               if (imat.eq.1) then
8677                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8678               else
8679                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8680               endif
8681             endif
8682 #endif
8683             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8684      &        auxvec(1))
8685             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8686             if (j.eq.l+1) then
8687               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8688      &          b1(1,itj1),auxvec(1))
8689               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8690             else
8691               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8692      &          b1(1,itl1),auxvec(1))
8693               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8694             endif
8695             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8696      &        pizda(1,1))
8697             vv(1)=pizda(1,1)-pizda(2,2)
8698             vv(2)=pizda(2,1)+pizda(1,2)
8699             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8700             if (swap) then
8701               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8702 #ifdef MOMENT
8703                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8704      &             -(s1+s2+s4)
8705 #else
8706                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8707      &             -(s2+s4)
8708 #endif
8709                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8710               else
8711 #ifdef MOMENT
8712                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8713 #else
8714                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8715 #endif
8716                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8717               endif
8718             else
8719 #ifdef MOMENT
8720               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8721 #else
8722               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8723 #endif
8724               if (l.eq.j+1) then
8725                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8726               else
8727                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8728               endif
8729             endif
8730           enddo
8731         enddo
8732       enddo
8733       return
8734       end
8735 c----------------------------------------------------------------------------
8736       double precision function eello_turn6(i,jj,kk)
8737       implicit real*8 (a-h,o-z)
8738       include 'DIMENSIONS'
8739       include 'COMMON.IOUNITS'
8740       include 'COMMON.CHAIN'
8741       include 'COMMON.DERIV'
8742       include 'COMMON.INTERACT'
8743       include 'COMMON.CONTACTS'
8744       include 'COMMON.TORSION'
8745       include 'COMMON.VAR'
8746       include 'COMMON.GEO'
8747       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8748      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8749      &  ggg1(3),ggg2(3)
8750       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8751      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8752 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8753 C           the respective energy moment and not to the cluster cumulant.
8754       s1=0.0d0
8755       s8=0.0d0
8756       s13=0.0d0
8757 c
8758       eello_turn6=0.0d0
8759       j=i+4
8760       k=i+1
8761       l=i+3
8762       iti=itortyp(itype(i))
8763       itk=itortyp(itype(k))
8764       itk1=itortyp(itype(k+1))
8765       itl=itortyp(itype(l))
8766       itj=itortyp(itype(j))
8767 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8768 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8769 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8770 cd        eello6=0.0d0
8771 cd        return
8772 cd      endif
8773 cd      write (iout,*)
8774 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8775 cd     &   ' and',k,l
8776 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8777       do iii=1,2
8778         do kkk=1,5
8779           do lll=1,3
8780             derx_turn(lll,kkk,iii)=0.0d0
8781           enddo
8782         enddo
8783       enddo
8784 cd      eij=1.0d0
8785 cd      ekl=1.0d0
8786 cd      ekont=1.0d0
8787       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8788 cd      eello6_5=0.0d0
8789 cd      write (2,*) 'eello6_5',eello6_5
8790 #ifdef MOMENT
8791       call transpose2(AEA(1,1,1),auxmat(1,1))
8792       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8793       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8794       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8795 #endif
8796       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8797       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8798       s2 = scalar2(b1(1,itk),vtemp1(1))
8799 #ifdef MOMENT
8800       call transpose2(AEA(1,1,2),atemp(1,1))
8801       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8802       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8803       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8804 #endif
8805       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8806       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8807       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8808 #ifdef MOMENT
8809       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8810       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8811       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8812       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8813       ss13 = scalar2(b1(1,itk),vtemp4(1))
8814       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8815 #endif
8816 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8817 c      s1=0.0d0
8818 c      s2=0.0d0
8819 c      s8=0.0d0
8820 c      s12=0.0d0
8821 c      s13=0.0d0
8822       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8823 C Derivatives in gamma(i+2)
8824       s1d =0.0d0
8825       s8d =0.0d0
8826 #ifdef MOMENT
8827       call transpose2(AEA(1,1,1),auxmatd(1,1))
8828       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8829       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8830       call transpose2(AEAderg(1,1,2),atempd(1,1))
8831       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8832       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8833 #endif
8834       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8835       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8836       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8837 c      s1d=0.0d0
8838 c      s2d=0.0d0
8839 c      s8d=0.0d0
8840 c      s12d=0.0d0
8841 c      s13d=0.0d0
8842       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8843 C Derivatives in gamma(i+3)
8844 #ifdef MOMENT
8845       call transpose2(AEA(1,1,1),auxmatd(1,1))
8846       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8847       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8848       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8849 #endif
8850       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8851       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8852       s2d = scalar2(b1(1,itk),vtemp1d(1))
8853 #ifdef MOMENT
8854       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8855       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8856 #endif
8857       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8858 #ifdef MOMENT
8859       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8860       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8861       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8862 #endif
8863 c      s1d=0.0d0
8864 c      s2d=0.0d0
8865 c      s8d=0.0d0
8866 c      s12d=0.0d0
8867 c      s13d=0.0d0
8868 #ifdef MOMENT
8869       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8870      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8871 #else
8872       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8873      &               -0.5d0*ekont*(s2d+s12d)
8874 #endif
8875 C Derivatives in gamma(i+4)
8876       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8877       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8878       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8879 #ifdef MOMENT
8880       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8881       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8882       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8883 #endif
8884 c      s1d=0.0d0
8885 c      s2d=0.0d0
8886 c      s8d=0.0d0
8887 C      s12d=0.0d0
8888 c      s13d=0.0d0
8889 #ifdef MOMENT
8890       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8891 #else
8892       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8893 #endif
8894 C Derivatives in gamma(i+5)
8895 #ifdef MOMENT
8896       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8897       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8898       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8899 #endif
8900       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8901       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8902       s2d = scalar2(b1(1,itk),vtemp1d(1))
8903 #ifdef MOMENT
8904       call transpose2(AEA(1,1,2),atempd(1,1))
8905       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8906       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8907 #endif
8908       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8909       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8910 #ifdef MOMENT
8911       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8912       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8913       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8914 #endif
8915 c      s1d=0.0d0
8916 c      s2d=0.0d0
8917 c      s8d=0.0d0
8918 c      s12d=0.0d0
8919 c      s13d=0.0d0
8920 #ifdef MOMENT
8921       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8922      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8923 #else
8924       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8925      &               -0.5d0*ekont*(s2d+s12d)
8926 #endif
8927 C Cartesian derivatives
8928       do iii=1,2
8929         do kkk=1,5
8930           do lll=1,3
8931 #ifdef MOMENT
8932             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8933             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8934             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8935 #endif
8936             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8937             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8938      &          vtemp1d(1))
8939             s2d = scalar2(b1(1,itk),vtemp1d(1))
8940 #ifdef MOMENT
8941             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8942             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8943             s8d = -(atempd(1,1)+atempd(2,2))*
8944      &           scalar2(cc(1,1,itl),vtemp2(1))
8945 #endif
8946             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8947      &           auxmatd(1,1))
8948             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8949             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8950 c      s1d=0.0d0
8951 c      s2d=0.0d0
8952 c      s8d=0.0d0
8953 c      s12d=0.0d0
8954 c      s13d=0.0d0
8955 #ifdef MOMENT
8956             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8957      &        - 0.5d0*(s1d+s2d)
8958 #else
8959             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8960      &        - 0.5d0*s2d
8961 #endif
8962 #ifdef MOMENT
8963             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8964      &        - 0.5d0*(s8d+s12d)
8965 #else
8966             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8967      &        - 0.5d0*s12d
8968 #endif
8969           enddo
8970         enddo
8971       enddo
8972 #ifdef MOMENT
8973       do kkk=1,5
8974         do lll=1,3
8975           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8976      &      achuj_tempd(1,1))
8977           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8978           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8979           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8980           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8981           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8982      &      vtemp4d(1))
8983           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8984           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8985           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8986         enddo
8987       enddo
8988 #endif
8989 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8990 cd     &  16*eel_turn6_num
8991 cd      goto 1112
8992       if (j.lt.nres-1) then
8993         j1=j+1
8994         j2=j-1
8995       else
8996         j1=j-1
8997         j2=j-2
8998       endif
8999       if (l.lt.nres-1) then
9000         l1=l+1
9001         l2=l-1
9002       else
9003         l1=l-1
9004         l2=l-2
9005       endif
9006       do ll=1,3
9007 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9008 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9009 cgrad        ghalf=0.5d0*ggg1(ll)
9010 cd        ghalf=0.0d0
9011         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9012         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9013         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9014      &    +ekont*derx_turn(ll,2,1)
9015         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9016         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9017      &    +ekont*derx_turn(ll,4,1)
9018         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9019         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9020         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9021 cgrad        ghalf=0.5d0*ggg2(ll)
9022 cd        ghalf=0.0d0
9023         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9024      &    +ekont*derx_turn(ll,2,2)
9025         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9026         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9027      &    +ekont*derx_turn(ll,4,2)
9028         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9029         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9030         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9031       enddo
9032 cd      goto 1112
9033 cgrad      do m=i+1,j-1
9034 cgrad        do ll=1,3
9035 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9036 cgrad        enddo
9037 cgrad      enddo
9038 cgrad      do m=k+1,l-1
9039 cgrad        do ll=1,3
9040 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9041 cgrad        enddo
9042 cgrad      enddo
9043 cgrad1112  continue
9044 cgrad      do m=i+2,j2
9045 cgrad        do ll=1,3
9046 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9047 cgrad        enddo
9048 cgrad      enddo
9049 cgrad      do m=k+2,l2
9050 cgrad        do ll=1,3
9051 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9052 cgrad        enddo
9053 cgrad      enddo
9054 cd      do iii=1,nres-3
9055 cd        write (2,*) iii,g_corr6_loc(iii)
9056 cd      enddo
9057       eello_turn6=ekont*eel_turn6
9058 cd      write (2,*) 'ekont',ekont
9059 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9060       return
9061       end
9062
9063 C-----------------------------------------------------------------------------
9064       double precision function scalar(u,v)
9065 !DIR$ INLINEALWAYS scalar
9066 #ifndef OSF
9067 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9068 #endif
9069       implicit none
9070       double precision u(3),v(3)
9071 cd      double precision sc
9072 cd      integer i
9073 cd      sc=0.0d0
9074 cd      do i=1,3
9075 cd        sc=sc+u(i)*v(i)
9076 cd      enddo
9077 cd      scalar=sc
9078
9079       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9080       return
9081       end
9082 crc-------------------------------------------------
9083       SUBROUTINE MATVEC2(A1,V1,V2)
9084 !DIR$ INLINEALWAYS MATVEC2
9085 #ifndef OSF
9086 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9087 #endif
9088       implicit real*8 (a-h,o-z)
9089       include 'DIMENSIONS'
9090       DIMENSION A1(2,2),V1(2),V2(2)
9091 c      DO 1 I=1,2
9092 c        VI=0.0
9093 c        DO 3 K=1,2
9094 c    3     VI=VI+A1(I,K)*V1(K)
9095 c        Vaux(I)=VI
9096 c    1 CONTINUE
9097
9098       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9099       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9100
9101       v2(1)=vaux1
9102       v2(2)=vaux2
9103       END
9104 C---------------------------------------
9105       SUBROUTINE MATMAT2(A1,A2,A3)
9106 #ifndef OSF
9107 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9108 #endif
9109       implicit real*8 (a-h,o-z)
9110       include 'DIMENSIONS'
9111       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9112 c      DIMENSION AI3(2,2)
9113 c        DO  J=1,2
9114 c          A3IJ=0.0
9115 c          DO K=1,2
9116 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9117 c          enddo
9118 c          A3(I,J)=A3IJ
9119 c       enddo
9120 c      enddo
9121
9122       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9123       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9124       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9125       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9126
9127       A3(1,1)=AI3_11
9128       A3(2,1)=AI3_21
9129       A3(1,2)=AI3_12
9130       A3(2,2)=AI3_22
9131       END
9132
9133 c-------------------------------------------------------------------------
9134       double precision function scalar2(u,v)
9135 !DIR$ INLINEALWAYS scalar2
9136       implicit none
9137       double precision u(2),v(2)
9138       double precision sc
9139       integer i
9140       scalar2=u(1)*v(1)+u(2)*v(2)
9141       return
9142       end
9143
9144 C-----------------------------------------------------------------------------
9145
9146       subroutine transpose2(a,at)
9147 !DIR$ INLINEALWAYS transpose2
9148 #ifndef OSF
9149 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9150 #endif
9151       implicit none
9152       double precision a(2,2),at(2,2)
9153       at(1,1)=a(1,1)
9154       at(1,2)=a(2,1)
9155       at(2,1)=a(1,2)
9156       at(2,2)=a(2,2)
9157       return
9158       end
9159 c--------------------------------------------------------------------------
9160       subroutine transpose(n,a,at)
9161       implicit none
9162       integer n,i,j
9163       double precision a(n,n),at(n,n)
9164       do i=1,n
9165         do j=1,n
9166           at(j,i)=a(i,j)
9167         enddo
9168       enddo
9169       return
9170       end
9171 C---------------------------------------------------------------------------
9172       subroutine prodmat3(a1,a2,kk,transp,prod)
9173 !DIR$ INLINEALWAYS prodmat3
9174 #ifndef OSF
9175 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9176 #endif
9177       implicit none
9178       integer i,j
9179       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9180       logical transp
9181 crc      double precision auxmat(2,2),prod_(2,2)
9182
9183       if (transp) then
9184 crc        call transpose2(kk(1,1),auxmat(1,1))
9185 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9186 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9187
9188            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9189      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9190            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9191      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9192            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9193      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9194            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9195      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9196
9197       else
9198 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9199 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9200
9201            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9202      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9203            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9204      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9205            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9206      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9207            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9208      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9209
9210       endif
9211 c      call transpose2(a2(1,1),a2t(1,1))
9212
9213 crc      print *,transp
9214 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9215 crc      print *,((prod(i,j),i=1,2),j=1,2)
9216
9217       return
9218       end
9219