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 #ifdef DEBUG
 783       write (iout,*) "gloc_sc before reduce"
 784       do i=1,nres
 785        do j=1,3
 786         write (iout,*) i,j,gloc_sc(j,i,icg)
 787        enddo
 788       enddo
 789 #endif
 790         do i=1,nres
 791          do j=1,3
 792           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 793          enddo
 794         enddo
 795         time00=MPI_Wtime()
 796         call MPI_Barrier(FG_COMM,IERR)
 797         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 798         time00=MPI_Wtime()
 799         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 800      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 801         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 802      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 803         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 804      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 805         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 806      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 807         time_reduce=time_reduce+MPI_Wtime()-time00
 808 #ifdef DEBUG
 809       write (iout,*) "gloc_sc after reduce"
 810       do i=1,nres
 811        do j=1,3
 812         write (iout,*) i,j,gloc_sc(j,i,icg)
 813        enddo
 814       enddo
 815 #endif
 816 #ifdef DEBUG
 817       write (iout,*) "gloc after reduce"
 818       do i=1,4*nres
 819         write (iout,*) i,gloc(i,icg)
 820       enddo
 821 #endif
 822       endif
 823 #endif
 824       if (gnorm_check) then
 825 c
 826 c Compute the maximum elements of the gradient
 827 c
 828       gvdwc_max=0.0d0
 829       gvdwc_scp_max=0.0d0
 830       gelc_max=0.0d0
 831       gvdwpp_max=0.0d0
 832       gradb_max=0.0d0
 833       ghpbc_max=0.0d0
 834       gradcorr_max=0.0d0
 835       gel_loc_max=0.0d0
 836       gcorr3_turn_max=0.0d0
 837       gcorr4_turn_max=0.0d0
 838       gradcorr5_max=0.0d0
 839       gradcorr6_max=0.0d0
 840       gcorr6_turn_max=0.0d0
 841       gsccorc_max=0.0d0
 842       gscloc_max=0.0d0
 843       gvdwx_max=0.0d0
 844       gradx_scp_max=0.0d0
 845       ghpbx_max=0.0d0
 846       gradxorr_max=0.0d0
 847       gsccorx_max=0.0d0
 848       gsclocx_max=0.0d0
 849       do i=1,nct
 850         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 851         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 852 #ifdef TSCSC
 853         gvdwc_norm=dsqrt(scalar(gvdwcT(1,i),gvdwcT(1,i)))
 854         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 855 #endif
 856         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 857         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 858      &   gvdwc_scp_max=gvdwc_scp_norm
 859         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 860         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 861         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 862         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 863         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 864         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 865         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 866         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 867         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 868         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 869         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 870         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 871         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 872      &    gcorr3_turn(1,i)))
 873         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 874      &    gcorr3_turn_max=gcorr3_turn_norm
 875         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 876      &    gcorr4_turn(1,i)))
 877         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 878      &    gcorr4_turn_max=gcorr4_turn_norm
 879         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 880         if (gradcorr5_norm.gt.gradcorr5_max)
 881      &    gradcorr5_max=gradcorr5_norm
 882         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 883         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 884         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 885      &    gcorr6_turn(1,i)))
 886         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 887      &    gcorr6_turn_max=gcorr6_turn_norm
 888         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 889         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 890         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 891         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 892         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 893         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 894 #ifdef TSCSC
 895         gvdwx_norm=dsqrt(scalar(gvdwxT(1,i),gvdwxT(1,i)))
 896         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 897 #endif
 898         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 899         if (gradx_scp_norm.gt.gradx_scp_max)
 900      &    gradx_scp_max=gradx_scp_norm
 901         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 902         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 903         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 904         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 905         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 906         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 907         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 908         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 909       enddo
 910       if (gradout) then
 911 #ifdef AIX
 912         open(istat,file=statname,position="append")
 913 #else
 914         open(istat,file=statname,access="append")
 915 #endif
 916         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 917      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 918      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 919      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 920      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 921      &     gsccorx_max,gsclocx_max
 922         close(istat)
 923         if (gvdwc_max.gt.1.0d4) then
 924           write (iout,*) "gvdwc gvdwx gradb gradbx"
 925           do i=nnt,nct
 926             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 927      &        gradb(j,i),gradbx(j,i),j=1,3)
 928           enddo
 929           call pdbout(0.0d0,'cipiszcze',iout)
 930           call flush(iout)
 931         endif
 932       endif
 933       endif
 934 #ifdef DEBUG
 935       write (iout,*) "gradc gradx gloc"
 936       do i=1,nres
 937         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 938      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 939       enddo
 940 #endif
 941 #ifdef TIMING
 942 #ifdef MPI
 943       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 944 #else
 945       time_sumgradient=time_sumgradient+tcpu()-time01
 946 #endif
 947 #endif
 948       return
 949       end
 950 c-------------------------------------------------------------------------------
 951       subroutine rescale_weights(t_bath)
 952       implicit real*8 (a-h,o-z)
 953       include 'DIMENSIONS'
 954       include 'COMMON.IOUNITS'
 955       include 'COMMON.FFIELD'
 956       include 'COMMON.SBRIDGE'
 957       double precision kfac /2.4d0/
 958       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 959 c      facT=temp0/t_bath
 960 c      facT=2*temp0/(t_bath+temp0)
 961       if (rescale_mode.eq.0) then
 962         facT=1.0d0
 963         facT2=1.0d0
 964         facT3=1.0d0
 965         facT4=1.0d0
 966         facT5=1.0d0
 967       else if (rescale_mode.eq.1) then
 968         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 969         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 970         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 971         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 972         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 973       else if (rescale_mode.eq.2) then
 974         x=t_bath/temp0
 975         x2=x*x
 976         x3=x2*x
 977         x4=x3*x
 978         x5=x4*x
 979         facT=licznik/dlog(dexp(x)+dexp(-x))
 980         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 981         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 982         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 983         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 984       else
 985         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 986         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 987 #ifdef MPI
 988        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 989 #endif
 990        stop 555
 991       endif
 992       welec=weights(3)*fact
 993       wcorr=weights(4)*fact3
 994       wcorr5=weights(5)*fact4
 995       wcorr6=weights(6)*fact5
 996       wel_loc=weights(7)*fact2
 997       wturn3=weights(8)*fact2
 998       wturn4=weights(9)*fact3
 999       wturn6=weights(10)*fact5
1000       wtor=weights(13)*fact
1001       wtor_d=weights(14)*fact2
1002       wsccor=weights(21)*fact
1003 #ifdef TSCSC
1004 c      wsct=t_bath/temp0
1005       wsct=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
1006 #endif
1007       return
1008       end
1009 C------------------------------------------------------------------------
1010       subroutine enerprint(energia)
1011       implicit real*8 (a-h,o-z)
1012       include 'DIMENSIONS'
1013       include 'COMMON.IOUNITS'
1014       include 'COMMON.FFIELD'
1015       include 'COMMON.SBRIDGE'
1016       include 'COMMON.MD'
1017       double precision energia(0:n_ene)
1018       etot=energia(0)
1019 #ifdef TSCSC
1020       evdw=energia(22)+wsct*energia(23)
1021 #else
1022       evdw=energia(1)
1023 #endif
1024       evdw2=energia(2)
1025 #ifdef SCP14
1026       evdw2=energia(2)+energia(18)
1027 #else
1028       evdw2=energia(2)
1029 #endif
1030       ees=energia(3)
1031 #ifdef SPLITELE
1032       evdw1=energia(16)
1033 #endif
1034       ecorr=energia(4)
1035       ecorr5=energia(5)
1036       ecorr6=energia(6)
1037       eel_loc=energia(7)
1038       eello_turn3=energia(8)
1039       eello_turn4=energia(9)
1040       eello_turn6=energia(10)
1041       ebe=energia(11)
1042       escloc=energia(12)
1043       etors=energia(13)
1044       etors_d=energia(14)
1045       ehpb=energia(15)
1046       edihcnstr=energia(19)
1047       estr=energia(17)
1048       Uconst=energia(20)
1049       esccor=energia(21)
1050 #ifdef SPLITELE
1051       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1052      &  estr,wbond,ebe,wang,
1053      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1054      &  ecorr,wcorr,
1055      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1056      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
1057      &  edihcnstr,ebr*nss,
1058      &  Uconst,etot
1059    10 format (/'Virtual-chain energies:'//
1060      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1061      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1062      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1063      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
1064      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1065      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1066      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1067      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1068      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1069      & 'EHPB=  ',1pE16.6,' WEIGHT=',1pD16.6,
1070      & ' (SS bridges & dist. cnstr.)'/
1071      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1072      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1073      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1074      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1075      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1076      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1077      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1078      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1079      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1080      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1081      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1082      & 'ETOT=  ',1pE16.6,' (total)')
1083 #else
1084       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1085      &  estr,wbond,ebe,wang,
1086      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1087      &  ecorr,wcorr,
1088      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1089      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1090      &  ebr*nss,Uconst,etot
1091    10 format (/'Virtual-chain energies:'//
1092      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1093      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1094      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1095      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1096      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1097      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1098      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1099      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1100      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1101      & ' (SS bridges & dist. cnstr.)'/
1102      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1103      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1104      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1105      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1106      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1107      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1108      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1109      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1110      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1111      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1112      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1113      & 'ETOT=  ',1pE16.6,' (total)')
1114 #endif
1115       return
1116       end
1117 C-----------------------------------------------------------------------
1118       subroutine elj(evdw,evdw_p,evdw_m)
1119 C
1120 C This subroutine calculates the interaction energy of nonbonded side chains
1121 C assuming the LJ potential of interaction.
1122 C
1123       implicit real*8 (a-h,o-z)
1124       include 'DIMENSIONS'
1125       parameter (accur=1.0d-10)
1126       include 'COMMON.GEO'
1127       include 'COMMON.VAR'
1128       include 'COMMON.LOCAL'
1129       include 'COMMON.CHAIN'
1130       include 'COMMON.DERIV'
1131       include 'COMMON.INTERACT'
1132       include 'COMMON.TORSION'
1133       include 'COMMON.SBRIDGE'
1134       include 'COMMON.NAMES'
1135       include 'COMMON.IOUNITS'
1136       include 'COMMON.CONTACTS'
1137       dimension gg(3)
1138 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1139       evdw=0.0D0
1140       do i=iatsc_s,iatsc_e
1141         itypi=itype(i)
1142         itypi1=itype(i+1)
1143         xi=c(1,nres+i)
1144         yi=c(2,nres+i)
1145         zi=c(3,nres+i)
1146 C Change 12/1/95
1147         num_conti=0
1148 C
1149 C Calculate SC interaction energy.
1150 C
1151         do iint=1,nint_gr(i)
1152 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1153 cd   &                  'iend=',iend(i,iint)
1154           do j=istart(i,iint),iend(i,iint)
1155             itypj=itype(j)
1156             xj=c(1,nres+j)-xi
1157             yj=c(2,nres+j)-yi
1158             zj=c(3,nres+j)-zi
1159 C Change 12/1/95 to calculate four-body interactions
1160             rij=xj*xj+yj*yj+zj*zj
1161             rrij=1.0D0/rij
1162 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1163             eps0ij=eps(itypi,itypj)
1164             fac=rrij**expon2
1165             e1=fac*fac*aa(itypi,itypj)
1166             e2=fac*bb(itypi,itypj)
1167             evdwij=e1+e2
1168 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1169 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1170 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1171 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1172 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1173 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1174 #ifdef TSCSC
1175             if (bb(itypi,itypj).gt.0) then
1176                evdw_p=evdw_p+evdwij
1177             else
1178                evdw_m=evdw_m+evdwij
1179             endif
1180 #else
1181             evdw=evdw+evdwij
1182 #endif
1183 C
1184 C Calculate the components of the gradient in DC and X
1185 C
1186             fac=-rrij*(e1+evdwij)
1187             gg(1)=xj*fac
1188             gg(2)=yj*fac
1189             gg(3)=zj*fac
1190 #ifdef TSCSC
1191             if (bb(itypi,itypj).gt.0.0d0) then
1192               do k=1,3
1193                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1194                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1195                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1196                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1197               enddo
1198             else
1199               do k=1,3
1200                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1201                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1202                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1203                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1204               enddo
1205             endif
1206 #else
1207             do k=1,3
1208               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1209               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1210               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1211               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1212             enddo
1213 #endif
1214 cgrad            do k=i,j-1
1215 cgrad              do l=1,3
1216 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1217 cgrad              enddo
1218 cgrad            enddo
1219 C
1220 C 12/1/95, revised on 5/20/97
1221 C
1222 C Calculate the contact function. The ith column of the array JCONT will
1223 C contain the numbers of atoms that make contacts with the atom I (of numbers
1224 C greater than I). The arrays FACONT and GACONT will contain the values of
1225 C the contact function and its derivative.
1226 C
1227 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1228 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1229 C Uncomment next line, if the correlation interactions are contact function only
1230             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1231               rij=dsqrt(rij)
1232               sigij=sigma(itypi,itypj)
1233               r0ij=rs0(itypi,itypj)
1234 C
1235 C Check whether the SC's are not too far to make a contact.
1236 C
1237               rcut=1.5d0*r0ij
1238               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1239 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1240 C
1241               if (fcont.gt.0.0D0) then
1242 C If the SC-SC distance if close to sigma, apply spline.
1243 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1244 cAdam &             fcont1,fprimcont1)
1245 cAdam           fcont1=1.0d0-fcont1
1246 cAdam           if (fcont1.gt.0.0d0) then
1247 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1248 cAdam             fcont=fcont*fcont1
1249 cAdam           endif
1250 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1251 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1252 cga             do k=1,3
1253 cga               gg(k)=gg(k)*eps0ij
1254 cga             enddo
1255 cga             eps0ij=-evdwij*eps0ij
1256 C Uncomment for AL's type of SC correlation interactions.
1257 cadam           eps0ij=-evdwij
1258                 num_conti=num_conti+1
1259                 jcont(num_conti,i)=j
1260                 facont(num_conti,i)=fcont*eps0ij
1261                 fprimcont=eps0ij*fprimcont/rij
1262                 fcont=expon*fcont
1263 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1264 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1265 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1266 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1267                 gacont(1,num_conti,i)=-fprimcont*xj
1268                 gacont(2,num_conti,i)=-fprimcont*yj
1269                 gacont(3,num_conti,i)=-fprimcont*zj
1270 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1271 cd              write (iout,'(2i3,3f10.5)')
1272 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1273               endif
1274             endif
1275           enddo      ! j
1276         enddo        ! iint
1277 C Change 12/1/95
1278         num_cont(i)=num_conti
1279       enddo          ! i
1280       do i=1,nct
1281         do j=1,3
1282           gvdwc(j,i)=expon*gvdwc(j,i)
1283           gvdwx(j,i)=expon*gvdwx(j,i)
1284         enddo
1285       enddo
1286 C******************************************************************************
1287 C
1288 C                              N O T E !!!
1289 C
1290 C To save time, the factor of EXPON has been extracted from ALL components
1291 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1292 C use!
1293 C
1294 C******************************************************************************
1295       return
1296       end
1297 C-----------------------------------------------------------------------------
1298       subroutine eljk(evdw,evdw_p,evdw_m)
1299 C
1300 C This subroutine calculates the interaction energy of nonbonded side chains
1301 C assuming the LJK potential of interaction.
1302 C
1303       implicit real*8 (a-h,o-z)
1304       include 'DIMENSIONS'
1305       include 'COMMON.GEO'
1306       include 'COMMON.VAR'
1307       include 'COMMON.LOCAL'
1308       include 'COMMON.CHAIN'
1309       include 'COMMON.DERIV'
1310       include 'COMMON.INTERACT'
1311       include 'COMMON.IOUNITS'
1312       include 'COMMON.NAMES'
1313       dimension gg(3)
1314       logical scheck
1315 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1316       evdw=0.0D0
1317       do i=iatsc_s,iatsc_e
1318         itypi=itype(i)
1319         itypi1=itype(i+1)
1320         xi=c(1,nres+i)
1321         yi=c(2,nres+i)
1322         zi=c(3,nres+i)
1323 C
1324 C Calculate SC interaction energy.
1325 C
1326         do iint=1,nint_gr(i)
1327           do j=istart(i,iint),iend(i,iint)
1328             itypj=itype(j)
1329             xj=c(1,nres+j)-xi
1330             yj=c(2,nres+j)-yi
1331             zj=c(3,nres+j)-zi
1332             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1333             fac_augm=rrij**expon
1334             e_augm=augm(itypi,itypj)*fac_augm
1335             r_inv_ij=dsqrt(rrij)
1336             rij=1.0D0/r_inv_ij
1337             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1338             fac=r_shift_inv**expon
1339             e1=fac*fac*aa(itypi,itypj)
1340             e2=fac*bb(itypi,itypj)
1341             evdwij=e_augm+e1+e2
1342 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1343 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1344 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1345 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1346 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1347 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1348 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1349 #ifdef TSCSC
1350             if (bb(itypi,itypj).gt.0) then
1351                evdw_p=evdw_p+evdwij
1352             else
1353                evdw_m=evdw_m+evdwij
1354             endif
1355 #else
1356             evdw=evdw+evdwij
1357 #endif
1358 C
1359 C Calculate the components of the gradient in DC and X
1360 C
1361             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1362             gg(1)=xj*fac
1363             gg(2)=yj*fac
1364             gg(3)=zj*fac
1365 #ifdef TSCSC
1366             if (bb(itypi,itypj).gt.0.0d0) then
1367               do k=1,3
1368                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1369                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1370                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1371                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1372               enddo
1373             else
1374               do k=1,3
1375                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1376                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1377                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1378                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1379               enddo
1380             endif
1381 #else
1382             do k=1,3
1383               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1384               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1385               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1386               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1387             enddo
1388 #endif
1389 cgrad            do k=i,j-1
1390 cgrad              do l=1,3
1391 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1392 cgrad              enddo
1393 cgrad            enddo
1394           enddo      ! j
1395         enddo        ! iint
1396       enddo          ! i
1397       do i=1,nct
1398         do j=1,3
1399           gvdwc(j,i)=expon*gvdwc(j,i)
1400           gvdwx(j,i)=expon*gvdwx(j,i)
1401         enddo
1402       enddo
1403       return
1404       end
1405 C-----------------------------------------------------------------------------
1406       subroutine ebp(evdw,evdw_p,evdw_m)
1407 C
1408 C This subroutine calculates the interaction energy of nonbonded side chains
1409 C assuming the Berne-Pechukas potential of interaction.
1410 C
1411       implicit real*8 (a-h,o-z)
1412       include 'DIMENSIONS'
1413       include 'COMMON.GEO'
1414       include 'COMMON.VAR'
1415       include 'COMMON.LOCAL'
1416       include 'COMMON.CHAIN'
1417       include 'COMMON.DERIV'
1418       include 'COMMON.NAMES'
1419       include 'COMMON.INTERACT'
1420       include 'COMMON.IOUNITS'
1421       include 'COMMON.CALC'
1422       common /srutu/ icall
1423 c     double precision rrsave(maxdim)
1424       logical lprn
1425       evdw=0.0D0
1426 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1427       evdw=0.0D0
1428 c     if (icall.eq.0) then
1429 c       lprn=.true.
1430 c     else
1431         lprn=.false.
1432 c     endif
1433       ind=0
1434       do i=iatsc_s,iatsc_e
1435         itypi=itype(i)
1436         itypi1=itype(i+1)
1437         xi=c(1,nres+i)
1438         yi=c(2,nres+i)
1439         zi=c(3,nres+i)
1440         dxi=dc_norm(1,nres+i)
1441         dyi=dc_norm(2,nres+i)
1442         dzi=dc_norm(3,nres+i)
1443 c        dsci_inv=dsc_inv(itypi)
1444         dsci_inv=vbld_inv(i+nres)
1445 C
1446 C Calculate SC interaction energy.
1447 C
1448         do iint=1,nint_gr(i)
1449           do j=istart(i,iint),iend(i,iint)
1450             ind=ind+1
1451             itypj=itype(j)
1452 c            dscj_inv=dsc_inv(itypj)
1453             dscj_inv=vbld_inv(j+nres)
1454             chi1=chi(itypi,itypj)
1455             chi2=chi(itypj,itypi)
1456             chi12=chi1*chi2
1457             chip1=chip(itypi)
1458             chip2=chip(itypj)
1459             chip12=chip1*chip2
1460             alf1=alp(itypi)
1461             alf2=alp(itypj)
1462             alf12=0.5D0*(alf1+alf2)
1463 C For diagnostics only!!!
1464 c           chi1=0.0D0
1465 c           chi2=0.0D0
1466 c           chi12=0.0D0
1467 c           chip1=0.0D0
1468 c           chip2=0.0D0
1469 c           chip12=0.0D0
1470 c           alf1=0.0D0
1471 c           alf2=0.0D0
1472 c           alf12=0.0D0
1473             xj=c(1,nres+j)-xi
1474             yj=c(2,nres+j)-yi
1475             zj=c(3,nres+j)-zi
1476             dxj=dc_norm(1,nres+j)
1477             dyj=dc_norm(2,nres+j)
1478             dzj=dc_norm(3,nres+j)
1479             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1480 cd          if (icall.eq.0) then
1481 cd            rrsave(ind)=rrij
1482 cd          else
1483 cd            rrij=rrsave(ind)
1484 cd          endif
1485             rij=dsqrt(rrij)
1486 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1487             call sc_angular
1488 C Calculate whole angle-dependent part of epsilon and contributions
1489 C to its derivatives
1490             fac=(rrij*sigsq)**expon2
1491             e1=fac*fac*aa(itypi,itypj)
1492             e2=fac*bb(itypi,itypj)
1493             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1494             eps2der=evdwij*eps3rt
1495             eps3der=evdwij*eps2rt
1496             evdwij=evdwij*eps2rt*eps3rt
1497 #ifdef TSCSC
1498             if (bb(itypi,itypj).gt.0) then
1499                evdw_p=evdw_p+evdwij
1500             else
1501                evdw_m=evdw_m+evdwij
1502             endif
1503 #else
1504             evdw=evdw+evdwij
1505 #endif
1506             if (lprn) then
1507             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1508             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1509 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1510 cd     &        restyp(itypi),i,restyp(itypj),j,
1511 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1512 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1513 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1514 cd     &        evdwij
1515             endif
1516 C Calculate gradient components.
1517             e1=e1*eps1*eps2rt**2*eps3rt**2
1518             fac=-expon*(e1+evdwij)
1519             sigder=fac/sigsq
1520             fac=rrij*fac
1521 C Calculate radial part of the gradient
1522             gg(1)=xj*fac
1523             gg(2)=yj*fac
1524             gg(3)=zj*fac
1525 C Calculate the angular part of the gradient and sum add the contributions
1526 C to the appropriate components of the Cartesian gradient.
1527 #ifdef TSCSC
1528             if (bb(itypi,itypj).gt.0) then
1529                call sc_grad
1530             else
1531                call sc_grad_T
1532             endif
1533 #else
1534             call sc_grad
1535 #endif
1536           enddo      ! j
1537         enddo        ! iint
1538       enddo          ! i
1539 c     stop
1540       return
1541       end
1542 C-----------------------------------------------------------------------------
1543       subroutine egb(evdw,evdw_p,evdw_m)
1544 C
1545 C This subroutine calculates the interaction energy of nonbonded side chains
1546 C assuming the Gay-Berne potential of interaction.
1547 C
1548       implicit real*8 (a-h,o-z)
1549       include 'DIMENSIONS'
1550       include 'COMMON.GEO'
1551       include 'COMMON.VAR'
1552       include 'COMMON.LOCAL'
1553       include 'COMMON.CHAIN'
1554       include 'COMMON.DERIV'
1555       include 'COMMON.NAMES'
1556       include 'COMMON.INTERACT'
1557       include 'COMMON.IOUNITS'
1558       include 'COMMON.CALC'
1559       include 'COMMON.CONTROL'
1560       include 'COMMON.SBRIDGE'
1561       logical lprn
1562       evdw=0.0D0
1563 ccccc      energy_dec=.false.
1564 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1565       evdw=0.0D0
1566       evdw_p=0.0D0
1567       evdw_m=0.0D0
1568       lprn=.false.
1569 c     if (icall.eq.0) lprn=.false.
1570       ind=0
1571       do i=iatsc_s,iatsc_e
1572         itypi=itype(i)
1573         itypi1=itype(i+1)
1574         xi=c(1,nres+i)
1575         yi=c(2,nres+i)
1576         zi=c(3,nres+i)
1577         dxi=dc_norm(1,nres+i)
1578         dyi=dc_norm(2,nres+i)
1579         dzi=dc_norm(3,nres+i)
1580 c        dsci_inv=dsc_inv(itypi)
1581         dsci_inv=vbld_inv(i+nres)
1582 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1583 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1584 C
1585 C Calculate SC interaction energy.
1586 C
1587         do iint=1,nint_gr(i)
1588           do j=istart(i,iint),iend(i,iint)
1589             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1590               call dyn_ssbond_ene(i,j,evdwij)
1591               evdw=evdw+evdwij
1592             ELSE
1593             ind=ind+1
1594             itypj=itype(j)
1595 c            dscj_inv=dsc_inv(itypj)
1596             dscj_inv=vbld_inv(j+nres)
1597 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1598 c     &       1.0d0/vbld(j+nres)
1599 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1600             sig0ij=sigma(itypi,itypj)
1601             chi1=chi(itypi,itypj)
1602             chi2=chi(itypj,itypi)
1603             chi12=chi1*chi2
1604             chip1=chip(itypi)
1605             chip2=chip(itypj)
1606             chip12=chip1*chip2
1607             alf1=alp(itypi)
1608             alf2=alp(itypj)
1609             alf12=0.5D0*(alf1+alf2)
1610 C For diagnostics only!!!
1611 c           chi1=0.0D0
1612 c           chi2=0.0D0
1613 c           chi12=0.0D0
1614 c           chip1=0.0D0
1615 c           chip2=0.0D0
1616 c           chip12=0.0D0
1617 c           alf1=0.0D0
1618 c           alf2=0.0D0
1619 c           alf12=0.0D0
1620             xj=c(1,nres+j)-xi
1621             yj=c(2,nres+j)-yi
1622             zj=c(3,nres+j)-zi
1623             dxj=dc_norm(1,nres+j)
1624             dyj=dc_norm(2,nres+j)
1625             dzj=dc_norm(3,nres+j)
1626 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1627 c            write (iout,*) "j",j," dc_norm",
1628 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1629             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1630             rij=dsqrt(rrij)
1631 C Calculate angle-dependent terms of energy and contributions to their
1632 C derivatives.
1633             call sc_angular
1634             sigsq=1.0D0/sigsq
1635             sig=sig0ij*dsqrt(sigsq)
1636             rij_shift=1.0D0/rij-sig+sig0ij
1637 c for diagnostics; uncomment
1638 c            rij_shift=1.2*sig0ij
1639 C I hate to put IF's in the loops, but here don't have another choice!!!!
1640             if (rij_shift.le.0.0D0) then
1641               evdw=1.0D20
1642 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1643 cd     &        restyp(itypi),i,restyp(itypj),j,
1644 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1645               return
1646             endif
1647             sigder=-sig*sigsq
1648 c---------------------------------------------------------------
1649             rij_shift=1.0D0/rij_shift
1650             fac=rij_shift**expon
1651             e1=fac*fac*aa(itypi,itypj)
1652             e2=fac*bb(itypi,itypj)
1653             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1654             eps2der=evdwij*eps3rt
1655             eps3der=evdwij*eps2rt
1656 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1657 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1658             evdwij=evdwij*eps2rt*eps3rt
1659 #ifdef TSCSC
1660             if (bb(itypi,itypj).gt.0) then
1661                evdw_p=evdw_p+evdwij
1662             else
1663                evdw_m=evdw_m+evdwij
1664             endif
1665 #else
1666             evdw=evdw+evdwij
1667 #endif
1668             if (lprn) then
1669             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1670             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1671             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1672      &        restyp(itypi),i,restyp(itypj),j,
1673      &        epsi,sigm,chi1,chi2,chip1,chip2,
1674      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1675      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1676      &        evdwij
1677             endif
1678
1679             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1680      &                        'evdw',i,j,evdwij
1681
1682 C Calculate gradient components.
1683             e1=e1*eps1*eps2rt**2*eps3rt**2
1684             fac=-expon*(e1+evdwij)*rij_shift
1685             sigder=fac*sigder
1686             fac=rij*fac
1687 c            fac=0.0d0
1688 C Calculate the radial part of the gradient
1689             gg(1)=xj*fac
1690             gg(2)=yj*fac
1691             gg(3)=zj*fac
1692 C Calculate angular part of the gradient.
1693 #ifdef TSCSC
1694             if (bb(itypi,itypj).gt.0) then
1695                call sc_grad
1696             else
1697                call sc_grad_T
1698             endif
1699 #else
1700             call sc_grad
1701 #endif
1702             ENDIF    ! dyn_ss
1703           enddo      ! j
1704         enddo        ! iint
1705       enddo          ! i
1706 c      write (iout,*) "Number of loop steps in EGB:",ind
1707 cccc      energy_dec=.false.
1708       return
1709       end
1710 C-----------------------------------------------------------------------------
1711       subroutine egbv(evdw,evdw_p,evdw_m)
1712 C
1713 C This subroutine calculates the interaction energy of nonbonded side chains
1714 C assuming the Gay-Berne-Vorobjev potential of interaction.
1715 C
1716       implicit real*8 (a-h,o-z)
1717       include 'DIMENSIONS'
1718       include 'COMMON.GEO'
1719       include 'COMMON.VAR'
1720       include 'COMMON.LOCAL'
1721       include 'COMMON.CHAIN'
1722       include 'COMMON.DERIV'
1723       include 'COMMON.NAMES'
1724       include 'COMMON.INTERACT'
1725       include 'COMMON.IOUNITS'
1726       include 'COMMON.CALC'
1727       common /srutu/ icall
1728       logical lprn
1729       evdw=0.0D0
1730 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1731       evdw=0.0D0
1732       lprn=.false.
1733 c     if (icall.eq.0) lprn=.true.
1734       ind=0
1735       do i=iatsc_s,iatsc_e
1736         itypi=itype(i)
1737         itypi1=itype(i+1)
1738         xi=c(1,nres+i)
1739         yi=c(2,nres+i)
1740         zi=c(3,nres+i)
1741         dxi=dc_norm(1,nres+i)
1742         dyi=dc_norm(2,nres+i)
1743         dzi=dc_norm(3,nres+i)
1744 c        dsci_inv=dsc_inv(itypi)
1745         dsci_inv=vbld_inv(i+nres)
1746 C
1747 C Calculate SC interaction energy.
1748 C
1749         do iint=1,nint_gr(i)
1750           do j=istart(i,iint),iend(i,iint)
1751             ind=ind+1
1752             itypj=itype(j)
1753 c            dscj_inv=dsc_inv(itypj)
1754             dscj_inv=vbld_inv(j+nres)
1755             sig0ij=sigma(itypi,itypj)
1756             r0ij=r0(itypi,itypj)
1757             chi1=chi(itypi,itypj)
1758             chi2=chi(itypj,itypi)
1759             chi12=chi1*chi2
1760             chip1=chip(itypi)
1761             chip2=chip(itypj)
1762             chip12=chip1*chip2
1763             alf1=alp(itypi)
1764             alf2=alp(itypj)
1765             alf12=0.5D0*(alf1+alf2)
1766 C For diagnostics only!!!
1767 c           chi1=0.0D0
1768 c           chi2=0.0D0
1769 c           chi12=0.0D0
1770 c           chip1=0.0D0
1771 c           chip2=0.0D0
1772 c           chip12=0.0D0
1773 c           alf1=0.0D0
1774 c           alf2=0.0D0
1775 c           alf12=0.0D0
1776             xj=c(1,nres+j)-xi
1777             yj=c(2,nres+j)-yi
1778             zj=c(3,nres+j)-zi
1779             dxj=dc_norm(1,nres+j)
1780             dyj=dc_norm(2,nres+j)
1781             dzj=dc_norm(3,nres+j)
1782             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1783             rij=dsqrt(rrij)
1784 C Calculate angle-dependent terms of energy and contributions to their
1785 C derivatives.
1786             call sc_angular
1787             sigsq=1.0D0/sigsq
1788             sig=sig0ij*dsqrt(sigsq)
1789             rij_shift=1.0D0/rij-sig+r0ij
1790 C I hate to put IF's in the loops, but here don't have another choice!!!!
1791             if (rij_shift.le.0.0D0) then
1792               evdw=1.0D20
1793               return
1794             endif
1795             sigder=-sig*sigsq
1796 c---------------------------------------------------------------
1797             rij_shift=1.0D0/rij_shift
1798             fac=rij_shift**expon
1799             e1=fac*fac*aa(itypi,itypj)
1800             e2=fac*bb(itypi,itypj)
1801             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1802             eps2der=evdwij*eps3rt
1803             eps3der=evdwij*eps2rt
1804             fac_augm=rrij**expon
1805             e_augm=augm(itypi,itypj)*fac_augm
1806             evdwij=evdwij*eps2rt*eps3rt
1807 #ifdef TSCSC
1808             if (bb(itypi,itypj).gt.0) then
1809                evdw_p=evdw_p+evdwij+e_augm
1810             else
1811                evdw_m=evdw_m+evdwij+e_augm
1812             endif
1813 #else
1814             evdw=evdw+evdwij+e_augm
1815 #endif
1816             if (lprn) then
1817             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1818             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1819             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1820      &        restyp(itypi),i,restyp(itypj),j,
1821      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1822      &        chi1,chi2,chip1,chip2,
1823      &        eps1,eps2rt**2,eps3rt**2,
1824      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1825      &        evdwij+e_augm
1826             endif
1827 C Calculate gradient components.
1828             e1=e1*eps1*eps2rt**2*eps3rt**2
1829             fac=-expon*(e1+evdwij)*rij_shift
1830             sigder=fac*sigder
1831             fac=rij*fac-2*expon*rrij*e_augm
1832 C Calculate the radial part of the gradient
1833             gg(1)=xj*fac
1834             gg(2)=yj*fac
1835             gg(3)=zj*fac
1836 C Calculate angular part of the gradient.
1837 #ifdef TSCSC
1838             if (bb(itypi,itypj).gt.0) then
1839                call sc_grad
1840             else
1841                call sc_grad_T
1842             endif
1843 #else
1844             call sc_grad
1845 #endif
1846           enddo      ! j
1847         enddo        ! iint
1848       enddo          ! i
1849       end
1850 C-----------------------------------------------------------------------------
1851       subroutine sc_angular
1852 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1853 C om12. Called by ebp, egb, and egbv.
1854       implicit none
1855       include 'COMMON.CALC'
1856       include 'COMMON.IOUNITS'
1857       erij(1)=xj*rij
1858       erij(2)=yj*rij
1859       erij(3)=zj*rij
1860       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1861       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1862       om12=dxi*dxj+dyi*dyj+dzi*dzj
1863       chiom12=chi12*om12
1864 C Calculate eps1(om12) and its derivative in om12
1865       faceps1=1.0D0-om12*chiom12
1866       faceps1_inv=1.0D0/faceps1
1867       eps1=dsqrt(faceps1_inv)
1868 C Following variable is eps1*deps1/dom12
1869       eps1_om12=faceps1_inv*chiom12
1870 c diagnostics only
1871 c      faceps1_inv=om12
1872 c      eps1=om12
1873 c      eps1_om12=1.0d0
1874 c      write (iout,*) "om12",om12," eps1",eps1
1875 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1876 C and om12.
1877       om1om2=om1*om2
1878       chiom1=chi1*om1
1879       chiom2=chi2*om2
1880       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1881       sigsq=1.0D0-facsig*faceps1_inv
1882       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1883       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1884       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1885 c diagnostics only
1886 c      sigsq=1.0d0
1887 c      sigsq_om1=0.0d0
1888 c      sigsq_om2=0.0d0
1889 c      sigsq_om12=0.0d0
1890 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1891 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1892 c     &    " eps1",eps1
1893 C Calculate eps2 and its derivatives in om1, om2, and om12.
1894       chipom1=chip1*om1
1895       chipom2=chip2*om2
1896       chipom12=chip12*om12
1897       facp=1.0D0-om12*chipom12
1898       facp_inv=1.0D0/facp
1899       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1900 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1901 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1902 C Following variable is the square root of eps2
1903       eps2rt=1.0D0-facp1*facp_inv
1904 C Following three variables are the derivatives of the square root of eps
1905 C in om1, om2, and om12.
1906       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1907       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1908       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1909 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1910       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1911 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1912 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1913 c     &  " eps2rt_om12",eps2rt_om12
1914 C Calculate whole angle-dependent part of epsilon and contributions
1915 C to its derivatives
1916       return
1917       end
1918
1919 C----------------------------------------------------------------------------
1920       subroutine sc_grad_T
1921       implicit real*8 (a-h,o-z)
1922       include 'DIMENSIONS'
1923       include 'COMMON.CHAIN'
1924       include 'COMMON.DERIV'
1925       include 'COMMON.CALC'
1926       include 'COMMON.IOUNITS'
1927       double precision dcosom1(3),dcosom2(3)
1928       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1929       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1930       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1931      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1932 c diagnostics only
1933 c      eom1=0.0d0
1934 c      eom2=0.0d0
1935 c      eom12=evdwij*eps1_om12
1936 c end diagnostics
1937 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1938 c     &  " sigder",sigder
1939 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1940 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1941       do k=1,3
1942         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1943         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1944       enddo
1945       do k=1,3
1946         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1947       enddo
1948 c      write (iout,*) "gg",(gg(k),k=1,3)
1949       do k=1,3
1950         gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1951      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1952      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1953         gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1954      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1955      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1956 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1957 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1958 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1959 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1960       enddo
1961 C
1962 C Calculate the components of the gradient in DC and X
1963 C
1964 cgrad      do k=i,j-1
1965 cgrad        do l=1,3
1966 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1967 cgrad        enddo
1968 cgrad      enddo
1969       do l=1,3
1970         gvdwcT(l,i)=gvdwcT(l,i)-gg(l)
1971         gvdwcT(l,j)=gvdwcT(l,j)+gg(l)
1972       enddo
1973       return
1974       end
1975
1976 C----------------------------------------------------------------------------
1977       subroutine sc_grad
1978       implicit real*8 (a-h,o-z)
1979       include 'DIMENSIONS'
1980       include 'COMMON.CHAIN'
1981       include 'COMMON.DERIV'
1982       include 'COMMON.CALC'
1983       include 'COMMON.IOUNITS'
1984       double precision dcosom1(3),dcosom2(3)
1985       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1986       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1987       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1988      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1989 c diagnostics only
1990 c      eom1=0.0d0
1991 c      eom2=0.0d0
1992 c      eom12=evdwij*eps1_om12
1993 c end diagnostics
1994 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1995 c     &  " sigder",sigder
1996 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1997 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1998       do k=1,3
1999         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2000         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2001       enddo
2002       do k=1,3
2003         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
2004       enddo
2005 c      write (iout,*) "gg",(gg(k),k=1,3)
2006       do k=1,3
2007         gvdwx(k,i)=gvdwx(k,i)-gg(k)
2008      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2009      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2010         gvdwx(k,j)=gvdwx(k,j)+gg(k)
2011      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2012      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2013 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2014 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2015 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2016 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2017       enddo
2018 C
2019 C Calculate the components of the gradient in DC and X
2020 C
2021 cgrad      do k=i,j-1
2022 cgrad        do l=1,3
2023 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2024 cgrad        enddo
2025 cgrad      enddo
2026       do l=1,3
2027         gvdwc(l,i)=gvdwc(l,i)-gg(l)
2028         gvdwc(l,j)=gvdwc(l,j)+gg(l)
2029       enddo
2030       return
2031       end
2032 C-----------------------------------------------------------------------
2033       subroutine e_softsphere(evdw)
2034 C
2035 C This subroutine calculates the interaction energy of nonbonded side chains
2036 C assuming the LJ potential of interaction.
2037 C
2038       implicit real*8 (a-h,o-z)
2039       include 'DIMENSIONS'
2040       parameter (accur=1.0d-10)
2041       include 'COMMON.GEO'
2042       include 'COMMON.VAR'
2043       include 'COMMON.LOCAL'
2044       include 'COMMON.CHAIN'
2045       include 'COMMON.DERIV'
2046       include 'COMMON.INTERACT'
2047       include 'COMMON.TORSION'
2048       include 'COMMON.SBRIDGE'
2049       include 'COMMON.NAMES'
2050       include 'COMMON.IOUNITS'
2051       include 'COMMON.CONTACTS'
2052       dimension gg(3)
2053 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2054       evdw=0.0D0
2055       do i=iatsc_s,iatsc_e
2056         itypi=itype(i)
2057         itypi1=itype(i+1)
2058         xi=c(1,nres+i)
2059         yi=c(2,nres+i)
2060         zi=c(3,nres+i)
2061 C
2062 C Calculate SC interaction energy.
2063 C
2064         do iint=1,nint_gr(i)
2065 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2066 cd   &                  'iend=',iend(i,iint)
2067           do j=istart(i,iint),iend(i,iint)
2068             itypj=itype(j)
2069             xj=c(1,nres+j)-xi
2070             yj=c(2,nres+j)-yi
2071             zj=c(3,nres+j)-zi
2072             rij=xj*xj+yj*yj+zj*zj
2073 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2074             r0ij=r0(itypi,itypj)
2075             r0ijsq=r0ij*r0ij
2076 c            print *,i,j,r0ij,dsqrt(rij)
2077             if (rij.lt.r0ijsq) then
2078               evdwij=0.25d0*(rij-r0ijsq)**2
2079               fac=rij-r0ijsq
2080             else
2081               evdwij=0.0d0
2082               fac=0.0d0
2083             endif
2084             evdw=evdw+evdwij
2085 C
2086 C Calculate the components of the gradient in DC and X
2087 C
2088             gg(1)=xj*fac
2089             gg(2)=yj*fac
2090             gg(3)=zj*fac
2091             do k=1,3
2092               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2093               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2094               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2095               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2096             enddo
2097 cgrad            do k=i,j-1
2098 cgrad              do l=1,3
2099 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2100 cgrad              enddo
2101 cgrad            enddo
2102           enddo ! j
2103         enddo ! iint
2104       enddo ! i
2105       return
2106       end
2107 C--------------------------------------------------------------------------
2108       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2109      &              eello_turn4)
2110 C
2111 C Soft-sphere potential of p-p interaction
2112 C
2113       implicit real*8 (a-h,o-z)
2114       include 'DIMENSIONS'
2115       include 'COMMON.CONTROL'
2116       include 'COMMON.IOUNITS'
2117       include 'COMMON.GEO'
2118       include 'COMMON.VAR'
2119       include 'COMMON.LOCAL'
2120       include 'COMMON.CHAIN'
2121       include 'COMMON.DERIV'
2122       include 'COMMON.INTERACT'
2123       include 'COMMON.CONTACTS'
2124       include 'COMMON.TORSION'
2125       include 'COMMON.VECTORS'
2126       include 'COMMON.FFIELD'
2127       dimension ggg(3)
2128 cd      write(iout,*) 'In EELEC_soft_sphere'
2129       ees=0.0D0
2130       evdw1=0.0D0
2131       eel_loc=0.0d0
2132       eello_turn3=0.0d0
2133       eello_turn4=0.0d0
2134       ind=0
2135       do i=iatel_s,iatel_e
2136         dxi=dc(1,i)
2137         dyi=dc(2,i)
2138         dzi=dc(3,i)
2139         xmedi=c(1,i)+0.5d0*dxi
2140         ymedi=c(2,i)+0.5d0*dyi
2141         zmedi=c(3,i)+0.5d0*dzi
2142         num_conti=0
2143 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2144         do j=ielstart(i),ielend(i)
2145           ind=ind+1
2146           iteli=itel(i)
2147           itelj=itel(j)
2148           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2149           r0ij=rpp(iteli,itelj)
2150           r0ijsq=r0ij*r0ij
2151           dxj=dc(1,j)
2152           dyj=dc(2,j)
2153           dzj=dc(3,j)
2154           xj=c(1,j)+0.5D0*dxj-xmedi
2155           yj=c(2,j)+0.5D0*dyj-ymedi
2156           zj=c(3,j)+0.5D0*dzj-zmedi
2157           rij=xj*xj+yj*yj+zj*zj
2158           if (rij.lt.r0ijsq) then
2159             evdw1ij=0.25d0*(rij-r0ijsq)**2
2160             fac=rij-r0ijsq
2161           else
2162             evdw1ij=0.0d0
2163             fac=0.0d0
2164           endif
2165           evdw1=evdw1+evdw1ij
2166 C
2167 C Calculate contributions to the Cartesian gradient.
2168 C
2169           ggg(1)=fac*xj
2170           ggg(2)=fac*yj
2171           ggg(3)=fac*zj
2172           do k=1,3
2173             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2174             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2175           enddo
2176 *
2177 * Loop over residues i+1 thru j-1.
2178 *
2179 cgrad          do k=i+1,j-1
2180 cgrad            do l=1,3
2181 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2182 cgrad            enddo
2183 cgrad          enddo
2184         enddo ! j
2185       enddo   ! i
2186 cgrad      do i=nnt,nct-1
2187 cgrad        do k=1,3
2188 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2189 cgrad        enddo
2190 cgrad        do j=i+1,nct-1
2191 cgrad          do k=1,3
2192 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2193 cgrad          enddo
2194 cgrad        enddo
2195 cgrad      enddo
2196       return
2197       end
2198 c------------------------------------------------------------------------------
2199       subroutine vec_and_deriv
2200       implicit real*8 (a-h,o-z)
2201       include 'DIMENSIONS'
2202 #ifdef MPI
2203       include 'mpif.h'
2204 #endif
2205       include 'COMMON.IOUNITS'
2206       include 'COMMON.GEO'
2207       include 'COMMON.VAR'
2208       include 'COMMON.LOCAL'
2209       include 'COMMON.CHAIN'
2210       include 'COMMON.VECTORS'
2211       include 'COMMON.SETUP'
2212       include 'COMMON.TIME1'
2213       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2214 C Compute the local reference systems. For reference system (i), the
2215 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2216 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2217 #ifdef PARVEC
2218       do i=ivec_start,ivec_end
2219 #else
2220       do i=1,nres-1
2221 #endif
2222           if (i.eq.nres-1) then
2223 C Case of the last full residue
2224 C Compute the Z-axis
2225             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2226             costh=dcos(pi-theta(nres))
2227             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2228             do k=1,3
2229               uz(k,i)=fac*uz(k,i)
2230             enddo
2231 C Compute the derivatives of uz
2232             uzder(1,1,1)= 0.0d0
2233             uzder(2,1,1)=-dc_norm(3,i-1)
2234             uzder(3,1,1)= dc_norm(2,i-1)
2235             uzder(1,2,1)= dc_norm(3,i-1)
2236             uzder(2,2,1)= 0.0d0
2237             uzder(3,2,1)=-dc_norm(1,i-1)
2238             uzder(1,3,1)=-dc_norm(2,i-1)
2239             uzder(2,3,1)= dc_norm(1,i-1)
2240             uzder(3,3,1)= 0.0d0
2241             uzder(1,1,2)= 0.0d0
2242             uzder(2,1,2)= dc_norm(3,i)
2243             uzder(3,1,2)=-dc_norm(2,i)
2244             uzder(1,2,2)=-dc_norm(3,i)
2245             uzder(2,2,2)= 0.0d0
2246             uzder(3,2,2)= dc_norm(1,i)
2247             uzder(1,3,2)= dc_norm(2,i)
2248             uzder(2,3,2)=-dc_norm(1,i)
2249             uzder(3,3,2)= 0.0d0
2250 C Compute the Y-axis
2251             facy=fac
2252             do k=1,3
2253               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2254             enddo
2255 C Compute the derivatives of uy
2256             do j=1,3
2257               do k=1,3
2258                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2259      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2260                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2261               enddo
2262               uyder(j,j,1)=uyder(j,j,1)-costh
2263               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2264             enddo
2265             do j=1,2
2266               do k=1,3
2267                 do l=1,3
2268                   uygrad(l,k,j,i)=uyder(l,k,j)
2269                   uzgrad(l,k,j,i)=uzder(l,k,j)
2270                 enddo
2271               enddo
2272             enddo
2273             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2274             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2275             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2276             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2277           else
2278 C Other residues
2279 C Compute the Z-axis
2280             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2281             costh=dcos(pi-theta(i+2))
2282             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2283             do k=1,3
2284               uz(k,i)=fac*uz(k,i)
2285             enddo
2286 C Compute the derivatives of uz
2287             uzder(1,1,1)= 0.0d0
2288             uzder(2,1,1)=-dc_norm(3,i+1)
2289             uzder(3,1,1)= dc_norm(2,i+1)
2290             uzder(1,2,1)= dc_norm(3,i+1)
2291             uzder(2,2,1)= 0.0d0
2292             uzder(3,2,1)=-dc_norm(1,i+1)
2293             uzder(1,3,1)=-dc_norm(2,i+1)
2294             uzder(2,3,1)= dc_norm(1,i+1)
2295             uzder(3,3,1)= 0.0d0
2296             uzder(1,1,2)= 0.0d0
2297             uzder(2,1,2)= dc_norm(3,i)
2298             uzder(3,1,2)=-dc_norm(2,i)
2299             uzder(1,2,2)=-dc_norm(3,i)
2300             uzder(2,2,2)= 0.0d0
2301             uzder(3,2,2)= dc_norm(1,i)
2302             uzder(1,3,2)= dc_norm(2,i)
2303             uzder(2,3,2)=-dc_norm(1,i)
2304             uzder(3,3,2)= 0.0d0
2305 C Compute the Y-axis
2306             facy=fac
2307             do k=1,3
2308               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2309             enddo
2310 C Compute the derivatives of uy
2311             do j=1,3
2312               do k=1,3
2313                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2314      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2315                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2316               enddo
2317               uyder(j,j,1)=uyder(j,j,1)-costh
2318               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2319             enddo
2320             do j=1,2
2321               do k=1,3
2322                 do l=1,3
2323                   uygrad(l,k,j,i)=uyder(l,k,j)
2324                   uzgrad(l,k,j,i)=uzder(l,k,j)
2325                 enddo
2326               enddo
2327             enddo
2328             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2329             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2330             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2331             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2332           endif
2333       enddo
2334       do i=1,nres-1
2335         vbld_inv_temp(1)=vbld_inv(i+1)
2336         if (i.lt.nres-1) then
2337           vbld_inv_temp(2)=vbld_inv(i+2)
2338           else
2339           vbld_inv_temp(2)=vbld_inv(i)
2340           endif
2341         do j=1,2
2342           do k=1,3
2343             do l=1,3
2344               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2345               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2346             enddo
2347           enddo
2348         enddo
2349       enddo
2350 #if defined(PARVEC) && defined(MPI)
2351       if (nfgtasks1.gt.1) then
2352         time00=MPI_Wtime()
2353 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2354 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2355 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2356         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2357      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2358      &   FG_COMM1,IERR)
2359         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2360      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2361      &   FG_COMM1,IERR)
2362         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2363      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2364      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2365         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2366      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2367      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2368         time_gather=time_gather+MPI_Wtime()-time00
2369       endif
2370 c      if (fg_rank.eq.0) then
2371 c        write (iout,*) "Arrays UY and UZ"
2372 c        do i=1,nres-1
2373 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2374 c     &     (uz(k,i),k=1,3)
2375 c        enddo
2376 c      endif
2377 #endif
2378       return
2379       end
2380 C-----------------------------------------------------------------------------
2381       subroutine check_vecgrad
2382       implicit real*8 (a-h,o-z)
2383       include 'DIMENSIONS'
2384       include 'COMMON.IOUNITS'
2385       include 'COMMON.GEO'
2386       include 'COMMON.VAR'
2387       include 'COMMON.LOCAL'
2388       include 'COMMON.CHAIN'
2389       include 'COMMON.VECTORS'
2390       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2391       dimension uyt(3,maxres),uzt(3,maxres)
2392       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2393       double precision delta /1.0d-7/
2394       call vec_and_deriv
2395 cd      do i=1,nres
2396 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2397 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2398 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2399 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2400 cd     &     (dc_norm(if90,i),if90=1,3)
2401 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2402 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2403 cd          write(iout,'(a)')
2404 cd      enddo
2405       do i=1,nres
2406         do j=1,2
2407           do k=1,3
2408             do l=1,3
2409               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2410               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2411             enddo
2412           enddo
2413         enddo
2414       enddo
2415       call vec_and_deriv
2416       do i=1,nres
2417         do j=1,3
2418           uyt(j,i)=uy(j,i)
2419           uzt(j,i)=uz(j,i)
2420         enddo
2421       enddo
2422       do i=1,nres
2423 cd        write (iout,*) 'i=',i
2424         do k=1,3
2425           erij(k)=dc_norm(k,i)
2426         enddo
2427         do j=1,3
2428           do k=1,3
2429             dc_norm(k,i)=erij(k)
2430           enddo
2431           dc_norm(j,i)=dc_norm(j,i)+delta
2432 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2433 c          do k=1,3
2434 c            dc_norm(k,i)=dc_norm(k,i)/fac
2435 c          enddo
2436 c          write (iout,*) (dc_norm(k,i),k=1,3)
2437 c          write (iout,*) (erij(k),k=1,3)
2438           call vec_and_deriv
2439           do k=1,3
2440             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2441             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2442             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2443             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2444           enddo
2445 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2446 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2447 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2448         enddo
2449         do k=1,3
2450           dc_norm(k,i)=erij(k)
2451         enddo
2452 cd        do k=1,3
2453 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2454 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2455 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2456 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2457 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2458 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2459 cd          write (iout,'(a)')
2460 cd        enddo
2461       enddo
2462       return
2463       end
2464 C--------------------------------------------------------------------------
2465       subroutine set_matrices
2466       implicit real*8 (a-h,o-z)
2467       include 'DIMENSIONS'
2468 #ifdef MPI
2469       include "mpif.h"
2470       include "COMMON.SETUP"
2471       integer IERR
2472       integer status(MPI_STATUS_SIZE)
2473 #endif
2474       include 'COMMON.IOUNITS'
2475       include 'COMMON.GEO'
2476       include 'COMMON.VAR'
2477       include 'COMMON.LOCAL'
2478       include 'COMMON.CHAIN'
2479       include 'COMMON.DERIV'
2480       include 'COMMON.INTERACT'
2481       include 'COMMON.CONTACTS'
2482       include 'COMMON.TORSION'
2483       include 'COMMON.VECTORS'
2484       include 'COMMON.FFIELD'
2485       double precision auxvec(2),auxmat(2,2)
2486 C
2487 C Compute the virtual-bond-torsional-angle dependent quantities needed
2488 C to calculate the el-loc multibody terms of various order.
2489 C
2490 #ifdef PARMAT
2491       do i=ivec_start+2,ivec_end+2
2492 #else
2493       do i=3,nres+1
2494 #endif
2495         if (i .lt. nres+1) then
2496           sin1=dsin(phi(i))
2497           cos1=dcos(phi(i))
2498           sintab(i-2)=sin1
2499           costab(i-2)=cos1
2500           obrot(1,i-2)=cos1
2501           obrot(2,i-2)=sin1
2502           sin2=dsin(2*phi(i))
2503           cos2=dcos(2*phi(i))
2504           sintab2(i-2)=sin2
2505           costab2(i-2)=cos2
2506           obrot2(1,i-2)=cos2
2507           obrot2(2,i-2)=sin2
2508           Ug(1,1,i-2)=-cos1
2509           Ug(1,2,i-2)=-sin1
2510           Ug(2,1,i-2)=-sin1
2511           Ug(2,2,i-2)= cos1
2512           Ug2(1,1,i-2)=-cos2
2513           Ug2(1,2,i-2)=-sin2
2514           Ug2(2,1,i-2)=-sin2
2515           Ug2(2,2,i-2)= cos2
2516         else
2517           costab(i-2)=1.0d0
2518           sintab(i-2)=0.0d0
2519           obrot(1,i-2)=1.0d0
2520           obrot(2,i-2)=0.0d0
2521           obrot2(1,i-2)=0.0d0
2522           obrot2(2,i-2)=0.0d0
2523           Ug(1,1,i-2)=1.0d0
2524           Ug(1,2,i-2)=0.0d0
2525           Ug(2,1,i-2)=0.0d0
2526           Ug(2,2,i-2)=1.0d0
2527           Ug2(1,1,i-2)=0.0d0
2528           Ug2(1,2,i-2)=0.0d0
2529           Ug2(2,1,i-2)=0.0d0
2530           Ug2(2,2,i-2)=0.0d0
2531         endif
2532         if (i .gt. 3 .and. i .lt. nres+1) then
2533           obrot_der(1,i-2)=-sin1
2534           obrot_der(2,i-2)= cos1
2535           Ugder(1,1,i-2)= sin1
2536           Ugder(1,2,i-2)=-cos1
2537           Ugder(2,1,i-2)=-cos1
2538           Ugder(2,2,i-2)=-sin1
2539           dwacos2=cos2+cos2
2540           dwasin2=sin2+sin2
2541           obrot2_der(1,i-2)=-dwasin2
2542           obrot2_der(2,i-2)= dwacos2
2543           Ug2der(1,1,i-2)= dwasin2
2544           Ug2der(1,2,i-2)=-dwacos2
2545           Ug2der(2,1,i-2)=-dwacos2
2546           Ug2der(2,2,i-2)=-dwasin2
2547         else
2548           obrot_der(1,i-2)=0.0d0
2549           obrot_der(2,i-2)=0.0d0
2550           Ugder(1,1,i-2)=0.0d0
2551           Ugder(1,2,i-2)=0.0d0
2552           Ugder(2,1,i-2)=0.0d0
2553           Ugder(2,2,i-2)=0.0d0
2554           obrot2_der(1,i-2)=0.0d0
2555           obrot2_der(2,i-2)=0.0d0
2556           Ug2der(1,1,i-2)=0.0d0
2557           Ug2der(1,2,i-2)=0.0d0
2558           Ug2der(2,1,i-2)=0.0d0
2559           Ug2der(2,2,i-2)=0.0d0
2560         endif
2561 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2562         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2563           iti = itortyp(itype(i-2))
2564         else
2565           iti=ntortyp+1
2566         endif
2567 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2568         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2569           iti1 = itortyp(itype(i-1))
2570         else
2571           iti1=ntortyp+1
2572         endif
2573 cd        write (iout,*) '*******i',i,' iti1',iti
2574 cd        write (iout,*) 'b1',b1(:,iti)
2575 cd        write (iout,*) 'b2',b2(:,iti)
2576 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2577 c        if (i .gt. iatel_s+2) then
2578         if (i .gt. nnt+2) then
2579           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2580           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2581           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2582      &    then
2583           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2584           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2585           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2586           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2587           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2588           endif
2589         else
2590           do k=1,2
2591             Ub2(k,i-2)=0.0d0
2592             Ctobr(k,i-2)=0.0d0
2593             Dtobr2(k,i-2)=0.0d0
2594             do l=1,2
2595               EUg(l,k,i-2)=0.0d0
2596               CUg(l,k,i-2)=0.0d0
2597               DUg(l,k,i-2)=0.0d0
2598               DtUg2(l,k,i-2)=0.0d0
2599             enddo
2600           enddo
2601         endif
2602         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2603         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2604         do k=1,2
2605           muder(k,i-2)=Ub2der(k,i-2)
2606         enddo
2607 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2608         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2609           iti1 = itortyp(itype(i-1))
2610         else
2611           iti1=ntortyp+1
2612         endif
2613         do k=1,2
2614           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2615         enddo
2616 cd        write (iout,*) 'mu ',mu(:,i-2)
2617 cd        write (iout,*) 'mu1',mu1(:,i-2)
2618 cd        write (iout,*) 'mu2',mu2(:,i-2)
2619         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2620      &  then
2621         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2622         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2623         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2624         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2625         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2626 C Vectors and matrices dependent on a single virtual-bond dihedral.
2627         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2628         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2629         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2630         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2631         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2632         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2633         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2634         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2635         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2636         endif
2637       enddo
2638 C Matrices dependent on two consecutive virtual-bond dihedrals.
2639 C The order of matrices is from left to right.
2640       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2641      &then
2642 c      do i=max0(ivec_start,2),ivec_end
2643       do i=2,nres-1
2644         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2645         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2646         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2647         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2648         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2649         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2650         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2651         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2652       enddo
2653       endif
2654 #if defined(MPI) && defined(PARMAT)
2655 #ifdef DEBUG
2656 c      if (fg_rank.eq.0) then
2657         write (iout,*) "Arrays UG and UGDER before GATHER"
2658         do i=1,nres-1
2659           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2660      &     ((ug(l,k,i),l=1,2),k=1,2),
2661      &     ((ugder(l,k,i),l=1,2),k=1,2)
2662         enddo
2663         write (iout,*) "Arrays UG2 and UG2DER"
2664         do i=1,nres-1
2665           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2666      &     ((ug2(l,k,i),l=1,2),k=1,2),
2667      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2668         enddo
2669         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2670         do i=1,nres-1
2671           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2672      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2673      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2674         enddo
2675         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2676         do i=1,nres-1
2677           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2678      &     costab(i),sintab(i),costab2(i),sintab2(i)
2679         enddo
2680         write (iout,*) "Array MUDER"
2681         do i=1,nres-1
2682           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2683         enddo
2684 c      endif
2685 #endif
2686       if (nfgtasks.gt.1) then
2687         time00=MPI_Wtime()
2688 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2689 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2690 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2691 #ifdef MATGATHER
2692         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2693      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2694      &   FG_COMM1,IERR)
2695         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2696      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2697      &   FG_COMM1,IERR)
2698         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2699      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2700      &   FG_COMM1,IERR)
2701         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2702      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2703      &   FG_COMM1,IERR)
2704         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2705      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2706      &   FG_COMM1,IERR)
2707         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2708      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2709      &   FG_COMM1,IERR)
2710         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2711      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2712      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2713         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2714      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2715      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2716         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2717      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2718      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2719         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2720      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2721      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2722         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2723      &  then
2724         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2725      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2726      &   FG_COMM1,IERR)
2727         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2728      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2729      &   FG_COMM1,IERR)
2730         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2731      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2732      &   FG_COMM1,IERR)
2733        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2734      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2735      &   FG_COMM1,IERR)
2736         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2737      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2738      &   FG_COMM1,IERR)
2739         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2740      &   ivec_count(fg_rank1),
2741      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2742      &   FG_COMM1,IERR)
2743         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2744      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2745      &   FG_COMM1,IERR)
2746         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2747      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2748      &   FG_COMM1,IERR)
2749         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2750      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2751      &   FG_COMM1,IERR)
2752         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2753      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2754      &   FG_COMM1,IERR)
2755         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2756      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2757      &   FG_COMM1,IERR)
2758         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2759      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2760      &   FG_COMM1,IERR)
2761         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2762      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2763      &   FG_COMM1,IERR)
2764         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2765      &   ivec_count(fg_rank1),
2766      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2767      &   FG_COMM1,IERR)
2768         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2769      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2770      &   FG_COMM1,IERR)
2771        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2772      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2773      &   FG_COMM1,IERR)
2774         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2775      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2776      &   FG_COMM1,IERR)
2777        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2778      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2779      &   FG_COMM1,IERR)
2780         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2781      &   ivec_count(fg_rank1),
2782      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2783      &   FG_COMM1,IERR)
2784         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2785      &   ivec_count(fg_rank1),
2786      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2787      &   FG_COMM1,IERR)
2788         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2789      &   ivec_count(fg_rank1),
2790      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2791      &   MPI_MAT2,FG_COMM1,IERR)
2792         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2793      &   ivec_count(fg_rank1),
2794      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2795      &   MPI_MAT2,FG_COMM1,IERR)
2796         endif
2797 #else
2798 c Passes matrix info through the ring
2799       isend=fg_rank1
2800       irecv=fg_rank1-1
2801       if (irecv.lt.0) irecv=nfgtasks1-1
2802       iprev=irecv
2803       inext=fg_rank1+1
2804       if (inext.ge.nfgtasks1) inext=0
2805       do i=1,nfgtasks1-1
2806 c        write (iout,*) "isend",isend," irecv",irecv
2807 c        call flush(iout)
2808         lensend=lentyp(isend)
2809         lenrecv=lentyp(irecv)
2810 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2811 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2812 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2813 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2814 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2815 c        write (iout,*) "Gather ROTAT1"
2816 c        call flush(iout)
2817 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2818 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2819 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2820 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2821 c        write (iout,*) "Gather ROTAT2"
2822 c        call flush(iout)
2823         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2824      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2825      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2826      &   iprev,4400+irecv,FG_COMM,status,IERR)
2827 c        write (iout,*) "Gather ROTAT_OLD"
2828 c        call flush(iout)
2829         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2830      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2831      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2832      &   iprev,5500+irecv,FG_COMM,status,IERR)
2833 c        write (iout,*) "Gather PRECOMP11"
2834 c        call flush(iout)
2835         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2836      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2837      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2838      &   iprev,6600+irecv,FG_COMM,status,IERR)
2839 c        write (iout,*) "Gather PRECOMP12"
2840 c        call flush(iout)
2841         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2842      &  then
2843         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2844      &   MPI_ROTAT2(lensend),inext,7700+isend,
2845      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2846      &   iprev,7700+irecv,FG_COMM,status,IERR)
2847 c        write (iout,*) "Gather PRECOMP21"
2848 c        call flush(iout)
2849         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2850      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2851      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2852      &   iprev,8800+irecv,FG_COMM,status,IERR)
2853 c        write (iout,*) "Gather PRECOMP22"
2854 c        call flush(iout)
2855         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2856      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2857      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2858      &   MPI_PRECOMP23(lenrecv),
2859      &   iprev,9900+irecv,FG_COMM,status,IERR)
2860 c        write (iout,*) "Gather PRECOMP23"
2861 c        call flush(iout)
2862         endif
2863         isend=irecv
2864         irecv=irecv-1
2865         if (irecv.lt.0) irecv=nfgtasks1-1
2866       enddo
2867 #endif
2868         time_gather=time_gather+MPI_Wtime()-time00
2869       endif
2870 #ifdef DEBUG
2871 c      if (fg_rank.eq.0) then
2872         write (iout,*) "Arrays UG and UGDER"
2873         do i=1,nres-1
2874           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2875      &     ((ug(l,k,i),l=1,2),k=1,2),
2876      &     ((ugder(l,k,i),l=1,2),k=1,2)
2877         enddo
2878         write (iout,*) "Arrays UG2 and UG2DER"
2879         do i=1,nres-1
2880           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2881      &     ((ug2(l,k,i),l=1,2),k=1,2),
2882      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2883         enddo
2884         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2885         do i=1,nres-1
2886           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2887      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2888      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2889         enddo
2890         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2891         do i=1,nres-1
2892           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2893      &     costab(i),sintab(i),costab2(i),sintab2(i)
2894         enddo
2895         write (iout,*) "Array MUDER"
2896         do i=1,nres-1
2897           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2898         enddo
2899 c      endif
2900 #endif
2901 #endif
2902 cd      do i=1,nres
2903 cd        iti = itortyp(itype(i))
2904 cd        write (iout,*) i
2905 cd        do j=1,2
2906 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2907 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2908 cd        enddo
2909 cd      enddo
2910       return
2911       end
2912 C--------------------------------------------------------------------------
2913       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2914 C
2915 C This subroutine calculates the average interaction energy and its gradient
2916 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2917 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2918 C The potential depends both on the distance of peptide-group centers and on
2919 C the orientation of the CA-CA virtual bonds.
2920 C
2921       implicit real*8 (a-h,o-z)
2922 #ifdef MPI
2923       include 'mpif.h'
2924 #endif
2925       include 'DIMENSIONS'
2926       include 'COMMON.CONTROL'
2927       include 'COMMON.SETUP'
2928       include 'COMMON.IOUNITS'
2929       include 'COMMON.GEO'
2930       include 'COMMON.VAR'
2931       include 'COMMON.LOCAL'
2932       include 'COMMON.CHAIN'
2933       include 'COMMON.DERIV'
2934       include 'COMMON.INTERACT'
2935       include 'COMMON.CONTACTS'
2936       include 'COMMON.TORSION'
2937       include 'COMMON.VECTORS'
2938       include 'COMMON.FFIELD'
2939       include 'COMMON.TIME1'
2940       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2941      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2942       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2943      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2944       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2945      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2946      &    num_conti,j1,j2
2947 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2948 #ifdef MOMENT
2949       double precision scal_el /1.0d0/
2950 #else
2951       double precision scal_el /0.5d0/
2952 #endif
2953 C 12/13/98
2954 C 13-go grudnia roku pamietnego...
2955       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2956      &                   0.0d0,1.0d0,0.0d0,
2957      &                   0.0d0,0.0d0,1.0d0/
2958 cd      write(iout,*) 'In EELEC'
2959 cd      do i=1,nloctyp
2960 cd        write(iout,*) 'Type',i
2961 cd        write(iout,*) 'B1',B1(:,i)
2962 cd        write(iout,*) 'B2',B2(:,i)
2963 cd        write(iout,*) 'CC',CC(:,:,i)
2964 cd        write(iout,*) 'DD',DD(:,:,i)
2965 cd        write(iout,*) 'EE',EE(:,:,i)
2966 cd      enddo
2967 cd      call check_vecgrad
2968 cd      stop
2969       if (icheckgrad.eq.1) then
2970         do i=1,nres-1
2971           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2972           do k=1,3
2973             dc_norm(k,i)=dc(k,i)*fac
2974           enddo
2975 c          write (iout,*) 'i',i,' fac',fac
2976         enddo
2977       endif
2978       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2979      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2980      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2981 c        call vec_and_deriv
2982 #ifdef TIMING
2983         time01=MPI_Wtime()
2984 #endif
2985         call set_matrices
2986 #ifdef TIMING
2987         time_mat=time_mat+MPI_Wtime()-time01
2988 #endif
2989       endif
2990 cd      do i=1,nres-1
2991 cd        write (iout,*) 'i=',i
2992 cd        do k=1,3
2993 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2994 cd        enddo
2995 cd        do k=1,3
2996 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2997 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2998 cd        enddo
2999 cd      enddo
3000       t_eelecij=0.0d0
3001       ees=0.0D0
3002       evdw1=0.0D0
3003       eel_loc=0.0d0
3004       eello_turn3=0.0d0
3005       eello_turn4=0.0d0
3006       ind=0
3007       do i=1,nres
3008         num_cont_hb(i)=0
3009       enddo
3010 cd      print '(a)','Enter EELEC'
3011 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3012       do i=1,nres
3013         gel_loc_loc(i)=0.0d0
3014         gcorr_loc(i)=0.0d0
3015       enddo
3016 c
3017 c
3018 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3019 C
3020 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3021 C
3022       do i=iturn3_start,iturn3_end
3023         dxi=dc(1,i)
3024         dyi=dc(2,i)
3025         dzi=dc(3,i)
3026         dx_normi=dc_norm(1,i)
3027         dy_normi=dc_norm(2,i)
3028         dz_normi=dc_norm(3,i)
3029         xmedi=c(1,i)+0.5d0*dxi
3030         ymedi=c(2,i)+0.5d0*dyi
3031         zmedi=c(3,i)+0.5d0*dzi
3032         num_conti=0
3033         call eelecij(i,i+2,ees,evdw1,eel_loc)
3034         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3035         num_cont_hb(i)=num_conti
3036       enddo
3037       do i=iturn4_start,iturn4_end
3038         dxi=dc(1,i)
3039         dyi=dc(2,i)
3040         dzi=dc(3,i)
3041         dx_normi=dc_norm(1,i)
3042         dy_normi=dc_norm(2,i)
3043         dz_normi=dc_norm(3,i)
3044         xmedi=c(1,i)+0.5d0*dxi
3045         ymedi=c(2,i)+0.5d0*dyi
3046         zmedi=c(3,i)+0.5d0*dzi
3047         num_conti=num_cont_hb(i)
3048         call eelecij(i,i+3,ees,evdw1,eel_loc)
3049         if (wturn4.gt.0.0d0) call eturn4(i,eello_turn4)
3050         num_cont_hb(i)=num_conti
3051       enddo   ! i
3052 c
3053 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3054 c
3055       do i=iatel_s,iatel_e
3056         dxi=dc(1,i)
3057         dyi=dc(2,i)
3058         dzi=dc(3,i)
3059         dx_normi=dc_norm(1,i)
3060         dy_normi=dc_norm(2,i)
3061         dz_normi=dc_norm(3,i)
3062         xmedi=c(1,i)+0.5d0*dxi
3063         ymedi=c(2,i)+0.5d0*dyi
3064         zmedi=c(3,i)+0.5d0*dzi
3065 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3066         num_conti=num_cont_hb(i)
3067         do j=ielstart(i),ielend(i)
3068           call eelecij(i,j,ees,evdw1,eel_loc)
3069         enddo ! j
3070         num_cont_hb(i)=num_conti
3071       enddo   ! i
3072 c      write (iout,*) "Number of loop steps in EELEC:",ind
3073 cd      do i=1,nres
3074 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3075 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3076 cd      enddo
3077 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3078 ccc      eel_loc=eel_loc+eello_turn3
3079 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3080       return
3081       end
3082 C-------------------------------------------------------------------------------
3083       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3084       implicit real*8 (a-h,o-z)
3085       include 'DIMENSIONS'
3086 #ifdef MPI
3087       include "mpif.h"
3088 #endif
3089       include 'COMMON.CONTROL'
3090       include 'COMMON.IOUNITS'
3091       include 'COMMON.GEO'
3092       include 'COMMON.VAR'
3093       include 'COMMON.LOCAL'
3094       include 'COMMON.CHAIN'
3095       include 'COMMON.DERIV'
3096       include 'COMMON.INTERACT'
3097       include 'COMMON.CONTACTS'
3098       include 'COMMON.TORSION'
3099       include 'COMMON.VECTORS'
3100       include 'COMMON.FFIELD'
3101       include 'COMMON.TIME1'
3102       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3103      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3104       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3105      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3106       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3107      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3108      &    num_conti,j1,j2
3109 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3110 #ifdef MOMENT
3111       double precision scal_el /1.0d0/
3112 #else
3113       double precision scal_el /0.5d0/
3114 #endif
3115 C 12/13/98
3116 C 13-go grudnia roku pamietnego...
3117       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3118      &                   0.0d0,1.0d0,0.0d0,
3119      &                   0.0d0,0.0d0,1.0d0/
3120 c          time00=MPI_Wtime()
3121 cd      write (iout,*) "eelecij",i,j
3122 c          ind=ind+1
3123           iteli=itel(i)
3124           itelj=itel(j)
3125           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3126           aaa=app(iteli,itelj)
3127           bbb=bpp(iteli,itelj)
3128           ael6i=ael6(iteli,itelj)
3129           ael3i=ael3(iteli,itelj)
3130           dxj=dc(1,j)
3131           dyj=dc(2,j)
3132           dzj=dc(3,j)
3133           dx_normj=dc_norm(1,j)
3134           dy_normj=dc_norm(2,j)
3135           dz_normj=dc_norm(3,j)
3136           xj=c(1,j)+0.5D0*dxj-xmedi
3137           yj=c(2,j)+0.5D0*dyj-ymedi
3138           zj=c(3,j)+0.5D0*dzj-zmedi
3139           rij=xj*xj+yj*yj+zj*zj
3140           rrmij=1.0D0/rij
3141           rij=dsqrt(rij)
3142           rmij=1.0D0/rij
3143           r3ij=rrmij*rmij
3144           r6ij=r3ij*r3ij
3145           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3146           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3147           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3148           fac=cosa-3.0D0*cosb*cosg
3149           ev1=aaa*r6ij*r6ij
3150 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3151           if (j.eq.i+2) ev1=scal_el*ev1
3152           ev2=bbb*r6ij
3153           fac3=ael6i*r6ij
3154           fac4=ael3i*r3ij
3155           evdwij=ev1+ev2
3156           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3157           el2=fac4*fac
3158           eesij=el1+el2
3159 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3160           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3161           ees=ees+eesij
3162           evdw1=evdw1+evdwij
3163 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3164 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3165 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3166 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3167
3168           if (energy_dec) then
3169               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3170               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3171           endif
3172
3173 C
3174 C Calculate contributions to the Cartesian gradient.
3175 C
3176 #ifdef SPLITELE
3177           facvdw=-6*rrmij*(ev1+evdwij)
3178           facel=-3*rrmij*(el1+eesij)
3179           fac1=fac
3180           erij(1)=xj*rmij
3181           erij(2)=yj*rmij
3182           erij(3)=zj*rmij
3183 *
3184 * Radial derivatives. First process both termini of the fragment (i,j)
3185 *
3186           ggg(1)=facel*xj
3187           ggg(2)=facel*yj
3188           ggg(3)=facel*zj
3189 c          do k=1,3
3190 c            ghalf=0.5D0*ggg(k)
3191 c            gelc(k,i)=gelc(k,i)+ghalf
3192 c            gelc(k,j)=gelc(k,j)+ghalf
3193 c          enddo
3194 c 9/28/08 AL Gradient compotents will be summed only at the end
3195           do k=1,3
3196             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3197             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3198           enddo
3199 *
3200 * Loop over residues i+1 thru j-1.
3201 *
3202 cgrad          do k=i+1,j-1
3203 cgrad            do l=1,3
3204 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3205 cgrad            enddo
3206 cgrad          enddo
3207           ggg(1)=facvdw*xj
3208           ggg(2)=facvdw*yj
3209           ggg(3)=facvdw*zj
3210 c          do k=1,3
3211 c            ghalf=0.5D0*ggg(k)
3212 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3213 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3214 c          enddo
3215 c 9/28/08 AL Gradient compotents will be summed only at the end
3216           do k=1,3
3217             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3218             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3219           enddo
3220 *
3221 * Loop over residues i+1 thru j-1.
3222 *
3223 cgrad          do k=i+1,j-1
3224 cgrad            do l=1,3
3225 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3226 cgrad            enddo
3227 cgrad          enddo
3228 #else
3229           facvdw=ev1+evdwij
3230           facel=el1+eesij
3231           fac1=fac
3232           fac=-3*rrmij*(facvdw+facvdw+facel)
3233           erij(1)=xj*rmij
3234           erij(2)=yj*rmij
3235           erij(3)=zj*rmij
3236 *
3237 * Radial derivatives. First process both termini of the fragment (i,j)
3238 *
3239           ggg(1)=fac*xj
3240           ggg(2)=fac*yj
3241           ggg(3)=fac*zj
3242 c          do k=1,3
3243 c            ghalf=0.5D0*ggg(k)
3244 c            gelc(k,i)=gelc(k,i)+ghalf
3245 c            gelc(k,j)=gelc(k,j)+ghalf
3246 c          enddo
3247 c 9/28/08 AL Gradient compotents will be summed only at the end
3248           do k=1,3
3249             gelc_long(k,j)=gelc(k,j)+ggg(k)
3250             gelc_long(k,i)=gelc(k,i)-ggg(k)
3251           enddo
3252 *
3253 * Loop over residues i+1 thru j-1.
3254 *
3255 cgrad          do k=i+1,j-1
3256 cgrad            do l=1,3
3257 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3258 cgrad            enddo
3259 cgrad          enddo
3260 c 9/28/08 AL Gradient compotents will be summed only at the end
3261           ggg(1)=facvdw*xj
3262           ggg(2)=facvdw*yj
3263           ggg(3)=facvdw*zj
3264           do k=1,3
3265             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3266             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3267           enddo
3268 #endif
3269 *
3270 * Angular part
3271 *
3272           ecosa=2.0D0*fac3*fac1+fac4
3273           fac4=-3.0D0*fac4
3274           fac3=-6.0D0*fac3
3275           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3276           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3277           do k=1,3
3278             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3279             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3280           enddo
3281 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3282 cd   &          (dcosg(k),k=1,3)
3283           do k=1,3
3284             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3285           enddo
3286 c          do k=1,3
3287 c            ghalf=0.5D0*ggg(k)
3288 c            gelc(k,i)=gelc(k,i)+ghalf
3289 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3290 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3291 c            gelc(k,j)=gelc(k,j)+ghalf
3292 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3293 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3294 c          enddo
3295 cgrad          do k=i+1,j-1
3296 cgrad            do l=1,3
3297 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3298 cgrad            enddo
3299 cgrad          enddo
3300           do k=1,3
3301             gelc(k,i)=gelc(k,i)
3302      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3303      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3304             gelc(k,j)=gelc(k,j)
3305      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3306      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3307             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3308             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3309           enddo
3310           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3311      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3312      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3313 C
3314 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3315 C   energy of a peptide unit is assumed in the form of a second-order
3316 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3317 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3318 C   are computed for EVERY pair of non-contiguous peptide groups.
3319 C
3320           if (j.lt.nres-1) then
3321             j1=j+1
3322             j2=j-1
3323           else
3324             j1=j-1
3325             j2=j-2
3326           endif
3327           kkk=0
3328           do k=1,2
3329             do l=1,2
3330               kkk=kkk+1
3331               muij(kkk)=mu(k,i)*mu(l,j)
3332             enddo
3333           enddo
3334 cd         write (iout,*) 'EELEC: i',i,' j',j
3335 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3336 cd          write(iout,*) 'muij',muij
3337           ury=scalar(uy(1,i),erij)
3338           urz=scalar(uz(1,i),erij)
3339           vry=scalar(uy(1,j),erij)
3340           vrz=scalar(uz(1,j),erij)
3341           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3342           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3343           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3344           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3345           fac=dsqrt(-ael6i)*r3ij
3346           a22=a22*fac
3347           a23=a23*fac
3348           a32=a32*fac
3349           a33=a33*fac
3350 cd          write (iout,'(4i5,4f10.5)')
3351 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3352 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3353 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3354 cd     &      uy(:,j),uz(:,j)
3355 cd          write (iout,'(4f10.5)')
3356 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3357 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3358 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3359 cd           write (iout,'(9f10.5/)')
3360 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3361 C Derivatives of the elements of A in virtual-bond vectors
3362           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3363           do k=1,3
3364             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3365             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3366             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3367             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3368             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3369             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3370             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3371             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3372             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3373             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3374             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3375             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3376           enddo
3377 C Compute radial contributions to the gradient
3378           facr=-3.0d0*rrmij
3379           a22der=a22*facr
3380           a23der=a23*facr
3381           a32der=a32*facr
3382           a33der=a33*facr
3383           agg(1,1)=a22der*xj
3384           agg(2,1)=a22der*yj
3385           agg(3,1)=a22der*zj
3386           agg(1,2)=a23der*xj
3387           agg(2,2)=a23der*yj
3388           agg(3,2)=a23der*zj
3389           agg(1,3)=a32der*xj
3390           agg(2,3)=a32der*yj
3391           agg(3,3)=a32der*zj
3392           agg(1,4)=a33der*xj
3393           agg(2,4)=a33der*yj
3394           agg(3,4)=a33der*zj
3395 C Add the contributions coming from er
3396           fac3=-3.0d0*fac
3397           do k=1,3
3398             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3399             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3400             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3401             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3402           enddo
3403           do k=1,3
3404 C Derivatives in DC(i)
3405 cgrad            ghalf1=0.5d0*agg(k,1)
3406 cgrad            ghalf2=0.5d0*agg(k,2)
3407 cgrad            ghalf3=0.5d0*agg(k,3)
3408 cgrad            ghalf4=0.5d0*agg(k,4)
3409             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3410      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3411             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3412      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3413             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3414      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3415             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3416      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3417 C Derivatives in DC(i+1)
3418             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3419      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3420             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3421      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3422             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3423      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3424             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3425      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3426 C Derivatives in DC(j)
3427             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3428      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3429             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3430      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3431             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3432      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3433             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3434      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3435 C Derivatives in DC(j+1) or DC(nres-1)
3436             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3437      &      -3.0d0*vryg(k,3)*ury)
3438             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3439      &      -3.0d0*vrzg(k,3)*ury)
3440             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3441      &      -3.0d0*vryg(k,3)*urz)
3442             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3443      &      -3.0d0*vrzg(k,3)*urz)
3444 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3445 cgrad              do l=1,4
3446 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3447 cgrad              enddo
3448 cgrad            endif
3449           enddo
3450           acipa(1,1)=a22
3451           acipa(1,2)=a23
3452           acipa(2,1)=a32
3453           acipa(2,2)=a33
3454           a22=-a22
3455           a23=-a23
3456           do l=1,2
3457             do k=1,3
3458               agg(k,l)=-agg(k,l)
3459               aggi(k,l)=-aggi(k,l)
3460               aggi1(k,l)=-aggi1(k,l)
3461               aggj(k,l)=-aggj(k,l)
3462               aggj1(k,l)=-aggj1(k,l)
3463             enddo
3464           enddo
3465           if (j.lt.nres-1) then
3466             a22=-a22
3467             a32=-a32
3468             do l=1,3,2
3469               do k=1,3
3470                 agg(k,l)=-agg(k,l)
3471                 aggi(k,l)=-aggi(k,l)
3472                 aggi1(k,l)=-aggi1(k,l)
3473                 aggj(k,l)=-aggj(k,l)
3474                 aggj1(k,l)=-aggj1(k,l)
3475               enddo
3476             enddo
3477           else
3478             a22=-a22
3479             a23=-a23
3480             a32=-a32
3481             a33=-a33
3482             do l=1,4
3483               do k=1,3
3484                 agg(k,l)=-agg(k,l)
3485                 aggi(k,l)=-aggi(k,l)
3486                 aggi1(k,l)=-aggi1(k,l)
3487                 aggj(k,l)=-aggj(k,l)
3488                 aggj1(k,l)=-aggj1(k,l)
3489               enddo
3490             enddo
3491           endif
3492           ENDIF ! WCORR
3493           IF (wel_loc.gt.0.0d0) THEN
3494 C Contribution to the local-electrostatic energy coming from the i-j pair
3495           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3496      &     +a33*muij(4)
3497 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3498
3499           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3500      &            'eelloc',i,j,eel_loc_ij
3501
3502           eel_loc=eel_loc+eel_loc_ij
3503 C Partial derivatives in virtual-bond dihedral angles gamma
3504           if (i.gt.1)
3505      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3506      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3507      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3508           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3509      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3510      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3511 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3512           do l=1,3
3513             ggg(l)=agg(l,1)*muij(1)+
3514      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3515             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3516             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3517 cgrad            ghalf=0.5d0*ggg(l)
3518 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3519 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3520           enddo
3521 cgrad          do k=i+1,j2
3522 cgrad            do l=1,3
3523 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3524 cgrad            enddo
3525 cgrad          enddo
3526 C Remaining derivatives of eello
3527           do l=1,3
3528             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3529      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3530             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3531      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3532             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3533      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3534             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3535      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3536           enddo
3537           ENDIF
3538 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3539 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3540           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3541      &       .and. num_conti.le.maxconts) then
3542 c            write (iout,*) i,j," entered corr"
3543 C
3544 C Calculate the contact function. The ith column of the array JCONT will
3545 C contain the numbers of atoms that make contacts with the atom I (of numbers
3546 C greater than I). The arrays FACONT and GACONT will contain the values of
3547 C the contact function and its derivative.
3548 c           r0ij=1.02D0*rpp(iteli,itelj)
3549 c           r0ij=1.11D0*rpp(iteli,itelj)
3550             r0ij=2.20D0*rpp(iteli,itelj)
3551 c           r0ij=1.55D0*rpp(iteli,itelj)
3552             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3553             if (fcont.gt.0.0D0) then
3554               num_conti=num_conti+1
3555               if (num_conti.gt.maxconts) then
3556                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3557      &                         ' will skip next contacts for this conf.'
3558               else
3559                 jcont_hb(num_conti,i)=j
3560 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3561 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3562                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3563      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3564 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3565 C  terms.
3566                 d_cont(num_conti,i)=rij
3567 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3568 C     --- Electrostatic-interaction matrix ---
3569                 a_chuj(1,1,num_conti,i)=a22
3570                 a_chuj(1,2,num_conti,i)=a23
3571                 a_chuj(2,1,num_conti,i)=a32
3572                 a_chuj(2,2,num_conti,i)=a33
3573 C     --- Gradient of rij
3574                 do kkk=1,3
3575                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3576                 enddo
3577                 kkll=0
3578                 do k=1,2
3579                   do l=1,2
3580                     kkll=kkll+1
3581                     do m=1,3
3582                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3583                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3584                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3585                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3586                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3587                     enddo
3588                   enddo
3589                 enddo
3590                 ENDIF
3591                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3592 C Calculate contact energies
3593                 cosa4=4.0D0*cosa
3594                 wij=cosa-3.0D0*cosb*cosg
3595                 cosbg1=cosb+cosg
3596                 cosbg2=cosb-cosg
3597 c               fac3=dsqrt(-ael6i)/r0ij**3
3598                 fac3=dsqrt(-ael6i)*r3ij
3599 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3600                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3601                 if (ees0tmp.gt.0) then
3602                   ees0pij=dsqrt(ees0tmp)
3603                 else
3604                   ees0pij=0
3605                 endif
3606 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3607                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3608                 if (ees0tmp.gt.0) then
3609                   ees0mij=dsqrt(ees0tmp)
3610                 else
3611                   ees0mij=0
3612                 endif
3613 c               ees0mij=0.0D0
3614                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3615                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3616 C Diagnostics. Comment out or remove after debugging!
3617 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3618 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3619 c               ees0m(num_conti,i)=0.0D0
3620 C End diagnostics.
3621 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3622 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3623 C Angular derivatives of the contact function
3624                 ees0pij1=fac3/ees0pij
3625                 ees0mij1=fac3/ees0mij
3626                 fac3p=-3.0D0*fac3*rrmij
3627                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3628                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3629 c               ees0mij1=0.0D0
3630                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3631                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3632                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3633                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3634                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3635                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3636                 ecosap=ecosa1+ecosa2
3637                 ecosbp=ecosb1+ecosb2
3638                 ecosgp=ecosg1+ecosg2
3639                 ecosam=ecosa1-ecosa2
3640                 ecosbm=ecosb1-ecosb2
3641                 ecosgm=ecosg1-ecosg2
3642 C Diagnostics
3643 c               ecosap=ecosa1
3644 c               ecosbp=ecosb1
3645 c               ecosgp=ecosg1
3646 c               ecosam=0.0D0
3647 c               ecosbm=0.0D0
3648 c               ecosgm=0.0D0
3649 C End diagnostics
3650                 facont_hb(num_conti,i)=fcont
3651                 fprimcont=fprimcont/rij
3652 cd              facont_hb(num_conti,i)=1.0D0
3653 C Following line is for diagnostics.
3654 cd              fprimcont=0.0D0
3655                 do k=1,3
3656                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3657                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3658                 enddo
3659                 do k=1,3
3660                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3661                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3662                 enddo
3663                 gggp(1)=gggp(1)+ees0pijp*xj
3664                 gggp(2)=gggp(2)+ees0pijp*yj
3665                 gggp(3)=gggp(3)+ees0pijp*zj
3666                 gggm(1)=gggm(1)+ees0mijp*xj
3667                 gggm(2)=gggm(2)+ees0mijp*yj
3668                 gggm(3)=gggm(3)+ees0mijp*zj
3669 C Derivatives due to the contact function
3670                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3671                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3672                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3673                 do k=1,3
3674 c
3675 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3676 c          following the change of gradient-summation algorithm.
3677 c
3678 cgrad                  ghalfp=0.5D0*gggp(k)
3679 cgrad                  ghalfm=0.5D0*gggm(k)
3680                   gacontp_hb1(k,num_conti,i)=!ghalfp
3681      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3682      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3683                   gacontp_hb2(k,num_conti,i)=!ghalfp
3684      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3685      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3686                   gacontp_hb3(k,num_conti,i)=gggp(k)
3687                   gacontm_hb1(k,num_conti,i)=!ghalfm
3688      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3689      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3690                   gacontm_hb2(k,num_conti,i)=!ghalfm
3691      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3692      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3693                   gacontm_hb3(k,num_conti,i)=gggm(k)
3694                 enddo
3695 C Diagnostics. Comment out or remove after debugging!
3696 cdiag           do k=1,3
3697 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3698 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3699 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3700 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3701 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3702 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3703 cdiag           enddo
3704               ENDIF ! wcorr
3705               endif  ! num_conti.le.maxconts
3706             endif  ! fcont.gt.0
3707           endif    ! j.gt.i+1
3708           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3709             do k=1,4
3710               do l=1,3
3711                 ghalf=0.5d0*agg(l,k)
3712                 aggi(l,k)=aggi(l,k)+ghalf
3713                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3714                 aggj(l,k)=aggj(l,k)+ghalf
3715               enddo
3716             enddo
3717             if (j.eq.nres-1 .and. i.lt.j-2) then
3718               do k=1,4
3719                 do l=1,3
3720                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3721                 enddo
3722               enddo
3723             endif
3724           endif
3725 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3726       return
3727       end
3728 C-----------------------------------------------------------------------------
3729       subroutine eturn3(i,eello_turn3)
3730 C Third- and fourth-order contributions from turns
3731       implicit real*8 (a-h,o-z)
3732       include 'DIMENSIONS'
3733       include 'COMMON.IOUNITS'
3734       include 'COMMON.GEO'
3735       include 'COMMON.VAR'
3736       include 'COMMON.LOCAL'
3737       include 'COMMON.CHAIN'
3738       include 'COMMON.DERIV'
3739       include 'COMMON.INTERACT'
3740       include 'COMMON.CONTACTS'
3741       include 'COMMON.TORSION'
3742       include 'COMMON.VECTORS'
3743       include 'COMMON.FFIELD'
3744       include 'COMMON.CONTROL'
3745       dimension ggg(3)
3746       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3747      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3748      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3749       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3750      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3751       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3752      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3753      &    num_conti,j1,j2
3754       j=i+2
3755 c      write (iout,*) "eturn3",i,j,j1,j2
3756       a_temp(1,1)=a22
3757       a_temp(1,2)=a23
3758       a_temp(2,1)=a32
3759       a_temp(2,2)=a33
3760 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3761 C
3762 C               Third-order contributions
3763 C
3764 C                 (i+2)o----(i+3)
3765 C                      | |
3766 C                      | |
3767 C                 (i+1)o----i
3768 C
3769 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3770 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3771         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3772         call transpose2(auxmat(1,1),auxmat1(1,1))
3773         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3774         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3775         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3776      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3777 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3778 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3779 cd     &    ' eello_turn3_num',4*eello_turn3_num
3780 C Derivatives in gamma(i)
3781         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3782         call transpose2(auxmat2(1,1),auxmat3(1,1))
3783         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3784         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3785 C Derivatives in gamma(i+1)
3786         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3787         call transpose2(auxmat2(1,1),auxmat3(1,1))
3788         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3789         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3790      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3791 C Cartesian derivatives
3792         do l=1,3
3793 c            ghalf1=0.5d0*agg(l,1)
3794 c            ghalf2=0.5d0*agg(l,2)
3795 c            ghalf3=0.5d0*agg(l,3)
3796 c            ghalf4=0.5d0*agg(l,4)
3797           a_temp(1,1)=aggi(l,1)!+ghalf1
3798           a_temp(1,2)=aggi(l,2)!+ghalf2
3799           a_temp(2,1)=aggi(l,3)!+ghalf3
3800           a_temp(2,2)=aggi(l,4)!+ghalf4
3801           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3802           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3803      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3804           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3805           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3806           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3807           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3808           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3809           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3810      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3811           a_temp(1,1)=aggj(l,1)!+ghalf1
3812           a_temp(1,2)=aggj(l,2)!+ghalf2
3813           a_temp(2,1)=aggj(l,3)!+ghalf3
3814           a_temp(2,2)=aggj(l,4)!+ghalf4
3815           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3816           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3817      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3818           a_temp(1,1)=aggj1(l,1)
3819           a_temp(1,2)=aggj1(l,2)
3820           a_temp(2,1)=aggj1(l,3)
3821           a_temp(2,2)=aggj1(l,4)
3822           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3823           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3824      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3825         enddo
3826       return
3827       end
3828 C-------------------------------------------------------------------------------
3829       subroutine eturn4(i,eello_turn4)
3830 C Third- and fourth-order contributions from turns
3831       implicit real*8 (a-h,o-z)
3832       include 'DIMENSIONS'
3833       include 'COMMON.IOUNITS'
3834       include 'COMMON.GEO'
3835       include 'COMMON.VAR'
3836       include 'COMMON.LOCAL'
3837       include 'COMMON.CHAIN'
3838       include 'COMMON.DERIV'
3839       include 'COMMON.INTERACT'
3840       include 'COMMON.CONTACTS'
3841       include 'COMMON.TORSION'
3842       include 'COMMON.VECTORS'
3843       include 'COMMON.FFIELD'
3844       include 'COMMON.CONTROL'
3845       dimension ggg(3)
3846       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3847      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3848      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3849       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3850      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3851       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3852      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3853      &    num_conti,j1,j2
3854       j=i+3
3855 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3856 C
3857 C               Fourth-order contributions
3858 C
3859 C                 (i+3)o----(i+4)
3860 C                     /  |
3861 C               (i+2)o   |
3862 C                     \  |
3863 C                 (i+1)o----i
3864 C
3865 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3866 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3867 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3868         a_temp(1,1)=a22
3869         a_temp(1,2)=a23
3870         a_temp(2,1)=a32
3871         a_temp(2,2)=a33
3872         iti1=itortyp(itype(i+1))
3873         iti2=itortyp(itype(i+2))
3874         iti3=itortyp(itype(i+3))
3875 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3876         call transpose2(EUg(1,1,i+1),e1t(1,1))
3877         call transpose2(Eug(1,1,i+2),e2t(1,1))
3878         call transpose2(Eug(1,1,i+3),e3t(1,1))
3879         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3880         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3881         s1=scalar2(b1(1,iti2),auxvec(1))
3882         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3883         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3884         s2=scalar2(b1(1,iti1),auxvec(1))
3885         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3886         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3887         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3888         eello_turn4=eello_turn4-(s1+s2+s3)
3889         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3890      &      'eturn4',i,j,-(s1+s2+s3)
3891 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3892 cd     &    ' eello_turn4_num',8*eello_turn4_num
3893 C Derivatives in gamma(i)
3894         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3895         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3896         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3897         s1=scalar2(b1(1,iti2),auxvec(1))
3898         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3899         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3900         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3901 C Derivatives in gamma(i+1)
3902         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3903         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3904         s2=scalar2(b1(1,iti1),auxvec(1))
3905         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3906         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3907         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3908         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3909 C Derivatives in gamma(i+2)
3910         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3911         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3912         s1=scalar2(b1(1,iti2),auxvec(1))
3913         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3914         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3915         s2=scalar2(b1(1,iti1),auxvec(1))
3916         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3917         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3918         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3919         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3920 C Cartesian derivatives
3921 C Derivatives of this turn contributions in DC(i+2)
3922         if (j.lt.nres-1) then
3923           do l=1,3
3924             a_temp(1,1)=agg(l,1)
3925             a_temp(1,2)=agg(l,2)
3926             a_temp(2,1)=agg(l,3)
3927             a_temp(2,2)=agg(l,4)
3928             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3929             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3930             s1=scalar2(b1(1,iti2),auxvec(1))
3931             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3932             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3933             s2=scalar2(b1(1,iti1),auxvec(1))
3934             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3935             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3936             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3937             ggg(l)=-(s1+s2+s3)
3938             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3939           enddo
3940         endif
3941 C Remaining derivatives of this turn contribution
3942         do l=1,3
3943           a_temp(1,1)=aggi(l,1)
3944           a_temp(1,2)=aggi(l,2)
3945           a_temp(2,1)=aggi(l,3)
3946           a_temp(2,2)=aggi(l,4)
3947           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3948           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3949           s1=scalar2(b1(1,iti2),auxvec(1))
3950           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3951           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3952           s2=scalar2(b1(1,iti1),auxvec(1))
3953           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3954           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3955           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3956           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3957           a_temp(1,1)=aggi1(l,1)
3958           a_temp(1,2)=aggi1(l,2)
3959           a_temp(2,1)=aggi1(l,3)
3960           a_temp(2,2)=aggi1(l,4)
3961           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3962           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3963           s1=scalar2(b1(1,iti2),auxvec(1))
3964           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3965           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3966           s2=scalar2(b1(1,iti1),auxvec(1))
3967           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3968           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3969           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3970           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3971           a_temp(1,1)=aggj(l,1)
3972           a_temp(1,2)=aggj(l,2)
3973           a_temp(2,1)=aggj(l,3)
3974           a_temp(2,2)=aggj(l,4)
3975           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3976           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3977           s1=scalar2(b1(1,iti2),auxvec(1))
3978           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3979           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3980           s2=scalar2(b1(1,iti1),auxvec(1))
3981           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3982           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3983           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3984           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3985           a_temp(1,1)=aggj1(l,1)
3986           a_temp(1,2)=aggj1(l,2)
3987           a_temp(2,1)=aggj1(l,3)
3988           a_temp(2,2)=aggj1(l,4)
3989           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3990           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3991           s1=scalar2(b1(1,iti2),auxvec(1))
3992           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3993           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3994           s2=scalar2(b1(1,iti1),auxvec(1))
3995           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3996           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3997           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3998 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3999           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4000         enddo
4001       return
4002       end
4003 C-----------------------------------------------------------------------------
4004       subroutine vecpr(u,v,w)
4005       implicit real*8(a-h,o-z)
4006       dimension u(3),v(3),w(3)
4007       w(1)=u(2)*v(3)-u(3)*v(2)
4008       w(2)=-u(1)*v(3)+u(3)*v(1)
4009       w(3)=u(1)*v(2)-u(2)*v(1)
4010       return
4011       end
4012 C-----------------------------------------------------------------------------
4013       subroutine unormderiv(u,ugrad,unorm,ungrad)
4014 C This subroutine computes the derivatives of a normalized vector u, given
4015 C the derivatives computed without normalization conditions, ugrad. Returns
4016 C ungrad.
4017       implicit none
4018       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4019       double precision vec(3)
4020       double precision scalar
4021       integer i,j
4022 c      write (2,*) 'ugrad',ugrad
4023 c      write (2,*) 'u',u
4024       do i=1,3
4025         vec(i)=scalar(ugrad(1,i),u(1))
4026       enddo
4027 c      write (2,*) 'vec',vec
4028       do i=1,3
4029         do j=1,3
4030           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4031         enddo
4032       enddo
4033 c      write (2,*) 'ungrad',ungrad
4034       return
4035       end
4036 C-----------------------------------------------------------------------------
4037       subroutine escp_soft_sphere(evdw2,evdw2_14)
4038 C
4039 C This subroutine calculates the excluded-volume interaction energy between
4040 C peptide-group centers and side chains and its gradient in virtual-bond and
4041 C side-chain vectors.
4042 C
4043       implicit real*8 (a-h,o-z)
4044       include 'DIMENSIONS'
4045       include 'COMMON.GEO'
4046       include 'COMMON.VAR'
4047       include 'COMMON.LOCAL'
4048       include 'COMMON.CHAIN'
4049       include 'COMMON.DERIV'
4050       include 'COMMON.INTERACT'
4051       include 'COMMON.FFIELD'
4052       include 'COMMON.IOUNITS'
4053       include 'COMMON.CONTROL'
4054       dimension ggg(3)
4055       evdw2=0.0D0
4056       evdw2_14=0.0d0
4057       r0_scp=4.5d0
4058 cd    print '(a)','Enter ESCP'
4059 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4060       do i=iatscp_s,iatscp_e
4061         iteli=itel(i)
4062         xi=0.5D0*(c(1,i)+c(1,i+1))
4063         yi=0.5D0*(c(2,i)+c(2,i+1))
4064         zi=0.5D0*(c(3,i)+c(3,i+1))
4065
4066         do iint=1,nscp_gr(i)
4067
4068         do j=iscpstart(i,iint),iscpend(i,iint)
4069           itypj=itype(j)
4070 C Uncomment following three lines for SC-p interactions
4071 c         xj=c(1,nres+j)-xi
4072 c         yj=c(2,nres+j)-yi
4073 c         zj=c(3,nres+j)-zi
4074 C Uncomment following three lines for Ca-p interactions
4075           xj=c(1,j)-xi
4076           yj=c(2,j)-yi
4077           zj=c(3,j)-zi
4078           rij=xj*xj+yj*yj+zj*zj
4079           r0ij=r0_scp
4080           r0ijsq=r0ij*r0ij
4081           if (rij.lt.r0ijsq) then
4082             evdwij=0.25d0*(rij-r0ijsq)**2
4083             fac=rij-r0ijsq
4084           else
4085             evdwij=0.0d0
4086             fac=0.0d0
4087           endif
4088           evdw2=evdw2+evdwij
4089 C
4090 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4091 C
4092           ggg(1)=xj*fac
4093           ggg(2)=yj*fac
4094           ggg(3)=zj*fac
4095 cgrad          if (j.lt.i) then
4096 cd          write (iout,*) 'j<i'
4097 C Uncomment following three lines for SC-p interactions
4098 c           do k=1,3
4099 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4100 c           enddo
4101 cgrad          else
4102 cd          write (iout,*) 'j>i'
4103 cgrad            do k=1,3
4104 cgrad              ggg(k)=-ggg(k)
4105 C Uncomment following line for SC-p interactions
4106 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4107 cgrad            enddo
4108 cgrad          endif
4109 cgrad          do k=1,3
4110 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4111 cgrad          enddo
4112 cgrad          kstart=min0(i+1,j)
4113 cgrad          kend=max0(i-1,j-1)
4114 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4115 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4116 cgrad          do k=kstart,kend
4117 cgrad            do l=1,3
4118 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4119 cgrad            enddo
4120 cgrad          enddo
4121           do k=1,3
4122             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4123             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4124           enddo
4125         enddo
4126
4127         enddo ! iint
4128       enddo ! i
4129       return
4130       end
4131 C-----------------------------------------------------------------------------
4132       subroutine escp(evdw2,evdw2_14)
4133 C
4134 C This subroutine calculates the excluded-volume interaction energy between
4135 C peptide-group centers and side chains and its gradient in virtual-bond and
4136 C side-chain vectors.
4137 C
4138       implicit real*8 (a-h,o-z)
4139       include 'DIMENSIONS'
4140       include 'COMMON.GEO'
4141       include 'COMMON.VAR'
4142       include 'COMMON.LOCAL'
4143       include 'COMMON.CHAIN'
4144       include 'COMMON.DERIV'
4145       include 'COMMON.INTERACT'
4146       include 'COMMON.FFIELD'
4147       include 'COMMON.IOUNITS'
4148       include 'COMMON.CONTROL'
4149       dimension ggg(3)
4150       evdw2=0.0D0
4151       evdw2_14=0.0d0
4152 cd    print '(a)','Enter ESCP'
4153 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4154       do i=iatscp_s,iatscp_e
4155         iteli=itel(i)
4156         xi=0.5D0*(c(1,i)+c(1,i+1))
4157         yi=0.5D0*(c(2,i)+c(2,i+1))
4158         zi=0.5D0*(c(3,i)+c(3,i+1))
4159
4160         do iint=1,nscp_gr(i)
4161
4162         do j=iscpstart(i,iint),iscpend(i,iint)
4163           itypj=itype(j)
4164 C Uncomment following three lines for SC-p interactions
4165 c         xj=c(1,nres+j)-xi
4166 c         yj=c(2,nres+j)-yi
4167 c         zj=c(3,nres+j)-zi
4168 C Uncomment following three lines for Ca-p interactions
4169           xj=c(1,j)-xi
4170           yj=c(2,j)-yi
4171           zj=c(3,j)-zi
4172           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4173           fac=rrij**expon2
4174           e1=fac*fac*aad(itypj,iteli)
4175           e2=fac*bad(itypj,iteli)
4176           if (iabs(j-i) .le. 2) then
4177             e1=scal14*e1
4178             e2=scal14*e2
4179             evdw2_14=evdw2_14+e1+e2
4180           endif
4181           evdwij=e1+e2
4182           evdw2=evdw2+evdwij
4183           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4184      &        'evdw2',i,j,evdwij
4185 C
4186 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4187 C
4188           fac=-(evdwij+e1)*rrij
4189           ggg(1)=xj*fac
4190           ggg(2)=yj*fac
4191           ggg(3)=zj*fac
4192 cgrad          if (j.lt.i) then
4193 cd          write (iout,*) 'j<i'
4194 C Uncomment following three lines for SC-p interactions
4195 c           do k=1,3
4196 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4197 c           enddo
4198 cgrad          else
4199 cd          write (iout,*) 'j>i'
4200 cgrad            do k=1,3
4201 cgrad              ggg(k)=-ggg(k)
4202 C Uncomment following line for SC-p interactions
4203 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4204 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4205 cgrad            enddo
4206 cgrad          endif
4207 cgrad          do k=1,3
4208 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4209 cgrad          enddo
4210 cgrad          kstart=min0(i+1,j)
4211 cgrad          kend=max0(i-1,j-1)
4212 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4213 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4214 cgrad          do k=kstart,kend
4215 cgrad            do l=1,3
4216 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4217 cgrad            enddo
4218 cgrad          enddo
4219           do k=1,3
4220             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4221             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4222           enddo
4223         enddo
4224
4225         enddo ! iint
4226       enddo ! i
4227       do i=1,nct
4228         do j=1,3
4229           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4230           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4231           gradx_scp(j,i)=expon*gradx_scp(j,i)
4232         enddo
4233       enddo
4234 C******************************************************************************
4235 C
4236 C                              N O T E !!!
4237 C
4238 C To save time the factor EXPON has been extracted from ALL components
4239 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4240 C use!
4241 C
4242 C******************************************************************************
4243       return
4244       end
4245 C--------------------------------------------------------------------------
4246       subroutine edis(ehpb)
4247 C
4248 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4249 C
4250       implicit real*8 (a-h,o-z)
4251       include 'DIMENSIONS'
4252       include 'COMMON.SBRIDGE'
4253       include 'COMMON.CHAIN'
4254       include 'COMMON.DERIV'
4255       include 'COMMON.VAR'
4256       include 'COMMON.INTERACT'
4257       include 'COMMON.IOUNITS'
4258       dimension ggg(3)
4259       ehpb=0.0D0
4260 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4261 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4262       if (link_end.eq.0) return
4263       do i=link_start,link_end
4264 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4265 C CA-CA distance used in regularization of structure.
4266         ii=ihpb(i)
4267         jj=jhpb(i)
4268 C iii and jjj point to the residues for which the distance is assigned.
4269         if (ii.gt.nres) then
4270           iii=ii-nres
4271           jjj=jj-nres
4272         else
4273           iii=ii
4274           jjj=jj
4275         endif
4276 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4277 c     &    dhpb(i),dhpb1(i),forcon(i)
4278 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4279 C    distance and angle dependent SS bond potential.
4280         if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4281           call ssbond_ene(iii,jjj,eij)
4282           ehpb=ehpb+2*eij
4283 cd          write (iout,*) "eij",eij
4284         else if (ii.gt.nres .and. jj.gt.nres) then
4285 c Restraints from contact prediction
4286           dd=dist(ii,jj)
4287           if (dhpb1(i).gt.0.0d0) then
4288             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4289             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4290 c            write (iout,*) "beta nmr",
4291 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4292           else
4293             dd=dist(ii,jj)
4294             rdis=dd-dhpb(i)
4295 C Get the force constant corresponding to this distance.
4296             waga=forcon(i)
4297 C Calculate the contribution to energy.
4298             ehpb=ehpb+waga*rdis*rdis
4299 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
4300 C
4301 C Evaluate gradient.
4302 C
4303             fac=waga*rdis/dd
4304           endif
4305           do j=1,3
4306             ggg(j)=fac*(c(j,jj)-c(j,ii))
4307           enddo
4308           do j=1,3
4309             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4310             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4311           enddo
4312           do k=1,3
4313             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4314             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4315           enddo
4316         else
4317 C Calculate the distance between the two points and its difference from the
4318 C target distance.
4319           dd=dist(ii,jj)
4320           if (dhpb1(i).gt.0.0d0) then
4321             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4322             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4323 c            write (iout,*) "alph nmr",
4324 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4325           else
4326             rdis=dd-dhpb(i)
4327 C Get the force constant corresponding to this distance.
4328             waga=forcon(i)
4329 C Calculate the contribution to energy.
4330             ehpb=ehpb+waga*rdis*rdis
4331 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
4332 C
4333 C Evaluate gradient.
4334 C
4335             fac=waga*rdis/dd
4336           endif
4337 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4338 cd   &   ' waga=',waga,' fac=',fac
4339             do j=1,3
4340               ggg(j)=fac*(c(j,jj)-c(j,ii))
4341             enddo
4342 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4343 C If this is a SC-SC distance, we need to calculate the contributions to the
4344 C Cartesian gradient in the SC vectors (ghpbx).
4345           if (iii.lt.ii) then
4346           do j=1,3
4347             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4348             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4349           enddo
4350           endif
4351 cgrad        do j=iii,jjj-1
4352 cgrad          do k=1,3
4353 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4354 cgrad          enddo
4355 cgrad        enddo
4356           do k=1,3
4357             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4358             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4359           enddo
4360         endif
4361       enddo
4362       ehpb=0.5D0*ehpb
4363       return
4364       end
4365 C--------------------------------------------------------------------------
4366       subroutine ssbond_ene(i,j,eij)
4367 C
4368 C Calculate the distance and angle dependent SS-bond potential energy
4369 C using a free-energy function derived based on RHF/6-31G** ab initio
4370 C calculations of diethyl disulfide.
4371 C
4372 C A. Liwo and U. Kozlowska, 11/24/03
4373 C
4374       implicit real*8 (a-h,o-z)
4375       include 'DIMENSIONS'
4376       include 'COMMON.SBRIDGE'
4377       include 'COMMON.CHAIN'
4378       include 'COMMON.DERIV'
4379       include 'COMMON.LOCAL'
4380       include 'COMMON.INTERACT'
4381       include 'COMMON.VAR'
4382       include 'COMMON.IOUNITS'
4383       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4384       itypi=itype(i)
4385       xi=c(1,nres+i)
4386       yi=c(2,nres+i)
4387       zi=c(3,nres+i)
4388       dxi=dc_norm(1,nres+i)
4389       dyi=dc_norm(2,nres+i)
4390       dzi=dc_norm(3,nres+i)
4391 c      dsci_inv=dsc_inv(itypi)
4392       dsci_inv=vbld_inv(nres+i)
4393       itypj=itype(j)
4394 c      dscj_inv=dsc_inv(itypj)
4395       dscj_inv=vbld_inv(nres+j)
4396       xj=c(1,nres+j)-xi
4397       yj=c(2,nres+j)-yi
4398       zj=c(3,nres+j)-zi
4399       dxj=dc_norm(1,nres+j)
4400       dyj=dc_norm(2,nres+j)
4401       dzj=dc_norm(3,nres+j)
4402       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4403       rij=dsqrt(rrij)
4404       erij(1)=xj*rij
4405       erij(2)=yj*rij
4406       erij(3)=zj*rij
4407       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4408       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4409       om12=dxi*dxj+dyi*dyj+dzi*dzj
4410       do k=1,3
4411         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4412         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4413       enddo
4414       rij=1.0d0/rij
4415       deltad=rij-d0cm
4416       deltat1=1.0d0-om1
4417       deltat2=1.0d0+om2
4418       deltat12=om2-om1+2.0d0
4419       cosphi=om12-om1*om2
4420       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4421      &  +akct*deltad*deltat12
4422      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4423 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4424 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4425 c     &  " deltat12",deltat12," eij",eij
4426       ed=2*akcm*deltad+akct*deltat12
4427       pom1=akct*deltad
4428       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4429       eom1=-2*akth*deltat1-pom1-om2*pom2
4430       eom2= 2*akth*deltat2+pom1-om1*pom2
4431       eom12=pom2
4432       do k=1,3
4433         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4434         ghpbx(k,i)=ghpbx(k,i)-ggk
4435      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4436      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4437         ghpbx(k,j)=ghpbx(k,j)+ggk
4438      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4439      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4440         ghpbc(k,i)=ghpbc(k,i)-ggk
4441         ghpbc(k,j)=ghpbc(k,j)+ggk
4442       enddo
4443 C
4444 C Calculate the components of the gradient in DC and X
4445 C
4446 cgrad      do k=i,j-1
4447 cgrad        do l=1,3
4448 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4449 cgrad        enddo
4450 cgrad      enddo
4451       return
4452       end
4453 C--------------------------------------------------------------------------
4454       subroutine ebond(estr)
4455 c
4456 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4457 c
4458       implicit real*8 (a-h,o-z)
4459       include 'DIMENSIONS'
4460       include 'COMMON.LOCAL'
4461       include 'COMMON.GEO'
4462       include 'COMMON.INTERACT'
4463       include 'COMMON.DERIV'
4464       include 'COMMON.VAR'
4465       include 'COMMON.CHAIN'
4466       include 'COMMON.IOUNITS'
4467       include 'COMMON.NAMES'
4468       include 'COMMON.FFIELD'
4469       include 'COMMON.CONTROL'
4470       include 'COMMON.SETUP'
4471       double precision u(3),ud(3)
4472       estr=0.0d0
4473       do i=ibondp_start,ibondp_end
4474         diff = vbld(i)-vbldp0
4475 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4476         estr=estr+diff*diff
4477         do j=1,3
4478           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4479         enddo
4480 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4481       enddo
4482       estr=0.5d0*AKP*estr
4483 c
4484 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4485 c
4486       do i=ibond_start,ibond_end
4487         iti=itype(i)
4488         if (iti.ne.10) then
4489           nbi=nbondterm(iti)
4490           if (nbi.eq.1) then
4491             diff=vbld(i+nres)-vbldsc0(1,iti)
4492 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4493 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4494             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4495             do j=1,3
4496               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4497             enddo
4498           else
4499             do j=1,nbi
4500               diff=vbld(i+nres)-vbldsc0(j,iti)
4501               ud(j)=aksc(j,iti)*diff
4502               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4503             enddo
4504             uprod=u(1)
4505             do j=2,nbi
4506               uprod=uprod*u(j)
4507             enddo
4508             usum=0.0d0
4509             usumsqder=0.0d0
4510             do j=1,nbi
4511               uprod1=1.0d0
4512               uprod2=1.0d0
4513               do k=1,nbi
4514                 if (k.ne.j) then
4515                   uprod1=uprod1*u(k)
4516                   uprod2=uprod2*u(k)*u(k)
4517                 endif
4518               enddo
4519               usum=usum+uprod1
4520               usumsqder=usumsqder+ud(j)*uprod2
4521             enddo
4522             estr=estr+uprod/usum
4523             do j=1,3
4524              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4525             enddo
4526           endif
4527         endif
4528       enddo
4529       return
4530       end
4531 #ifdef CRYST_THETA
4532 C--------------------------------------------------------------------------
4533       subroutine ebend(etheta)
4534 C
4535 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4536 C angles gamma and its derivatives in consecutive thetas and gammas.
4537 C
4538       implicit real*8 (a-h,o-z)
4539       include 'DIMENSIONS'
4540       include 'COMMON.LOCAL'
4541       include 'COMMON.GEO'
4542       include 'COMMON.INTERACT'
4543       include 'COMMON.DERIV'
4544       include 'COMMON.VAR'
4545       include 'COMMON.CHAIN'
4546       include 'COMMON.IOUNITS'
4547       include 'COMMON.NAMES'
4548       include 'COMMON.FFIELD'
4549       include 'COMMON.CONTROL'
4550       common /calcthet/ term1,term2,termm,diffak,ratak,
4551      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4552      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4553       double precision y(2),z(2)
4554       delta=0.02d0*pi
4555 c      time11=dexp(-2*time)
4556 c      time12=1.0d0
4557       etheta=0.0D0
4558 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4559       do i=ithet_start,ithet_end
4560 C Zero the energy function and its derivative at 0 or pi.
4561         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4562         it=itype(i-1)
4563         if (i.gt.3) then
4564 #ifdef OSF
4565           phii=phi(i)
4566           if (phii.ne.phii) phii=150.0
4567 #else
4568           phii=phi(i)
4569 #endif
4570           y(1)=dcos(phii)
4571           y(2)=dsin(phii)
4572         else
4573           y(1)=0.0D0
4574           y(2)=0.0D0
4575         endif
4576         if (i.lt.nres) then
4577 #ifdef OSF
4578           phii1=phi(i+1)
4579           if (phii1.ne.phii1) phii1=150.0
4580           phii1=pinorm(phii1)
4581           z(1)=cos(phii1)
4582 #else
4583           phii1=phi(i+1)
4584           z(1)=dcos(phii1)
4585 #endif
4586           z(2)=dsin(phii1)
4587         else
4588           z(1)=0.0D0
4589           z(2)=0.0D0
4590         endif
4591 C Calculate the "mean" value of theta from the part of the distribution
4592 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4593 C In following comments this theta will be referred to as t_c.
4594         thet_pred_mean=0.0d0
4595         do k=1,2
4596           athetk=athet(k,it)
4597           bthetk=bthet(k,it)
4598           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4599         enddo
4600         dthett=thet_pred_mean*ssd
4601         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4602 C Derivatives of the "mean" values in gamma1 and gamma2.
4603         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
4604         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
4605         if (theta(i).gt.pi-delta) then
4606           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4607      &         E_tc0)
4608           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4609           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4610           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4611      &        E_theta)
4612           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4613      &        E_tc)
4614         else if (theta(i).lt.delta) then
4615           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4616           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4617           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4618      &        E_theta)
4619           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4620           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4621      &        E_tc)
4622         else
4623           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4624      &        E_theta,E_tc)
4625         endif
4626         etheta=etheta+ethetai
4627         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4628      &      'ebend',i,ethetai
4629         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4630         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4631         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4632       enddo
4633 C Ufff.... We've done all this!!!
4634       return
4635       end
4636 C---------------------------------------------------------------------------
4637       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4638      &     E_tc)
4639       implicit real*8 (a-h,o-z)
4640       include 'DIMENSIONS'
4641       include 'COMMON.LOCAL'
4642       include 'COMMON.IOUNITS'
4643       common /calcthet/ term1,term2,termm,diffak,ratak,
4644      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4645      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4646 C Calculate the contributions to both Gaussian lobes.
4647 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4648 C The "polynomial part" of the "standard deviation" of this part of
4649 C the distribution.
4650         sig=polthet(3,it)
4651         do j=2,0,-1
4652           sig=sig*thet_pred_mean+polthet(j,it)
4653         enddo
4654 C Derivative of the "interior part" of the "standard deviation of the"
4655 C gamma-dependent Gaussian lobe in t_c.
4656         sigtc=3*polthet(3,it)
4657         do j=2,1,-1
4658           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4659         enddo
4660         sigtc=sig*sigtc
4661 C Set the parameters of both Gaussian lobes of the distribution.
4662 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4663         fac=sig*sig+sigc0(it)
4664         sigcsq=fac+fac
4665         sigc=1.0D0/sigcsq
4666 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4667         sigsqtc=-4.0D0*sigcsq*sigtc
4668 c       print *,i,sig,sigtc,sigsqtc
4669 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4670         sigtc=-sigtc/(fac*fac)
4671 C Following variable is sigma(t_c)**(-2)
4672         sigcsq=sigcsq*sigcsq
4673         sig0i=sig0(it)
4674         sig0inv=1.0D0/sig0i**2
4675         delthec=thetai-thet_pred_mean
4676         delthe0=thetai-theta0i
4677         term1=-0.5D0*sigcsq*delthec*delthec
4678         term2=-0.5D0*sig0inv*delthe0*delthe0
4679 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4680 C NaNs in taking the logarithm. We extract the largest exponent which is added
4681 C to the energy (this being the log of the distribution) at the end of energy
4682 C term evaluation for this virtual-bond angle.
4683         if (term1.gt.term2) then
4684           termm=term1
4685           term2=dexp(term2-termm)
4686           term1=1.0d0
4687         else
4688           termm=term2
4689           term1=dexp(term1-termm)
4690           term2=1.0d0
4691         endif
4692 C The ratio between the gamma-independent and gamma-dependent lobes of
4693 C the distribution is a Gaussian function of thet_pred_mean too.
4694         diffak=gthet(2,it)-thet_pred_mean
4695         ratak=diffak/gthet(3,it)**2
4696         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4697 C Let's differentiate it in thet_pred_mean NOW.
4698         aktc=ak*ratak
4699 C Now put together the distribution terms to make complete distribution.
4700         termexp=term1+ak*term2
4701         termpre=sigc+ak*sig0i
4702 C Contribution of the bending energy from this theta is just the -log of
4703 C the sum of the contributions from the two lobes and the pre-exponential
4704 C factor. Simple enough, isn't it?
4705         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4706 C NOW the derivatives!!!
4707 C 6/6/97 Take into account the deformation.
4708         E_theta=(delthec*sigcsq*term1
4709      &       +ak*delthe0*sig0inv*term2)/termexp
4710         E_tc=((sigtc+aktc*sig0i)/termpre
4711      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4712      &       aktc*term2)/termexp)
4713       return
4714       end
4715 c-----------------------------------------------------------------------------
4716       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4717       implicit real*8 (a-h,o-z)
4718       include 'DIMENSIONS'
4719       include 'COMMON.LOCAL'
4720       include 'COMMON.IOUNITS'
4721       common /calcthet/ term1,term2,termm,diffak,ratak,
4722      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4723      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4724       delthec=thetai-thet_pred_mean
4725       delthe0=thetai-theta0i
4726 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4727       t3 = thetai-thet_pred_mean
4728       t6 = t3**2
4729       t9 = term1
4730       t12 = t3*sigcsq
4731       t14 = t12+t6*sigsqtc
4732       t16 = 1.0d0
4733       t21 = thetai-theta0i
4734       t23 = t21**2
4735       t26 = term2
4736       t27 = t21*t26
4737       t32 = termexp
4738       t40 = t32**2
4739       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4740      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4741      & *(-t12*t9-ak*sig0inv*t27)
4742       return
4743       end
4744 #else
4745 C--------------------------------------------------------------------------
4746       subroutine ebend(etheta)
4747 C
4748 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4749 C angles gamma and its derivatives in consecutive thetas and gammas.
4750 C ab initio-derived potentials from
4751 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4752 C
4753       implicit real*8 (a-h,o-z)
4754       include 'DIMENSIONS'
4755       include 'COMMON.LOCAL'
4756       include 'COMMON.GEO'
4757       include 'COMMON.INTERACT'
4758       include 'COMMON.DERIV'
4759       include 'COMMON.VAR'
4760       include 'COMMON.CHAIN'
4761       include 'COMMON.IOUNITS'
4762       include 'COMMON.NAMES'
4763       include 'COMMON.FFIELD'
4764       include 'COMMON.CONTROL'
4765       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4766      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4767      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4768      & sinph1ph2(maxdouble,maxdouble)
4769       logical lprn /.false./, lprn1 /.false./
4770       etheta=0.0D0
4771       do i=ithet_start,ithet_end
4772         dethetai=0.0d0
4773         dephii=0.0d0
4774         dephii1=0.0d0
4775         theti2=0.5d0*theta(i)
4776         ityp2=ithetyp(itype(i-1))
4777         do k=1,nntheterm
4778           coskt(k)=dcos(k*theti2)
4779           sinkt(k)=dsin(k*theti2)
4780         enddo
4781         if (i.gt.3) then
4782 #ifdef OSF
4783           phii=phi(i)
4784           if (phii.ne.phii) phii=150.0
4785 #else
4786           phii=phi(i)
4787 #endif
4788           ityp1=ithetyp(itype(i-2))
4789           do k=1,nsingle
4790             cosph1(k)=dcos(k*phii)
4791             sinph1(k)=dsin(k*phii)
4792           enddo
4793         else
4794           phii=0.0d0
4795           ityp1=nthetyp+1
4796           do k=1,nsingle
4797             cosph1(k)=0.0d0
4798             sinph1(k)=0.0d0
4799           enddo
4800         endif
4801         if (i.lt.nres) then
4802 #ifdef OSF
4803           phii1=phi(i+1)
4804           if (phii1.ne.phii1) phii1=150.0
4805           phii1=pinorm(phii1)
4806 #else
4807           phii1=phi(i+1)
4808 #endif
4809           ityp3=ithetyp(itype(i))
4810           do k=1,nsingle
4811             cosph2(k)=dcos(k*phii1)
4812             sinph2(k)=dsin(k*phii1)
4813           enddo
4814         else
4815           phii1=0.0d0
4816           ityp3=nthetyp+1
4817           do k=1,nsingle
4818             cosph2(k)=0.0d0
4819             sinph2(k)=0.0d0
4820           enddo
4821         endif
4822         ethetai=aa0thet(ityp1,ityp2,ityp3)
4823         do k=1,ndouble
4824           do l=1,k-1
4825             ccl=cosph1(l)*cosph2(k-l)
4826             ssl=sinph1(l)*sinph2(k-l)
4827             scl=sinph1(l)*cosph2(k-l)
4828             csl=cosph1(l)*sinph2(k-l)
4829             cosph1ph2(l,k)=ccl-ssl
4830             cosph1ph2(k,l)=ccl+ssl
4831             sinph1ph2(l,k)=scl+csl
4832             sinph1ph2(k,l)=scl-csl
4833           enddo
4834         enddo
4835         if (lprn) then
4836         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4837      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4838         write (iout,*) "coskt and sinkt"
4839         do k=1,nntheterm
4840           write (iout,*) k,coskt(k),sinkt(k)
4841         enddo
4842         endif
4843         do k=1,ntheterm
4844           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4845           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4846      &      *coskt(k)
4847           if (lprn)
4848      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4849      &     " ethetai",ethetai
4850         enddo
4851         if (lprn) then
4852         write (iout,*) "cosph and sinph"
4853         do k=1,nsingle
4854           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4855         enddo
4856         write (iout,*) "cosph1ph2 and sinph2ph2"
4857         do k=2,ndouble
4858           do l=1,k-1
4859             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4860      &         sinph1ph2(l,k),sinph1ph2(k,l)
4861           enddo
4862         enddo
4863         write(iout,*) "ethetai",ethetai
4864         endif
4865         do m=1,ntheterm2
4866           do k=1,nsingle
4867             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4868      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4869      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4870      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4871             ethetai=ethetai+sinkt(m)*aux
4872             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4873             dephii=dephii+k*sinkt(m)*(
4874      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4875      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4876             dephii1=dephii1+k*sinkt(m)*(
4877      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4878      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4879             if (lprn)
4880      &      write (iout,*) "m",m," k",k," bbthet",
4881      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4882      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4883      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4884      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4885           enddo
4886         enddo
4887         if (lprn)
4888      &  write(iout,*) "ethetai",ethetai
4889         do m=1,ntheterm3
4890           do k=2,ndouble
4891             do l=1,k-1
4892               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4893      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4894      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4895      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4896               ethetai=ethetai+sinkt(m)*aux
4897               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4898               dephii=dephii+l*sinkt(m)*(
4899      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4900      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4901      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4902      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4903               dephii1=dephii1+(k-l)*sinkt(m)*(
4904      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4905      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4906      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
4907      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4908               if (lprn) then
4909               write (iout,*) "m",m," k",k," l",l," ffthet",
4910      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
4911      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
4912      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
4913      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4914               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4915      &            cosph1ph2(k,l)*sinkt(m),
4916      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4917               endif
4918             enddo
4919           enddo
4920         enddo
4921 10      continue
4922         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4923      &   i,theta(i)*rad2deg,phii*rad2deg,
4924      &   phii1*rad2deg,ethetai
4925         etheta=etheta+ethetai
4926         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4927         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4928         gloc(nphi+i-2,icg)=wang*dethetai
4929       enddo
4930       return
4931       end
4932 #endif
4933 #ifdef CRYST_SC
4934 c-----------------------------------------------------------------------------
4935       subroutine esc(escloc)
4936 C Calculate the local energy of a side chain and its derivatives in the
4937 C corresponding virtual-bond valence angles THETA and the spherical angles
4938 C ALPHA and OMEGA.
4939       implicit real*8 (a-h,o-z)
4940       include 'DIMENSIONS'
4941       include 'COMMON.GEO'
4942       include 'COMMON.LOCAL'
4943       include 'COMMON.VAR'
4944       include 'COMMON.INTERACT'
4945       include 'COMMON.DERIV'
4946       include 'COMMON.CHAIN'
4947       include 'COMMON.IOUNITS'
4948       include 'COMMON.NAMES'
4949       include 'COMMON.FFIELD'
4950       include 'COMMON.CONTROL'
4951       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4952      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4953       common /sccalc/ time11,time12,time112,theti,it,nlobit
4954       delta=0.02d0*pi
4955       escloc=0.0D0
4956 c     write (iout,'(a)') 'ESC'
4957       do i=loc_start,loc_end
4958         it=itype(i)
4959         if (it.eq.10) goto 1
4960         nlobit=nlob(it)
4961 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4962 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4963         theti=theta(i+1)-pipol
4964         x(1)=dtan(theti)
4965         x(2)=alph(i)
4966         x(3)=omeg(i)
4967
4968         if (x(2).gt.pi-delta) then
4969           xtemp(1)=x(1)
4970           xtemp(2)=pi-delta
4971           xtemp(3)=x(3)
4972           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4973           xtemp(2)=pi
4974           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4975           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4976      &        escloci,dersc(2))
4977           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4978      &        ddersc0(1),dersc(1))
4979           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4980      &        ddersc0(3),dersc(3))
4981           xtemp(2)=pi-delta
4982           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4983           xtemp(2)=pi
4984           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4985           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4986      &            dersc0(2),esclocbi,dersc02)
4987           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4988      &            dersc12,dersc01)
4989           call splinthet(x(2),0.5d0*delta,ss,ssd)
4990           dersc0(1)=dersc01
4991           dersc0(2)=dersc02
4992           dersc0(3)=0.0d0
4993           do k=1,3
4994             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4995           enddo
4996           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4997 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4998 c    &             esclocbi,ss,ssd
4999           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5000 c         escloci=esclocbi
5001 c         write (iout,*) escloci
5002         else if (x(2).lt.delta) then
5003           xtemp(1)=x(1)
5004           xtemp(2)=delta
5005           xtemp(3)=x(3)
5006           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5007           xtemp(2)=0.0d0
5008           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5009           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5010      &        escloci,dersc(2))
5011           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5012      &        ddersc0(1),dersc(1))
5013           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5014      &        ddersc0(3),dersc(3))
5015           xtemp(2)=delta
5016           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5017           xtemp(2)=0.0d0
5018           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5019           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5020      &            dersc0(2),esclocbi,dersc02)
5021           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5022      &            dersc12,dersc01)
5023           dersc0(1)=dersc01
5024           dersc0(2)=dersc02
5025           dersc0(3)=0.0d0
5026           call splinthet(x(2),0.5d0*delta,ss,ssd)
5027           do k=1,3
5028             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5029           enddo
5030           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5031 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5032 c    &             esclocbi,ss,ssd
5033           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5034 c         write (iout,*) escloci
5035         else
5036           call enesc(x,escloci,dersc,ddummy,.false.)
5037         endif
5038
5039         escloc=escloc+escloci
5040         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5041      &     'escloc',i,escloci
5042 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5043
5044         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5045      &   wscloc*dersc(1)
5046         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5047         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5048     1   continue
5049       enddo
5050       return
5051       end
5052 C---------------------------------------------------------------------------
5053       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5054       implicit real*8 (a-h,o-z)
5055       include 'DIMENSIONS'
5056       include 'COMMON.GEO'
5057       include 'COMMON.LOCAL'
5058       include 'COMMON.IOUNITS'
5059       common /sccalc/ time11,time12,time112,theti,it,nlobit
5060       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5061       double precision contr(maxlob,-1:1)
5062       logical mixed
5063 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5064         escloc_i=0.0D0
5065         do j=1,3
5066           dersc(j)=0.0D0
5067           if (mixed) ddersc(j)=0.0d0
5068         enddo
5069         x3=x(3)
5070
5071 C Because of periodicity of the dependence of the SC energy in omega we have
5072 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5073 C To avoid underflows, first compute & store the exponents.
5074
5075         do iii=-1,1
5076
5077           x(3)=x3+iii*dwapi
5078
5079           do j=1,nlobit
5080             do k=1,3
5081               z(k)=x(k)-censc(k,j,it)
5082             enddo
5083             do k=1,3
5084               Axk=0.0D0
5085               do l=1,3
5086                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5087               enddo
5088               Ax(k,j,iii)=Axk
5089             enddo
5090             expfac=0.0D0
5091             do k=1,3
5092               expfac=expfac+Ax(k,j,iii)*z(k)
5093             enddo
5094             contr(j,iii)=expfac
5095           enddo ! j
5096
5097         enddo ! iii
5098
5099         x(3)=x3
5100 C As in the case of ebend, we want to avoid underflows in exponentiation and
5101 C subsequent NaNs and INFs in energy calculation.
5102 C Find the largest exponent
5103         emin=contr(1,-1)
5104         do iii=-1,1
5105           do j=1,nlobit
5106             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5107           enddo
5108         enddo
5109         emin=0.5D0*emin
5110 cd      print *,'it=',it,' emin=',emin
5111
5112 C Compute the contribution to SC energy and derivatives
5113         do iii=-1,1
5114
5115           do j=1,nlobit
5116 #ifdef OSF
5117             adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin
5118             if(adexp.ne.adexp) adexp=1.0
5119             expfac=dexp(adexp)
5120 #else
5121             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
5122 #endif
5123 cd          print *,'j=',j,' expfac=',expfac
5124             escloc_i=escloc_i+expfac
5125             do k=1,3
5126               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5127             enddo
5128             if (mixed) then
5129               do k=1,3,2
5130                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5131      &            +gaussc(k,2,j,it))*expfac
5132               enddo
5133             endif
5134           enddo
5135
5136         enddo ! iii
5137
5138         dersc(1)=dersc(1)/cos(theti)**2
5139         ddersc(1)=ddersc(1)/cos(theti)**2
5140         ddersc(3)=ddersc(3)
5141
5142         escloci=-(dlog(escloc_i)-emin)
5143         do j=1,3
5144           dersc(j)=dersc(j)/escloc_i
5145         enddo
5146         if (mixed) then
5147           do j=1,3,2
5148             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5149           enddo
5150         endif
5151       return
5152       end
5153 C------------------------------------------------------------------------------
5154       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5155       implicit real*8 (a-h,o-z)
5156       include 'DIMENSIONS'
5157       include 'COMMON.GEO'
5158       include 'COMMON.LOCAL'
5159       include 'COMMON.IOUNITS'
5160       common /sccalc/ time11,time12,time112,theti,it,nlobit
5161       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5162       double precision contr(maxlob)
5163       logical mixed
5164
5165       escloc_i=0.0D0
5166
5167       do j=1,3
5168         dersc(j)=0.0D0
5169       enddo
5170
5171       do j=1,nlobit
5172         do k=1,2
5173           z(k)=x(k)-censc(k,j,it)
5174         enddo
5175         z(3)=dwapi
5176         do k=1,3
5177           Axk=0.0D0
5178           do l=1,3
5179             Axk=Axk+gaussc(l,k,j,it)*z(l)
5180           enddo
5181           Ax(k,j)=Axk
5182         enddo
5183         expfac=0.0D0
5184         do k=1,3
5185           expfac=expfac+Ax(k,j)*z(k)
5186         enddo
5187         contr(j)=expfac
5188       enddo ! j
5189
5190 C As in the case of ebend, we want to avoid underflows in exponentiation and
5191 C subsequent NaNs and INFs in energy calculation.
5192 C Find the largest exponent
5193       emin=contr(1)
5194       do j=1,nlobit
5195         if (emin.gt.contr(j)) emin=contr(j)
5196       enddo
5197       emin=0.5D0*emin
5198
5199 C Compute the contribution to SC energy and derivatives
5200
5201       dersc12=0.0d0
5202       do j=1,nlobit
5203         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
5204         escloc_i=escloc_i+expfac
5205         do k=1,2
5206           dersc(k)=dersc(k)+Ax(k,j)*expfac
5207         enddo
5208         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5209      &            +gaussc(1,2,j,it))*expfac
5210         dersc(3)=0.0d0
5211       enddo
5212
5213       dersc(1)=dersc(1)/cos(theti)**2
5214       dersc12=dersc12/cos(theti)**2
5215       escloci=-(dlog(escloc_i)-emin)
5216       do j=1,2
5217         dersc(j)=dersc(j)/escloc_i
5218       enddo
5219       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5220       return
5221       end
5222 #else
5223 c----------------------------------------------------------------------------------
5224       subroutine esc(escloc)
5225 C Calculate the local energy of a side chain and its derivatives in the
5226 C corresponding virtual-bond valence angles THETA and the spherical angles
5227 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5228 C added by Urszula Kozlowska. 07/11/2007
5229 C
5230       implicit real*8 (a-h,o-z)
5231       include 'DIMENSIONS'
5232       include 'COMMON.GEO'
5233       include 'COMMON.LOCAL'
5234       include 'COMMON.VAR'
5235       include 'COMMON.SCROT'
5236       include 'COMMON.INTERACT'
5237       include 'COMMON.DERIV'
5238       include 'COMMON.CHAIN'
5239       include 'COMMON.IOUNITS'
5240       include 'COMMON.NAMES'
5241       include 'COMMON.FFIELD'
5242       include 'COMMON.CONTROL'
5243       include 'COMMON.VECTORS'
5244       double precision x_prime(3),y_prime(3),z_prime(3)
5245      &    , sumene,dsc_i,dp2_i,x(65),
5246      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5247      &    de_dxx,de_dyy,de_dzz,de_dt
5248       double precision s1_t,s1_6_t,s2_t,s2_6_t
5249       double precision
5250      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5251      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5252      & dt_dCi(3),dt_dCi1(3)
5253       common /sccalc/ time11,time12,time112,theti,it,nlobit
5254       delta=0.02d0*pi
5255       escloc=0.0D0
5256       do i=loc_start,loc_end
5257         costtab(i+1) =dcos(theta(i+1))
5258         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5259         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5260         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5261         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5262         cosfac=dsqrt(cosfac2)
5263         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5264         sinfac=dsqrt(sinfac2)
5265         it=itype(i)
5266         if (it.eq.10) goto 1
5267 c
5268 C  Compute the axes of tghe local cartesian coordinates system; store in
5269 c   x_prime, y_prime and z_prime
5270 c
5271         do j=1,3
5272           x_prime(j) = 0.00
5273           y_prime(j) = 0.00
5274           z_prime(j) = 0.00
5275         enddo
5276 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5277 C     &   dc_norm(3,i+nres)
5278         do j = 1,3
5279           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5280           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5281         enddo
5282         do j = 1,3
5283           z_prime(j) = -uz(j,i-1)
5284         enddo
5285 c       write (2,*) "i",i
5286 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5287 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5288 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5289 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5290 c      & " xy",scalar(x_prime(1),y_prime(1)),
5291 c      & " xz",scalar(x_prime(1),z_prime(1)),
5292 c      & " yy",scalar(y_prime(1),y_prime(1)),
5293 c      & " yz",scalar(y_prime(1),z_prime(1)),
5294 c      & " zz",scalar(z_prime(1),z_prime(1))
5295 c
5296 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5297 C to local coordinate system. Store in xx, yy, zz.
5298 c
5299         xx=0.0d0
5300         yy=0.0d0
5301         zz=0.0d0
5302         do j = 1,3
5303           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5304           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5305           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5306         enddo
5307
5308         xxtab(i)=xx
5309         yytab(i)=yy
5310         zztab(i)=zz
5311 C
5312 C Compute the energy of the ith side cbain
5313 C
5314 c        write (2,*) "xx",xx," yy",yy," zz",zz
5315         it=itype(i)
5316         do j = 1,65
5317           x(j) = sc_parmin(j,it)
5318         enddo
5319 #ifdef CHECK_COORD
5320 Cc diagnostics - remove later
5321         xx1 = dcos(alph(2))
5322         yy1 = dsin(alph(2))*dcos(omeg(2))
5323         zz1 = -dsin(alph(2))*dsin(omeg(2))
5324         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5325      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5326      &    xx1,yy1,zz1
5327 C,"  --- ", xx_w,yy_w,zz_w
5328 c end diagnostics
5329 #endif
5330         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5331      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5332      &   + x(10)*yy*zz
5333         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5334      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5335      & + x(20)*yy*zz
5336         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5337      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5338      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5339      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5340      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5341      &  +x(40)*xx*yy*zz
5342         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5343      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5344      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5345      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5346      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5347      &  +x(60)*xx*yy*zz
5348         dsc_i   = 0.743d0+x(61)
5349         dp2_i   = 1.9d0+x(62)
5350         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5351      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5352         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5353      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5354         s1=(1+x(63))/(0.1d0 + dscp1)
5355         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5356         s2=(1+x(65))/(0.1d0 + dscp2)
5357         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5358         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5359      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5360 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5361 c     &   sumene4,
5362 c     &   dscp1,dscp2,sumene
5363 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5364         escloc = escloc + sumene
5365 c        write (2,*) "i",i," escloc",sumene,escloc
5366 #ifdef DEBUG
5367 C
5368 C This section to check the numerical derivatives of the energy of ith side
5369 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5370 C #define DEBUG in the code to turn it on.
5371 C
5372         write (2,*) "sumene               =",sumene
5373         aincr=1.0d-7
5374         xxsave=xx
5375         xx=xx+aincr
5376         write (2,*) xx,yy,zz
5377         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5378         de_dxx_num=(sumenep-sumene)/aincr
5379         xx=xxsave
5380         write (2,*) "xx+ sumene from enesc=",sumenep
5381         yysave=yy
5382         yy=yy+aincr
5383         write (2,*) xx,yy,zz
5384         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5385         de_dyy_num=(sumenep-sumene)/aincr
5386         yy=yysave
5387         write (2,*) "yy+ sumene from enesc=",sumenep
5388         zzsave=zz
5389         zz=zz+aincr
5390         write (2,*) xx,yy,zz
5391         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5392         de_dzz_num=(sumenep-sumene)/aincr
5393         zz=zzsave
5394         write (2,*) "zz+ sumene from enesc=",sumenep
5395         costsave=cost2tab(i+1)
5396         sintsave=sint2tab(i+1)
5397         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5398         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5399         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5400         de_dt_num=(sumenep-sumene)/aincr
5401         write (2,*) " t+ sumene from enesc=",sumenep
5402         cost2tab(i+1)=costsave
5403         sint2tab(i+1)=sintsave
5404 C End of diagnostics section.
5405 #endif
5406 C
5407 C Compute the gradient of esc
5408 C
5409         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5410         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5411         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5412         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5413         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5414         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5415         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5416         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5417         pom1=(sumene3*sint2tab(i+1)+sumene1)
5418      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5419         pom2=(sumene4*cost2tab(i+1)+sumene2)
5420      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5421         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5422         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5423      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5424      &  +x(40)*yy*zz
5425         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5426         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5427      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5428      &  +x(60)*yy*zz
5429         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5430      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5431      &        +(pom1+pom2)*pom_dx
5432 #ifdef DEBUG
5433         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5434 #endif
5435 C
5436         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5437         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5438      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5439      &  +x(40)*xx*zz
5440         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5441         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5442      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5443      &  +x(59)*zz**2 +x(60)*xx*zz
5444         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5445      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5446      &        +(pom1-pom2)*pom_dy
5447 #ifdef DEBUG
5448         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5449 #endif
5450 C
5451         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5452      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5453      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5454      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5455      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5456      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5457      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5458      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5459 #ifdef DEBUG
5460         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5461 #endif
5462 C
5463         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5464      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5465      &  +pom1*pom_dt1+pom2*pom_dt2
5466 #ifdef DEBUG
5467         write(2,*), "de_dt = ", de_dt,de_dt_num
5468 #endif
5469 c
5470 C
5471        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5472        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5473        cosfac2xx=cosfac2*xx
5474        sinfac2yy=sinfac2*yy
5475        do k = 1,3
5476          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5477      &      vbld_inv(i+1)
5478          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5479      &      vbld_inv(i)
5480          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5481          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5482 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5483 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5484 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5485 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5486          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5487          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5488          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5489          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5490          dZZ_Ci1(k)=0.0d0
5491          dZZ_Ci(k)=0.0d0
5492          do j=1,3
5493            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5494            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5495          enddo
5496
5497          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5498          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5499          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5500 c
5501          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5502          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5503        enddo
5504
5505        do k=1,3
5506          dXX_Ctab(k,i)=dXX_Ci(k)
5507          dXX_C1tab(k,i)=dXX_Ci1(k)
5508          dYY_Ctab(k,i)=dYY_Ci(k)
5509          dYY_C1tab(k,i)=dYY_Ci1(k)
5510          dZZ_Ctab(k,i)=dZZ_Ci(k)
5511          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5512          dXX_XYZtab(k,i)=dXX_XYZ(k)
5513          dYY_XYZtab(k,i)=dYY_XYZ(k)
5514          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5515        enddo
5516
5517        do k = 1,3
5518 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5519 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5520 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5521 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5522 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5523 c     &    dt_dci(k)
5524 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5525 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5526          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5527      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5528          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5529      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5530          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5531      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5532        enddo
5533 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5534 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5535
5536 C to check gradient call subroutine check_grad
5537
5538     1 continue
5539       enddo
5540       return
5541       end
5542 c------------------------------------------------------------------------------
5543       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5544       implicit none
5545       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5546      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5547       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5548      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5549      &   + x(10)*yy*zz
5550       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5551      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5552      & + x(20)*yy*zz
5553       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5554      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5555      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5556      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5557      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5558      &  +x(40)*xx*yy*zz
5559       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5560      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5561      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5562      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5563      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5564      &  +x(60)*xx*yy*zz
5565       dsc_i   = 0.743d0+x(61)
5566       dp2_i   = 1.9d0+x(62)
5567       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5568      &          *(xx*cost2+yy*sint2))
5569       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5570      &          *(xx*cost2-yy*sint2))
5571       s1=(1+x(63))/(0.1d0 + dscp1)
5572       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5573       s2=(1+x(65))/(0.1d0 + dscp2)
5574       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5575       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5576      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5577       enesc=sumene
5578       return
5579       end
5580 #endif
5581 c------------------------------------------------------------------------------
5582       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5583 C
5584 C This procedure calculates two-body contact function g(rij) and its derivative:
5585 C
5586 C           eps0ij                                     !       x < -1
5587 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5588 C            0                                         !       x > 1
5589 C
5590 C where x=(rij-r0ij)/delta
5591 C
5592 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5593 C
5594       implicit none
5595       double precision rij,r0ij,eps0ij,fcont,fprimcont
5596       double precision x,x2,x4,delta
5597 c     delta=0.02D0*r0ij
5598 c      delta=0.2D0*r0ij
5599       x=(rij-r0ij)/delta
5600       if (x.lt.-1.0D0) then
5601         fcont=eps0ij
5602         fprimcont=0.0D0
5603       else if (x.le.1.0D0) then
5604         x2=x*x
5605         x4=x2*x2
5606         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5607         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5608       else
5609         fcont=0.0D0
5610         fprimcont=0.0D0
5611       endif
5612       return
5613       end
5614 c------------------------------------------------------------------------------
5615       subroutine splinthet(theti,delta,ss,ssder)
5616       implicit real*8 (a-h,o-z)
5617       include 'DIMENSIONS'
5618       include 'COMMON.VAR'
5619       include 'COMMON.GEO'
5620       thetup=pi-delta
5621       thetlow=delta
5622       if (theti.gt.pipol) then
5623         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5624       else
5625         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5626         ssder=-ssder
5627       endif
5628       return
5629       end
5630 c------------------------------------------------------------------------------
5631       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5632       implicit none
5633       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5634       double precision ksi,ksi2,ksi3,a1,a2,a3
5635       a1=fprim0*delta/(f1-f0)
5636       a2=3.0d0-2.0d0*a1
5637       a3=a1-2.0d0
5638       ksi=(x-x0)/delta
5639       ksi2=ksi*ksi
5640       ksi3=ksi2*ksi
5641       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5642       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5643       return
5644       end
5645 c------------------------------------------------------------------------------
5646       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5647       implicit none
5648       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5649       double precision ksi,ksi2,ksi3,a1,a2,a3
5650       ksi=(x-x0)/delta
5651       ksi2=ksi*ksi
5652       ksi3=ksi2*ksi
5653       a1=fprim0x*delta
5654       a2=3*(f1x-f0x)-2*fprim0x*delta
5655       a3=fprim0x*delta-2*(f1x-f0x)
5656       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5657       return
5658       end
5659 C-----------------------------------------------------------------------------
5660 #ifdef CRYST_TOR
5661 C-----------------------------------------------------------------------------
5662       subroutine etor(etors,edihcnstr)
5663       implicit real*8 (a-h,o-z)
5664       include 'DIMENSIONS'
5665       include 'COMMON.VAR'
5666       include 'COMMON.GEO'
5667       include 'COMMON.LOCAL'
5668       include 'COMMON.TORSION'
5669       include 'COMMON.INTERACT'
5670       include 'COMMON.DERIV'
5671       include 'COMMON.CHAIN'
5672       include 'COMMON.NAMES'
5673       include 'COMMON.IOUNITS'
5674       include 'COMMON.FFIELD'
5675       include 'COMMON.TORCNSTR'
5676       include 'COMMON.CONTROL'
5677       logical lprn
5678 C Set lprn=.true. for debugging
5679       lprn=.false.
5680 c      lprn=.true.
5681       etors=0.0D0
5682       do i=iphi_start,iphi_end
5683       etors_ii=0.0D0
5684         itori=itortyp(itype(i-2))
5685         itori1=itortyp(itype(i-1))
5686         phii=phi(i)
5687         gloci=0.0D0
5688 C Proline-Proline pair is a special case...
5689         if (itori.eq.3 .and. itori1.eq.3) then
5690           if (phii.gt.-dwapi3) then
5691             cosphi=dcos(3*phii)
5692             fac=1.0D0/(1.0D0-cosphi)
5693             etorsi=v1(1,3,3)*fac
5694             etorsi=etorsi+etorsi
5695             etors=etors+etorsi-v1(1,3,3)
5696             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5697             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5698           endif
5699           do j=1,3
5700             v1ij=v1(j+1,itori,itori1)
5701             v2ij=v2(j+1,itori,itori1)
5702             cosphi=dcos(j*phii)
5703             sinphi=dsin(j*phii)
5704             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5705             if (energy_dec) etors_ii=etors_ii+
5706      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5707             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5708           enddo
5709         else
5710           do j=1,nterm_old
5711             v1ij=v1(j,itori,itori1)
5712             v2ij=v2(j,itori,itori1)
5713             cosphi=dcos(j*phii)
5714             sinphi=dsin(j*phii)
5715             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5716             if (energy_dec) etors_ii=etors_ii+
5717      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5718             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5719           enddo
5720         endif
5721         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5722      &        'etor',i,etors_ii
5723         if (lprn)
5724      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5725      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5726      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5727         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5728         write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5729       enddo
5730 ! 6/20/98 - dihedral angle constraints
5731       edihcnstr=0.0d0
5732       do i=1,ndih_constr
5733         itori=idih_constr(i)
5734         phii=phi(itori)
5735         difi=phii-phi0(i)
5736         if (difi.gt.drange(i)) then
5737           difi=difi-drange(i)
5738           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5739           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5740         else if (difi.lt.-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         endif
5745 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5746 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5747       enddo
5748 !      write (iout,*) 'edihcnstr',edihcnstr
5749       return
5750       end
5751 c------------------------------------------------------------------------------
5752       subroutine etor_d(etors_d)
5753       etors_d=0.0d0
5754       return
5755       end
5756 c----------------------------------------------------------------------------
5757 #else
5758       subroutine etor(etors,edihcnstr)
5759       implicit real*8 (a-h,o-z)
5760       include 'DIMENSIONS'
5761       include 'COMMON.VAR'
5762       include 'COMMON.GEO'
5763       include 'COMMON.LOCAL'
5764       include 'COMMON.TORSION'
5765       include 'COMMON.INTERACT'
5766       include 'COMMON.DERIV'
5767       include 'COMMON.CHAIN'
5768       include 'COMMON.NAMES'
5769       include 'COMMON.IOUNITS'
5770       include 'COMMON.FFIELD'
5771       include 'COMMON.TORCNSTR'
5772       include 'COMMON.CONTROL'
5773       logical lprn
5774 C Set lprn=.true. for debugging
5775       lprn=.false.
5776 c     lprn=.true.
5777       etors=0.0D0
5778       do i=iphi_start,iphi_end
5779       etors_ii=0.0D0
5780         itori=itortyp(itype(i-2))
5781         itori1=itortyp(itype(i-1))
5782         phii=phi(i)
5783         gloci=0.0D0
5784 C Regular cosine and sine terms
5785         do j=1,nterm(itori,itori1)
5786           v1ij=v1(j,itori,itori1)
5787           v2ij=v2(j,itori,itori1)
5788           cosphi=dcos(j*phii)
5789           sinphi=dsin(j*phii)
5790           etors=etors+v1ij*cosphi+v2ij*sinphi
5791           if (energy_dec) etors_ii=etors_ii+
5792      &                v1ij*cosphi+v2ij*sinphi
5793           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5794         enddo
5795 C Lorentz terms
5796 C                         v1
5797 C  E = SUM ----------------------------------- - v1
5798 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5799 C
5800         cosphi=dcos(0.5d0*phii)
5801         sinphi=dsin(0.5d0*phii)
5802         do j=1,nlor(itori,itori1)
5803           vl1ij=vlor1(j,itori,itori1)
5804           vl2ij=vlor2(j,itori,itori1)
5805           vl3ij=vlor3(j,itori,itori1)
5806           pom=vl2ij*cosphi+vl3ij*sinphi
5807           pom1=1.0d0/(pom*pom+1.0d0)
5808           etors=etors+vl1ij*pom1
5809           if (energy_dec) etors_ii=etors_ii+
5810      &                vl1ij*pom1
5811           pom=-pom*pom1*pom1
5812           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5813         enddo
5814 C Subtract the constant term
5815         etors=etors-v0(itori,itori1)
5816           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5817      &         'etor',i,etors_ii-v0(itori,itori1)
5818         if (lprn)
5819      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5820      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5821      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5822         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5823 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5824       enddo
5825 ! 6/20/98 - dihedral angle constraints
5826       edihcnstr=0.0d0
5827 c      do i=1,ndih_constr
5828       do i=idihconstr_start,idihconstr_end
5829         itori=idih_constr(i)
5830         phii=phi(itori)
5831         difi=pinorm(phii-phi0(i))
5832         if (difi.gt.drange(i)) then
5833           difi=difi-drange(i)
5834           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5835           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5836         else if (difi.lt.-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
5841           difi=0.0
5842         endif
5843 c        write (iout,*) "gloci", gloc(i-3,icg)
5844 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5845 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5846 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5847       enddo
5848 cd       write (iout,*) 'edihcnstr',edihcnstr
5849       return
5850       end
5851 c----------------------------------------------------------------------------
5852       subroutine etor_d(etors_d)
5853 C 6/23/01 Compute double torsional energy
5854       implicit real*8 (a-h,o-z)
5855       include 'DIMENSIONS'
5856       include 'COMMON.VAR'
5857       include 'COMMON.GEO'
5858       include 'COMMON.LOCAL'
5859       include 'COMMON.TORSION'
5860       include 'COMMON.INTERACT'
5861       include 'COMMON.DERIV'
5862       include 'COMMON.CHAIN'
5863       include 'COMMON.NAMES'
5864       include 'COMMON.IOUNITS'
5865       include 'COMMON.FFIELD'
5866       include 'COMMON.TORCNSTR'
5867       logical lprn
5868 C Set lprn=.true. for debugging
5869       lprn=.false.
5870 c     lprn=.true.
5871       etors_d=0.0D0
5872       do i=iphid_start,iphid_end
5873         itori=itortyp(itype(i-2))
5874         itori1=itortyp(itype(i-1))
5875         itori2=itortyp(itype(i))
5876         phii=phi(i)
5877         phii1=phi(i+1)
5878         gloci1=0.0D0
5879         gloci2=0.0D0
5880         do j=1,ntermd_1(itori,itori1,itori2)
5881           v1cij=v1c(1,j,itori,itori1,itori2)
5882           v1sij=v1s(1,j,itori,itori1,itori2)
5883           v2cij=v1c(2,j,itori,itori1,itori2)
5884           v2sij=v1s(2,j,itori,itori1,itori2)
5885           cosphi1=dcos(j*phii)
5886           sinphi1=dsin(j*phii)
5887           cosphi2=dcos(j*phii1)
5888           sinphi2=dsin(j*phii1)
5889           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5890      &     v2cij*cosphi2+v2sij*sinphi2
5891           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5892           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5893         enddo
5894         do k=2,ntermd_2(itori,itori1,itori2)
5895           do l=1,k-1
5896             v1cdij = v2c(k,l,itori,itori1,itori2)
5897             v2cdij = v2c(l,k,itori,itori1,itori2)
5898             v1sdij = v2s(k,l,itori,itori1,itori2)
5899             v2sdij = v2s(l,k,itori,itori1,itori2)
5900             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5901             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5902             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5903             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5904             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5905      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5906             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5907      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5908             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5909      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5910           enddo
5911         enddo
5912         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5913         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5914 c        write (iout,*) "gloci", gloc(i-3,icg)
5915       enddo
5916       return
5917       end
5918 #endif
5919 c------------------------------------------------------------------------------
5920       subroutine eback_sc_corr(esccor)
5921 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5922 c        conformational states; temporarily implemented as differences
5923 c        between UNRES torsional potentials (dependent on three types of
5924 c        residues) and the torsional potentials dependent on all 20 types
5925 c        of residues computed from AM1  energy surfaces of terminally-blocked
5926 c        amino-acid residues.
5927       implicit real*8 (a-h,o-z)
5928       include 'DIMENSIONS'
5929       include 'COMMON.VAR'
5930       include 'COMMON.GEO'
5931       include 'COMMON.LOCAL'
5932       include 'COMMON.TORSION'
5933       include 'COMMON.SCCOR'
5934       include 'COMMON.INTERACT'
5935       include 'COMMON.DERIV'
5936       include 'COMMON.CHAIN'
5937       include 'COMMON.NAMES'
5938       include 'COMMON.IOUNITS'
5939       include 'COMMON.FFIELD'
5940       include 'COMMON.CONTROL'
5941       logical lprn
5942 C Set lprn=.true. for debugging
5943       lprn=.false.
5944 c      lprn=.true.
5945 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
5946       esccor=0.0D0
5947       do i=itau_start,itau_end
5948         esccor_ii=0.0D0
5949         isccori=isccortyp(itype(i-2))
5950         isccori1=isccortyp(itype(i-1))
5951         phii=phi(i)
5952 cccc  Added 9 May 2012
5953 cc Tauangle is torsional engle depending on the value of first digit
5954 c(see comment below)
5955 cc Omicron is flat angle depending on the value of first digit
5956 c(see comment below)
5957
5958
5959         do intertyp=1,3 !intertyp
5960 cc Added 09 May 2012 (Adasko)
5961 cc  Intertyp means interaction type of backbone mainchain correlation:
5962 c   1 = SC...Ca...Ca...Ca
5963 c   2 = Ca...Ca...Ca...SC
5964 c   3 = SC...Ca...Ca...SCi
5965         gloci=0.0D0
5966         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5967      &      (itype(i-1).eq.10).or.(itype(i-2).eq.21).or.
5968      &      (itype(i-1).eq.21)))
5969      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5970      &     .or.(itype(i-2).eq.21)))
5971      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5972      &      (itype(i-1).eq.21)))) cycle
5973         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle
5974         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21))
5975      & cycle
5976         do j=1,nterm_sccor(isccori,isccori1)
5977           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5978           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5979           cosphi=dcos(j*tauangle(intertyp,i))
5980           sinphi=dsin(j*tauangle(intertyp,i))
5981           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5982           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5983         enddo
5984         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5985 c        write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
5986 c     &gloc_sc(intertyp,i-3,icg)
5987         if (lprn)
5988      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5989      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5990      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
5991      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
5992         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5993        enddo !intertyp
5994       enddo
5995 c        do i=1,nres
5996 c        write (iout,*) "W@T@F",  gloc_sc(1,i,icg),gloc(i,icg)
5997 c        enddo
5998       return
5999       end
6000 c----------------------------------------------------------------------------
6001       subroutine multibody(ecorr)
6002 C This subroutine calculates multi-body contributions to energy following
6003 C the idea of Skolnick et al. If side chains I and J make a contact and
6004 C at the same time side chains I+1 and J+1 make a contact, an extra
6005 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6006       implicit real*8 (a-h,o-z)
6007       include 'DIMENSIONS'
6008       include 'COMMON.IOUNITS'
6009       include 'COMMON.DERIV'
6010       include 'COMMON.INTERACT'
6011       include 'COMMON.CONTACTS'
6012       double precision gx(3),gx1(3)
6013       logical lprn
6014
6015 C Set lprn=.true. for debugging
6016       lprn=.false.
6017
6018       if (lprn) then
6019         write (iout,'(a)') 'Contact function values:'
6020         do i=nnt,nct-2
6021           write (iout,'(i2,20(1x,i2,f10.5))')
6022      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6023         enddo
6024       endif
6025       ecorr=0.0D0
6026       do i=nnt,nct
6027         do j=1,3
6028           gradcorr(j,i)=0.0D0
6029           gradxorr(j,i)=0.0D0
6030         enddo
6031       enddo
6032       do i=nnt,nct-2
6033
6034         DO ISHIFT = 3,4
6035
6036         i1=i+ishift
6037         num_conti=num_cont(i)
6038         num_conti1=num_cont(i1)
6039         do jj=1,num_conti
6040           j=jcont(jj,i)
6041           do kk=1,num_conti1
6042             j1=jcont(kk,i1)
6043             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6044 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6045 cd   &                   ' ishift=',ishift
6046 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6047 C The system gains extra energy.
6048               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6049             endif   ! j1==j+-ishift
6050           enddo     ! kk
6051         enddo       ! jj
6052
6053         ENDDO ! ISHIFT
6054
6055       enddo         ! i
6056       return
6057       end
6058 c------------------------------------------------------------------------------
6059       double precision function esccorr(i,j,k,l,jj,kk)
6060       implicit real*8 (a-h,o-z)
6061       include 'DIMENSIONS'
6062       include 'COMMON.IOUNITS'
6063       include 'COMMON.DERIV'
6064       include 'COMMON.INTERACT'
6065       include 'COMMON.CONTACTS'
6066       double precision gx(3),gx1(3)
6067       logical lprn
6068       lprn=.false.
6069       eij=facont(jj,i)
6070       ekl=facont(kk,k)
6071 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6072 C Calculate the multi-body contribution to energy.
6073 C Calculate multi-body contributions to the gradient.
6074 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6075 cd   & k,l,(gacont(m,kk,k),m=1,3)
6076       do m=1,3
6077         gx(m) =ekl*gacont(m,jj,i)
6078         gx1(m)=eij*gacont(m,kk,k)
6079         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6080         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6081         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6082         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6083       enddo
6084       do m=i,j-1
6085         do ll=1,3
6086           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6087         enddo
6088       enddo
6089       do m=k,l-1
6090         do ll=1,3
6091           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6092         enddo
6093       enddo
6094       esccorr=-eij*ekl
6095       return
6096       end
6097 c------------------------------------------------------------------------------
6098       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6099 C This subroutine calculates multi-body contributions to hydrogen-bonding
6100       implicit real*8 (a-h,o-z)
6101       include 'DIMENSIONS'
6102       include 'COMMON.IOUNITS'
6103 #ifdef MPI
6104       include "mpif.h"
6105       parameter (max_cont=maxconts)
6106       parameter (max_dim=26)
6107       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6108       double precision zapas(max_dim,maxconts,max_fg_procs),
6109      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6110       common /przechowalnia/ zapas
6111       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6112      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6113 #endif
6114       include 'COMMON.SETUP'
6115       include 'COMMON.FFIELD'
6116       include 'COMMON.DERIV'
6117       include 'COMMON.INTERACT'
6118       include 'COMMON.CONTACTS'
6119       include 'COMMON.CONTROL'
6120       include 'COMMON.LOCAL'
6121       double precision gx(3),gx1(3),time00
6122       logical lprn,ldone
6123
6124 C Set lprn=.true. for debugging
6125       lprn=.false.
6126 #ifdef MPI
6127       n_corr=0
6128       n_corr1=0
6129       if (nfgtasks.le.1) goto 30
6130       if (lprn) then
6131         write (iout,'(a)') 'Contact function values before RECEIVE:'
6132         do i=nnt,nct-2
6133           write (iout,'(2i3,50(1x,i2,f5.2))')
6134      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6135      &    j=1,num_cont_hb(i))
6136         enddo
6137       endif
6138       call flush(iout)
6139       do i=1,ntask_cont_from
6140         ncont_recv(i)=0
6141       enddo
6142       do i=1,ntask_cont_to
6143         ncont_sent(i)=0
6144       enddo
6145 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6146 c     & ntask_cont_to
6147 C Make the list of contacts to send to send to other procesors
6148 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6149 c      call flush(iout)
6150       do i=iturn3_start,iturn3_end
6151 c        write (iout,*) "make contact list turn3",i," num_cont",
6152 c     &    num_cont_hb(i)
6153         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6154       enddo
6155       do i=iturn4_start,iturn4_end
6156 c        write (iout,*) "make contact list turn4",i," num_cont",
6157 c     &   num_cont_hb(i)
6158         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6159       enddo
6160       do ii=1,nat_sent
6161         i=iat_sent(ii)
6162 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6163 c     &    num_cont_hb(i)
6164         do j=1,num_cont_hb(i)
6165         do k=1,4
6166           jjc=jcont_hb(j,i)
6167           iproc=iint_sent_local(k,jjc,ii)
6168 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6169           if (iproc.gt.0) then
6170             ncont_sent(iproc)=ncont_sent(iproc)+1
6171             nn=ncont_sent(iproc)
6172             zapas(1,nn,iproc)=i
6173             zapas(2,nn,iproc)=jjc
6174             zapas(3,nn,iproc)=facont_hb(j,i)
6175             zapas(4,nn,iproc)=ees0p(j,i)
6176             zapas(5,nn,iproc)=ees0m(j,i)
6177             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6178             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6179             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6180             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6181             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6182             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6183             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6184             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6185             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6186             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6187             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6188             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6189             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6190             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6191             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6192             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6193             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6194             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6195             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6196             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6197             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6198           endif
6199         enddo
6200         enddo
6201       enddo
6202       if (lprn) then
6203       write (iout,*)
6204      &  "Numbers of contacts to be sent to other processors",
6205      &  (ncont_sent(i),i=1,ntask_cont_to)
6206       write (iout,*) "Contacts sent"
6207       do ii=1,ntask_cont_to
6208         nn=ncont_sent(ii)
6209         iproc=itask_cont_to(ii)
6210         write (iout,*) nn," contacts to processor",iproc,
6211      &   " of CONT_TO_COMM group"
6212         do i=1,nn
6213           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6214         enddo
6215       enddo
6216       call flush(iout)
6217       endif
6218       CorrelType=477
6219       CorrelID=fg_rank+1
6220       CorrelType1=478
6221       CorrelID1=nfgtasks+fg_rank+1
6222       ireq=0
6223 C Receive the numbers of needed contacts from other processors
6224       do ii=1,ntask_cont_from
6225         iproc=itask_cont_from(ii)
6226         ireq=ireq+1
6227         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6228      &    FG_COMM,req(ireq),IERR)
6229       enddo
6230 c      write (iout,*) "IRECV ended"
6231 c      call flush(iout)
6232 C Send the number of contacts needed by other processors
6233       do ii=1,ntask_cont_to
6234         iproc=itask_cont_to(ii)
6235         ireq=ireq+1
6236         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6237      &    FG_COMM,req(ireq),IERR)
6238       enddo
6239 c      write (iout,*) "ISEND ended"
6240 c      write (iout,*) "number of requests (nn)",ireq
6241       call flush(iout)
6242       if (ireq.gt.0)
6243      &  call MPI_Waitall(ireq,req,status_array,ierr)
6244 c      write (iout,*)
6245 c     &  "Numbers of contacts to be received from other processors",
6246 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6247 c      call flush(iout)
6248 C Receive contacts
6249       ireq=0
6250       do ii=1,ntask_cont_from
6251         iproc=itask_cont_from(ii)
6252         nn=ncont_recv(ii)
6253 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6254 c     &   " of CONT_TO_COMM group"
6255         call flush(iout)
6256         if (nn.gt.0) then
6257           ireq=ireq+1
6258           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6259      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6260 c          write (iout,*) "ireq,req",ireq,req(ireq)
6261         endif
6262       enddo
6263 C Send the contacts to processors that need them
6264       do ii=1,ntask_cont_to
6265         iproc=itask_cont_to(ii)
6266         nn=ncont_sent(ii)
6267 c        write (iout,*) nn," contacts to processor",iproc,
6268 c     &   " of CONT_TO_COMM group"
6269         if (nn.gt.0) then
6270           ireq=ireq+1
6271           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6272      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6273 c          write (iout,*) "ireq,req",ireq,req(ireq)
6274 c          do i=1,nn
6275 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6276 c          enddo
6277         endif
6278       enddo
6279 c      write (iout,*) "number of requests (contacts)",ireq
6280 c      write (iout,*) "req",(req(i),i=1,4)
6281 c      call flush(iout)
6282       if (ireq.gt.0)
6283      & call MPI_Waitall(ireq,req,status_array,ierr)
6284       do iii=1,ntask_cont_from
6285         iproc=itask_cont_from(iii)
6286         nn=ncont_recv(iii)
6287         if (lprn) then
6288         write (iout,*) "Received",nn," contacts from processor",iproc,
6289      &   " of CONT_FROM_COMM group"
6290         call flush(iout)
6291         do i=1,nn
6292           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6293         enddo
6294         call flush(iout)
6295         endif
6296         do i=1,nn
6297           ii=zapas_recv(1,i,iii)
6298 c Flag the received contacts to prevent double-counting
6299           jj=-zapas_recv(2,i,iii)
6300 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6301 c          call flush(iout)
6302           nnn=num_cont_hb(ii)+1
6303           num_cont_hb(ii)=nnn
6304           jcont_hb(nnn,ii)=jj
6305           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6306           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6307           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6308           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6309           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6310           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6311           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6312           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6313           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6314           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6315           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6316           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6317           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6318           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6319           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6320           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6321           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6322           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6323           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6324           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6325           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6326           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6327           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6328           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6329         enddo
6330       enddo
6331       call flush(iout)
6332       if (lprn) then
6333         write (iout,'(a)') 'Contact function values after receive:'
6334         do i=nnt,nct-2
6335           write (iout,'(2i3,50(1x,i3,f5.2))')
6336      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6337      &    j=1,num_cont_hb(i))
6338         enddo
6339         call flush(iout)
6340       endif
6341    30 continue
6342 #endif
6343       if (lprn) then
6344         write (iout,'(a)') 'Contact function values:'
6345         do i=nnt,nct-2
6346           write (iout,'(2i3,50(1x,i3,f5.2))')
6347      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6348      &    j=1,num_cont_hb(i))
6349         enddo
6350       endif
6351       ecorr=0.0D0
6352 C Remove the loop below after debugging !!!
6353       do i=nnt,nct
6354         do j=1,3
6355           gradcorr(j,i)=0.0D0
6356           gradxorr(j,i)=0.0D0
6357         enddo
6358       enddo
6359 C Calculate the local-electrostatic correlation terms
6360       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6361         i1=i+1
6362         num_conti=num_cont_hb(i)
6363         num_conti1=num_cont_hb(i+1)
6364         do jj=1,num_conti
6365           j=jcont_hb(jj,i)
6366           jp=iabs(j)
6367           do kk=1,num_conti1
6368             j1=jcont_hb(kk,i1)
6369             jp1=iabs(j1)
6370 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6371 c     &         ' jj=',jj,' kk=',kk
6372             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6373      &          .or. j.lt.0 .and. j1.gt.0) .and.
6374      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6375 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6376 C The system gains extra energy.
6377               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6378               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6379      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6380               n_corr=n_corr+1
6381             else if (j1.eq.j) then
6382 C Contacts I-J and I-(J+1) occur simultaneously.
6383 C The system loses extra energy.
6384 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6385             endif
6386           enddo ! kk
6387           do kk=1,num_conti
6388             j1=jcont_hb(kk,i)
6389 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6390 c    &         ' jj=',jj,' kk=',kk
6391             if (j1.eq.j+1) then
6392 C Contacts I-J and (I+1)-J occur simultaneously.
6393 C The system loses extra energy.
6394 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6395             endif ! j1==j+1
6396           enddo ! kk
6397         enddo ! jj
6398       enddo ! i
6399       return
6400       end
6401 c------------------------------------------------------------------------------
6402       subroutine add_hb_contact(ii,jj,itask)
6403       implicit real*8 (a-h,o-z)
6404       include "DIMENSIONS"
6405       include "COMMON.IOUNITS"
6406       integer max_cont
6407       integer max_dim
6408       parameter (max_cont=maxconts)
6409       parameter (max_dim=26)
6410       include "COMMON.CONTACTS"
6411       double precision zapas(max_dim,maxconts,max_fg_procs),
6412      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6413       common /przechowalnia/ zapas
6414       integer i,j,ii,jj,iproc,itask(4),nn
6415 c      write (iout,*) "itask",itask
6416       do i=1,2
6417         iproc=itask(i)
6418         if (iproc.gt.0) then
6419           do j=1,num_cont_hb(ii)
6420             jjc=jcont_hb(j,ii)
6421 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6422             if (jjc.eq.jj) then
6423               ncont_sent(iproc)=ncont_sent(iproc)+1
6424               nn=ncont_sent(iproc)
6425               zapas(1,nn,iproc)=ii
6426               zapas(2,nn,iproc)=jjc
6427               zapas(3,nn,iproc)=facont_hb(j,ii)
6428               zapas(4,nn,iproc)=ees0p(j,ii)
6429               zapas(5,nn,iproc)=ees0m(j,ii)
6430               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6431               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6432               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6433               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6434               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6435               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6436               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6437               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6438               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6439               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6440               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6441               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6442               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6443               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6444               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6445               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6446               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6447               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6448               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6449               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6450               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6451               exit
6452             endif
6453           enddo
6454         endif
6455       enddo
6456       return
6457       end
6458 c------------------------------------------------------------------------------
6459       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6460      &  n_corr1)
6461 C This subroutine calculates multi-body contributions to hydrogen-bonding
6462       implicit real*8 (a-h,o-z)
6463       include 'DIMENSIONS'
6464       include 'COMMON.IOUNITS'
6465 #ifdef MPI
6466       include "mpif.h"
6467       parameter (max_cont=maxconts)
6468       parameter (max_dim=70)
6469       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6470       double precision zapas(max_dim,maxconts,max_fg_procs),
6471      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6472       common /przechowalnia/ zapas
6473       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6474      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6475 #endif
6476       include 'COMMON.SETUP'
6477       include 'COMMON.FFIELD'
6478       include 'COMMON.DERIV'
6479       include 'COMMON.LOCAL'
6480       include 'COMMON.INTERACT'
6481       include 'COMMON.CONTACTS'
6482       include 'COMMON.CHAIN'
6483       include 'COMMON.CONTROL'
6484       double precision gx(3),gx1(3)
6485       integer num_cont_hb_old(maxres)
6486       logical lprn,ldone
6487       double precision eello4,eello5,eelo6,eello_turn6
6488       external eello4,eello5,eello6,eello_turn6
6489 C Set lprn=.true. for debugging
6490       lprn=.false.
6491       eturn6=0.0d0
6492 #ifdef MPI
6493       do i=1,nres
6494         num_cont_hb_old(i)=num_cont_hb(i)
6495       enddo
6496       n_corr=0
6497       n_corr1=0
6498       if (nfgtasks.le.1) goto 30
6499       if (lprn) then
6500         write (iout,'(a)') 'Contact function values before RECEIVE:'
6501         do i=nnt,nct-2
6502           write (iout,'(2i3,50(1x,i2,f5.2))')
6503      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6504      &    j=1,num_cont_hb(i))
6505         enddo
6506       endif
6507       call flush(iout)
6508       do i=1,ntask_cont_from
6509         ncont_recv(i)=0
6510       enddo
6511       do i=1,ntask_cont_to
6512         ncont_sent(i)=0
6513       enddo
6514 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6515 c     & ntask_cont_to
6516 C Make the list of contacts to send to send to other procesors
6517       do i=iturn3_start,iturn3_end
6518 c        write (iout,*) "make contact list turn3",i," num_cont",
6519 c     &    num_cont_hb(i)
6520         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6521       enddo
6522       do i=iturn4_start,iturn4_end
6523 c        write (iout,*) "make contact list turn4",i," num_cont",
6524 c     &   num_cont_hb(i)
6525         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6526       enddo
6527       do ii=1,nat_sent
6528         i=iat_sent(ii)
6529 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6530 c     &    num_cont_hb(i)
6531         do j=1,num_cont_hb(i)
6532         do k=1,4
6533           jjc=jcont_hb(j,i)
6534           iproc=iint_sent_local(k,jjc,ii)
6535 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6536           if (iproc.ne.0) then
6537             ncont_sent(iproc)=ncont_sent(iproc)+1
6538             nn=ncont_sent(iproc)
6539             zapas(1,nn,iproc)=i
6540             zapas(2,nn,iproc)=jjc
6541             zapas(3,nn,iproc)=d_cont(j,i)
6542             ind=3
6543             do kk=1,3
6544               ind=ind+1
6545               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6546             enddo
6547             do kk=1,2
6548               do ll=1,2
6549                 ind=ind+1
6550                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6551               enddo
6552             enddo
6553             do jj=1,5
6554               do kk=1,3
6555                 do ll=1,2
6556                   do mm=1,2
6557                     ind=ind+1
6558                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6559                   enddo
6560                 enddo
6561               enddo
6562             enddo
6563           endif
6564         enddo
6565         enddo
6566       enddo
6567       if (lprn) then
6568       write (iout,*)
6569      &  "Numbers of contacts to be sent to other processors",
6570      &  (ncont_sent(i),i=1,ntask_cont_to)
6571       write (iout,*) "Contacts sent"
6572       do ii=1,ntask_cont_to
6573         nn=ncont_sent(ii)
6574         iproc=itask_cont_to(ii)
6575         write (iout,*) nn," contacts to processor",iproc,
6576      &   " of CONT_TO_COMM group"
6577         do i=1,nn
6578           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6579         enddo
6580       enddo
6581       call flush(iout)
6582       endif
6583       CorrelType=477
6584       CorrelID=fg_rank+1
6585       CorrelType1=478
6586       CorrelID1=nfgtasks+fg_rank+1
6587       ireq=0
6588 C Receive the numbers of needed contacts from other processors
6589       do ii=1,ntask_cont_from
6590         iproc=itask_cont_from(ii)
6591         ireq=ireq+1
6592         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6593      &    FG_COMM,req(ireq),IERR)
6594       enddo
6595 c      write (iout,*) "IRECV ended"
6596 c      call flush(iout)
6597 C Send the number of contacts needed by other processors
6598       do ii=1,ntask_cont_to
6599         iproc=itask_cont_to(ii)
6600         ireq=ireq+1
6601         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6602      &    FG_COMM,req(ireq),IERR)
6603       enddo
6604 c      write (iout,*) "ISEND ended"
6605 c      write (iout,*) "number of requests (nn)",ireq
6606       call flush(iout)
6607       if (ireq.gt.0)
6608      &  call MPI_Waitall(ireq,req,status_array,ierr)
6609 c      write (iout,*)
6610 c     &  "Numbers of contacts to be received from other processors",
6611 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6612 c      call flush(iout)
6613 C Receive contacts
6614       ireq=0
6615       do ii=1,ntask_cont_from
6616         iproc=itask_cont_from(ii)
6617         nn=ncont_recv(ii)
6618 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6619 c     &   " of CONT_TO_COMM group"
6620         call flush(iout)
6621         if (nn.gt.0) then
6622           ireq=ireq+1
6623           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6624      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6625 c          write (iout,*) "ireq,req",ireq,req(ireq)
6626         endif
6627       enddo
6628 C Send the contacts to processors that need them
6629       do ii=1,ntask_cont_to
6630         iproc=itask_cont_to(ii)
6631         nn=ncont_sent(ii)
6632 c        write (iout,*) nn," contacts to processor",iproc,
6633 c     &   " of CONT_TO_COMM group"
6634         if (nn.gt.0) then
6635           ireq=ireq+1
6636           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6637      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6638 c          write (iout,*) "ireq,req",ireq,req(ireq)
6639 c          do i=1,nn
6640 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6641 c          enddo
6642         endif
6643       enddo
6644 c      write (iout,*) "number of requests (contacts)",ireq
6645 c      write (iout,*) "req",(req(i),i=1,4)
6646 c      call flush(iout)
6647       if (ireq.gt.0)
6648      & call MPI_Waitall(ireq,req,status_array,ierr)
6649       do iii=1,ntask_cont_from
6650         iproc=itask_cont_from(iii)
6651         nn=ncont_recv(iii)
6652         if (lprn) then
6653         write (iout,*) "Received",nn," contacts from processor",iproc,
6654      &   " of CONT_FROM_COMM group"
6655         call flush(iout)
6656         do i=1,nn
6657           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6658         enddo
6659         call flush(iout)
6660         endif
6661         do i=1,nn
6662           ii=zapas_recv(1,i,iii)
6663 c Flag the received contacts to prevent double-counting
6664           jj=-zapas_recv(2,i,iii)
6665 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6666 c          call flush(iout)
6667           nnn=num_cont_hb(ii)+1
6668           num_cont_hb(ii)=nnn
6669           jcont_hb(nnn,ii)=jj
6670           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6671           ind=3
6672           do kk=1,3
6673             ind=ind+1
6674             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6675           enddo
6676           do kk=1,2
6677             do ll=1,2
6678               ind=ind+1
6679               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6680             enddo
6681           enddo
6682           do jj=1,5
6683             do kk=1,3
6684               do ll=1,2
6685                 do mm=1,2
6686                   ind=ind+1
6687                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6688                 enddo
6689               enddo
6690             enddo
6691           enddo
6692         enddo
6693       enddo
6694       call flush(iout)
6695       if (lprn) then
6696         write (iout,'(a)') 'Contact function values after receive:'
6697         do i=nnt,nct-2
6698           write (iout,'(2i3,50(1x,i3,5f6.3))')
6699      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6700      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6701         enddo
6702         call flush(iout)
6703       endif
6704    30 continue
6705 #endif
6706       if (lprn) then
6707         write (iout,'(a)') 'Contact function values:'
6708         do i=nnt,nct-2
6709           write (iout,'(2i3,50(1x,i2,5f6.3))')
6710      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6711      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6712         enddo
6713       endif
6714       ecorr=0.0D0
6715       ecorr5=0.0d0
6716       ecorr6=0.0d0
6717 C Remove the loop below after debugging !!!
6718       do i=nnt,nct
6719         do j=1,3
6720           gradcorr(j,i)=0.0D0
6721           gradxorr(j,i)=0.0D0
6722         enddo
6723       enddo
6724 C Calculate the dipole-dipole interaction energies
6725       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6726       do i=iatel_s,iatel_e+1
6727         num_conti=num_cont_hb(i)
6728         do jj=1,num_conti
6729           j=jcont_hb(jj,i)
6730 #ifdef MOMENT
6731           call dipole(i,j,jj)
6732 #endif
6733         enddo
6734       enddo
6735       endif
6736 C Calculate the local-electrostatic correlation terms
6737 c                write (iout,*) "gradcorr5 in eello5 before loop"
6738 c                do iii=1,nres
6739 c                  write (iout,'(i5,3f10.5)')
6740 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6741 c                enddo
6742       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6743 c        write (iout,*) "corr loop i",i
6744         i1=i+1
6745         num_conti=num_cont_hb(i)
6746         num_conti1=num_cont_hb(i+1)
6747         do jj=1,num_conti
6748           j=jcont_hb(jj,i)
6749           jp=iabs(j)
6750           do kk=1,num_conti1
6751             j1=jcont_hb(kk,i1)
6752             jp1=iabs(j1)
6753 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6754 c     &         ' jj=',jj,' kk=',kk
6755 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6756             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6757      &          .or. j.lt.0 .and. j1.gt.0) .and.
6758      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6759 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6760 C The system gains extra energy.
6761               n_corr=n_corr+1
6762               sqd1=dsqrt(d_cont(jj,i))
6763               sqd2=dsqrt(d_cont(kk,i1))
6764               sred_geom = sqd1*sqd2
6765               IF (sred_geom.lt.cutoff_corr) THEN
6766                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6767      &            ekont,fprimcont)
6768 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6769 cd     &         ' jj=',jj,' kk=',kk
6770                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6771                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6772                 do l=1,3
6773                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6774                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6775                 enddo
6776                 n_corr1=n_corr1+1
6777 cd               write (iout,*) 'sred_geom=',sred_geom,
6778 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6779 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6780 cd               write (iout,*) "g_contij",g_contij
6781 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6782 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6783                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6784                 if (wcorr4.gt.0.0d0)
6785      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6786                   if (energy_dec.and.wcorr4.gt.0.0d0)
6787      1                 write (iout,'(a6,4i5,0pf7.3)')
6788      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6789 c                write (iout,*) "gradcorr5 before eello5"
6790 c                do iii=1,nres
6791 c                  write (iout,'(i5,3f10.5)')
6792 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6793 c                enddo
6794                 if (wcorr5.gt.0.0d0)
6795      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6796 c                write (iout,*) "gradcorr5 after eello5"
6797 c                do iii=1,nres
6798 c                  write (iout,'(i5,3f10.5)')
6799 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6800 c                enddo
6801                   if (energy_dec.and.wcorr5.gt.0.0d0)
6802      1                 write (iout,'(a6,4i5,0pf7.3)')
6803      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6804 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6805 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6806                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6807      &               .or. wturn6.eq.0.0d0))then
6808 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6809                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6810                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6811      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6812 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6813 cd     &            'ecorr6=',ecorr6
6814 cd                write (iout,'(4e15.5)') sred_geom,
6815 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6816 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6817 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6818                 else if (wturn6.gt.0.0d0
6819      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6820 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6821                   eturn6=eturn6+eello_turn6(i,jj,kk)
6822                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6823      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6824 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6825                 endif
6826               ENDIF
6827 1111          continue
6828             endif
6829           enddo ! kk
6830         enddo ! jj
6831       enddo ! i
6832       do i=1,nres
6833         num_cont_hb(i)=num_cont_hb_old(i)
6834       enddo
6835 c                write (iout,*) "gradcorr5 in eello5"
6836 c                do iii=1,nres
6837 c                  write (iout,'(i5,3f10.5)')
6838 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6839 c                enddo
6840       return
6841       end
6842 c------------------------------------------------------------------------------
6843       subroutine add_hb_contact_eello(ii,jj,itask)
6844       implicit real*8 (a-h,o-z)
6845       include "DIMENSIONS"
6846       include "COMMON.IOUNITS"
6847       integer max_cont
6848       integer max_dim
6849       parameter (max_cont=maxconts)
6850       parameter (max_dim=70)
6851       include "COMMON.CONTACTS"
6852       double precision zapas(max_dim,maxconts,max_fg_procs),
6853      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6854       common /przechowalnia/ zapas
6855       integer i,j,ii,jj,iproc,itask(4),nn
6856 c      write (iout,*) "itask",itask
6857       do i=1,2
6858         iproc=itask(i)
6859         if (iproc.gt.0) then
6860           do j=1,num_cont_hb(ii)
6861             jjc=jcont_hb(j,ii)
6862 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6863             if (jjc.eq.jj) then
6864               ncont_sent(iproc)=ncont_sent(iproc)+1
6865               nn=ncont_sent(iproc)
6866               zapas(1,nn,iproc)=ii
6867               zapas(2,nn,iproc)=jjc
6868               zapas(3,nn,iproc)=d_cont(j,ii)
6869               ind=3
6870               do kk=1,3
6871                 ind=ind+1
6872                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6873               enddo
6874               do kk=1,2
6875                 do ll=1,2
6876                   ind=ind+1
6877                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6878                 enddo
6879               enddo
6880               do jj=1,5
6881                 do kk=1,3
6882                   do ll=1,2
6883                     do mm=1,2
6884                       ind=ind+1
6885                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6886                     enddo
6887                   enddo
6888                 enddo
6889               enddo
6890               exit
6891             endif
6892           enddo
6893         endif
6894       enddo
6895       return
6896       end
6897 c------------------------------------------------------------------------------
6898       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6899       implicit real*8 (a-h,o-z)
6900       include 'DIMENSIONS'
6901       include 'COMMON.IOUNITS'
6902       include 'COMMON.DERIV'
6903       include 'COMMON.INTERACT'
6904       include 'COMMON.CONTACTS'
6905       double precision gx(3),gx1(3)
6906       logical lprn
6907       lprn=.false.
6908       eij=facont_hb(jj,i)
6909       ekl=facont_hb(kk,k)
6910       ees0pij=ees0p(jj,i)
6911       ees0pkl=ees0p(kk,k)
6912       ees0mij=ees0m(jj,i)
6913       ees0mkl=ees0m(kk,k)
6914       ekont=eij*ekl
6915       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6916 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6917 C Following 4 lines for diagnostics.
6918 cd    ees0pkl=0.0D0
6919 cd    ees0pij=1.0D0
6920 cd    ees0mkl=0.0D0
6921 cd    ees0mij=1.0D0
6922 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6923 c     & 'Contacts ',i,j,
6924 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6925 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6926 c     & 'gradcorr_long'
6927 C Calculate the multi-body contribution to energy.
6928 c      ecorr=ecorr+ekont*ees
6929 C Calculate multi-body contributions to the gradient.
6930       coeffpees0pij=coeffp*ees0pij
6931       coeffmees0mij=coeffm*ees0mij
6932       coeffpees0pkl=coeffp*ees0pkl
6933       coeffmees0mkl=coeffm*ees0mkl
6934       do ll=1,3
6935 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6936         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6937      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6938      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6939         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6940      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6941      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6942 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6943         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6944      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6945      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6946         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6947      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6948      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6949         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6950      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6951      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6952         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6953         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6954         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6955      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6956      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6957         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6958         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6959 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6960       enddo
6961 c      write (iout,*)
6962 cgrad      do m=i+1,j-1
6963 cgrad        do ll=1,3
6964 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6965 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6966 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6967 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6968 cgrad        enddo
6969 cgrad      enddo
6970 cgrad      do m=k+1,l-1
6971 cgrad        do ll=1,3
6972 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6973 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6974 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6975 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6976 cgrad        enddo
6977 cgrad      enddo
6978 c      write (iout,*) "ehbcorr",ekont*ees
6979       ehbcorr=ekont*ees
6980       return
6981       end
6982 #ifdef MOMENT
6983 C---------------------------------------------------------------------------
6984       subroutine dipole(i,j,jj)
6985       implicit real*8 (a-h,o-z)
6986       include 'DIMENSIONS'
6987       include 'COMMON.IOUNITS'
6988       include 'COMMON.CHAIN'
6989       include 'COMMON.FFIELD'
6990       include 'COMMON.DERIV'
6991       include 'COMMON.INTERACT'
6992       include 'COMMON.CONTACTS'
6993       include 'COMMON.TORSION'
6994       include 'COMMON.VAR'
6995       include 'COMMON.GEO'
6996       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6997      &  auxmat(2,2)
6998       iti1 = itortyp(itype(i+1))
6999       if (j.lt.nres-1) then
7000         itj1 = itortyp(itype(j+1))
7001       else
7002         itj1=ntortyp+1
7003       endif
7004       do iii=1,2
7005         dipi(iii,1)=Ub2(iii,i)
7006         dipderi(iii)=Ub2der(iii,i)
7007         dipi(iii,2)=b1(iii,iti1)
7008         dipj(iii,1)=Ub2(iii,j)
7009         dipderj(iii)=Ub2der(iii,j)
7010         dipj(iii,2)=b1(iii,itj1)
7011       enddo
7012       kkk=0
7013       do iii=1,2
7014         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7015         do jjj=1,2
7016           kkk=kkk+1
7017           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7018         enddo
7019       enddo
7020       do kkk=1,5
7021         do lll=1,3
7022           mmm=0
7023           do iii=1,2
7024             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7025      &        auxvec(1))
7026             do jjj=1,2
7027               mmm=mmm+1
7028               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7029             enddo
7030           enddo
7031         enddo
7032       enddo
7033       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7034       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7035       do iii=1,2
7036         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7037       enddo
7038       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7039       do iii=1,2
7040         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7041       enddo
7042       return
7043       end
7044 #endif
7045 C---------------------------------------------------------------------------
7046       subroutine calc_eello(i,j,k,l,jj,kk)
7047 C
7048 C This subroutine computes matrices and vectors needed to calculate
7049 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7050 C
7051       implicit real*8 (a-h,o-z)
7052       include 'DIMENSIONS'
7053       include 'COMMON.IOUNITS'
7054       include 'COMMON.CHAIN'
7055       include 'COMMON.DERIV'
7056       include 'COMMON.INTERACT'
7057       include 'COMMON.CONTACTS'
7058       include 'COMMON.TORSION'
7059       include 'COMMON.VAR'
7060       include 'COMMON.GEO'
7061       include 'COMMON.FFIELD'
7062       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7063      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7064       logical lprn
7065       common /kutas/ lprn
7066 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7067 cd     & ' jj=',jj,' kk=',kk
7068 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7069 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7070 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7071       do iii=1,2
7072         do jjj=1,2
7073           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7074           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7075         enddo
7076       enddo
7077       call transpose2(aa1(1,1),aa1t(1,1))
7078       call transpose2(aa2(1,1),aa2t(1,1))
7079       do kkk=1,5
7080         do lll=1,3
7081           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7082      &      aa1tder(1,1,lll,kkk))
7083           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7084      &      aa2tder(1,1,lll,kkk))
7085         enddo
7086       enddo
7087       if (l.eq.j+1) then
7088 C parallel orientation of the two CA-CA-CA frames.
7089         if (i.gt.1) then
7090           iti=itortyp(itype(i))
7091         else
7092           iti=ntortyp+1
7093         endif
7094         itk1=itortyp(itype(k+1))
7095         itj=itortyp(itype(j))
7096         if (l.lt.nres-1) then
7097           itl1=itortyp(itype(l+1))
7098         else
7099           itl1=ntortyp+1
7100         endif
7101 C A1 kernel(j+1) A2T
7102 cd        do iii=1,2
7103 cd          write (iout,'(3f10.5,5x,3f10.5)')
7104 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7105 cd        enddo
7106         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7107      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7108      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7109 C Following matrices are needed only for 6-th order cumulants
7110         IF (wcorr6.gt.0.0d0) THEN
7111         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7112      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7113      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7114         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7115      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7116      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7117      &   ADtEAderx(1,1,1,1,1,1))
7118         lprn=.false.
7119         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7120      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7121      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7122      &   ADtEA1derx(1,1,1,1,1,1))
7123         ENDIF
7124 C End 6-th order cumulants
7125 cd        lprn=.false.
7126 cd        if (lprn) then
7127 cd        write (2,*) 'In calc_eello6'
7128 cd        do iii=1,2
7129 cd          write (2,*) 'iii=',iii
7130 cd          do kkk=1,5
7131 cd            write (2,*) 'kkk=',kkk
7132 cd            do jjj=1,2
7133 cd              write (2,'(3(2f10.5),5x)')
7134 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7135 cd            enddo
7136 cd          enddo
7137 cd        enddo
7138 cd        endif
7139         call transpose2(EUgder(1,1,k),auxmat(1,1))
7140         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7141         call transpose2(EUg(1,1,k),auxmat(1,1))
7142         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7143         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7144         do iii=1,2
7145           do kkk=1,5
7146             do lll=1,3
7147               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7148      &          EAEAderx(1,1,lll,kkk,iii,1))
7149             enddo
7150           enddo
7151         enddo
7152 C A1T kernel(i+1) A2
7153         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7154      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7155      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7156 C Following matrices are needed only for 6-th order cumulants
7157         IF (wcorr6.gt.0.0d0) THEN
7158         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7159      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7160      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7161         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7162      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7163      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7164      &   ADtEAderx(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.,DtUg2EUg(1,1,k),
7167      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7168      &   ADtEA1derx(1,1,1,1,1,2))
7169         ENDIF
7170 C End 6-th order cumulants
7171         call transpose2(EUgder(1,1,l),auxmat(1,1))
7172         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7173         call transpose2(EUg(1,1,l),auxmat(1,1))
7174         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7175         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7176         do iii=1,2
7177           do kkk=1,5
7178             do lll=1,3
7179               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7180      &          EAEAderx(1,1,lll,kkk,iii,2))
7181             enddo
7182           enddo
7183         enddo
7184 C AEAb1 and AEAb2
7185 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7186 C They are needed only when the fifth- or the sixth-order cumulants are
7187 C indluded.
7188         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7189         call transpose2(AEA(1,1,1),auxmat(1,1))
7190         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7191         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7192         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7193         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7194         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7195         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7196         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7197         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7198         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7199         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7200         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7201         call transpose2(AEA(1,1,2),auxmat(1,1))
7202         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7203         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7204         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7205         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7206         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7207         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7208         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7209         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7210         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7211         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7212         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7213 C Calculate the Cartesian derivatives of the vectors.
7214         do iii=1,2
7215           do kkk=1,5
7216             do lll=1,3
7217               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7218               call matvec2(auxmat(1,1),b1(1,iti),
7219      &          AEAb1derx(1,lll,kkk,iii,1,1))
7220               call matvec2(auxmat(1,1),Ub2(1,i),
7221      &          AEAb2derx(1,lll,kkk,iii,1,1))
7222               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7223      &          AEAb1derx(1,lll,kkk,iii,2,1))
7224               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7225      &          AEAb2derx(1,lll,kkk,iii,2,1))
7226               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7227               call matvec2(auxmat(1,1),b1(1,itj),
7228      &          AEAb1derx(1,lll,kkk,iii,1,2))
7229               call matvec2(auxmat(1,1),Ub2(1,j),
7230      &          AEAb2derx(1,lll,kkk,iii,1,2))
7231               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7232      &          AEAb1derx(1,lll,kkk,iii,2,2))
7233               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7234      &          AEAb2derx(1,lll,kkk,iii,2,2))
7235             enddo
7236           enddo
7237         enddo
7238         ENDIF
7239 C End vectors
7240       else
7241 C Antiparallel orientation of the two CA-CA-CA frames.
7242         if (i.gt.1) then
7243           iti=itortyp(itype(i))
7244         else
7245           iti=ntortyp+1
7246         endif
7247         itk1=itortyp(itype(k+1))
7248         itl=itortyp(itype(l))
7249         itj=itortyp(itype(j))
7250         if (j.lt.nres-1) then
7251           itj1=itortyp(itype(j+1))
7252         else
7253           itj1=ntortyp+1
7254         endif
7255 C A2 kernel(j-1)T A1T
7256         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7257      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7258      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7259 C Following matrices are needed only for 6-th order cumulants
7260         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7261      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7262         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7263      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7264      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7265         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7266      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7267      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7268      &   ADtEAderx(1,1,1,1,1,1))
7269         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7270      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7271      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7272      &   ADtEA1derx(1,1,1,1,1,1))
7273         ENDIF
7274 C End 6-th order cumulants
7275         call transpose2(EUgder(1,1,k),auxmat(1,1))
7276         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7277         call transpose2(EUg(1,1,k),auxmat(1,1))
7278         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7279         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7280         do iii=1,2
7281           do kkk=1,5
7282             do lll=1,3
7283               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7284      &          EAEAderx(1,1,lll,kkk,iii,1))
7285             enddo
7286           enddo
7287         enddo
7288 C A2T kernel(i+1)T A1
7289         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7290      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7291      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7292 C Following matrices are needed only for 6-th order cumulants
7293         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7294      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7295         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7296      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7297      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7298         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7299      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7300      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7301      &   ADtEAderx(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.,DtUg2EUg(1,1,k),
7304      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7305      &   ADtEA1derx(1,1,1,1,1,2))
7306         ENDIF
7307 C End 6-th order cumulants
7308         call transpose2(EUgder(1,1,j),auxmat(1,1))
7309         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7310         call transpose2(EUg(1,1,j),auxmat(1,1))
7311         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7312         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7313         do iii=1,2
7314           do kkk=1,5
7315             do lll=1,3
7316               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7317      &          EAEAderx(1,1,lll,kkk,iii,2))
7318             enddo
7319           enddo
7320         enddo
7321 C AEAb1 and AEAb2
7322 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7323 C They are needed only when the fifth- or the sixth-order cumulants are
7324 C indluded.
7325         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7326      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7327         call transpose2(AEA(1,1,1),auxmat(1,1))
7328         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7329         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7330         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7331         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7332         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7333         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7334         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7335         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7336         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7337         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7338         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7339         call transpose2(AEA(1,1,2),auxmat(1,1))
7340         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7341         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7342         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7343         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7344         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7345         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7346         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7347         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7348         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7349         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7350         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7351 C Calculate the Cartesian derivatives of the vectors.
7352         do iii=1,2
7353           do kkk=1,5
7354             do lll=1,3
7355               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7356               call matvec2(auxmat(1,1),b1(1,iti),
7357      &          AEAb1derx(1,lll,kkk,iii,1,1))
7358               call matvec2(auxmat(1,1),Ub2(1,i),
7359      &          AEAb2derx(1,lll,kkk,iii,1,1))
7360               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7361      &          AEAb1derx(1,lll,kkk,iii,2,1))
7362               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7363      &          AEAb2derx(1,lll,kkk,iii,2,1))
7364               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7365               call matvec2(auxmat(1,1),b1(1,itl),
7366      &          AEAb1derx(1,lll,kkk,iii,1,2))
7367               call matvec2(auxmat(1,1),Ub2(1,l),
7368      &          AEAb2derx(1,lll,kkk,iii,1,2))
7369               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7370      &          AEAb1derx(1,lll,kkk,iii,2,2))
7371               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7372      &          AEAb2derx(1,lll,kkk,iii,2,2))
7373             enddo
7374           enddo
7375         enddo
7376         ENDIF
7377 C End vectors
7378       endif
7379       return
7380       end
7381 C---------------------------------------------------------------------------
7382       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7383      &  KK,KKderg,AKA,AKAderg,AKAderx)
7384       implicit none
7385       integer nderg
7386       logical transp
7387       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7388      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7389      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7390       integer iii,kkk,lll
7391       integer jjj,mmm
7392       logical lprn
7393       common /kutas/ lprn
7394       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7395       do iii=1,nderg
7396         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7397      &    AKAderg(1,1,iii))
7398       enddo
7399 cd      if (lprn) write (2,*) 'In kernel'
7400       do kkk=1,5
7401 cd        if (lprn) write (2,*) 'kkk=',kkk
7402         do lll=1,3
7403           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7404      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7405 cd          if (lprn) then
7406 cd            write (2,*) 'lll=',lll
7407 cd            write (2,*) 'iii=1'
7408 cd            do jjj=1,2
7409 cd              write (2,'(3(2f10.5),5x)')
7410 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7411 cd            enddo
7412 cd          endif
7413           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7414      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7415 cd          if (lprn) then
7416 cd            write (2,*) 'lll=',lll
7417 cd            write (2,*) 'iii=2'
7418 cd            do jjj=1,2
7419 cd              write (2,'(3(2f10.5),5x)')
7420 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7421 cd            enddo
7422 cd          endif
7423         enddo
7424       enddo
7425       return
7426       end
7427 C---------------------------------------------------------------------------
7428       double precision function eello4(i,j,k,l,jj,kk)
7429       implicit real*8 (a-h,o-z)
7430       include 'DIMENSIONS'
7431       include 'COMMON.IOUNITS'
7432       include 'COMMON.CHAIN'
7433       include 'COMMON.DERIV'
7434       include 'COMMON.INTERACT'
7435       include 'COMMON.CONTACTS'
7436       include 'COMMON.TORSION'
7437       include 'COMMON.VAR'
7438       include 'COMMON.GEO'
7439       double precision pizda(2,2),ggg1(3),ggg2(3)
7440 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7441 cd        eello4=0.0d0
7442 cd        return
7443 cd      endif
7444 cd      print *,'eello4:',i,j,k,l,jj,kk
7445 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7446 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7447 cold      eij=facont_hb(jj,i)
7448 cold      ekl=facont_hb(kk,k)
7449 cold      ekont=eij*ekl
7450       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7451 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7452       gcorr_loc(k-1)=gcorr_loc(k-1)
7453      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7454       if (l.eq.j+1) then
7455         gcorr_loc(l-1)=gcorr_loc(l-1)
7456      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7457       else
7458         gcorr_loc(j-1)=gcorr_loc(j-1)
7459      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7460       endif
7461       do iii=1,2
7462         do kkk=1,5
7463           do lll=1,3
7464             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7465      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7466 cd            derx(lll,kkk,iii)=0.0d0
7467           enddo
7468         enddo
7469       enddo
7470 cd      gcorr_loc(l-1)=0.0d0
7471 cd      gcorr_loc(j-1)=0.0d0
7472 cd      gcorr_loc(k-1)=0.0d0
7473 cd      eel4=1.0d0
7474 cd      write (iout,*)'Contacts have occurred for peptide groups',
7475 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7476 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7477       if (j.lt.nres-1) then
7478         j1=j+1
7479         j2=j-1
7480       else
7481         j1=j-1
7482         j2=j-2
7483       endif
7484       if (l.lt.nres-1) then
7485         l1=l+1
7486         l2=l-1
7487       else
7488         l1=l-1
7489         l2=l-2
7490       endif
7491       do ll=1,3
7492 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7493 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7494         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7495         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7496 cgrad        ghalf=0.5d0*ggg1(ll)
7497         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7498         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7499         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7500         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7501         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7502         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7503 cgrad        ghalf=0.5d0*ggg2(ll)
7504         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7505         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7506         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7507         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7508         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7509         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7510       enddo
7511 cgrad      do m=i+1,j-1
7512 cgrad        do ll=1,3
7513 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7514 cgrad        enddo
7515 cgrad      enddo
7516 cgrad      do m=k+1,l-1
7517 cgrad        do ll=1,3
7518 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7519 cgrad        enddo
7520 cgrad      enddo
7521 cgrad      do m=i+2,j2
7522 cgrad        do ll=1,3
7523 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7524 cgrad        enddo
7525 cgrad      enddo
7526 cgrad      do m=k+2,l2
7527 cgrad        do ll=1,3
7528 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7529 cgrad        enddo
7530 cgrad      enddo
7531 cd      do iii=1,nres-3
7532 cd        write (2,*) iii,gcorr_loc(iii)
7533 cd      enddo
7534       eello4=ekont*eel4
7535 cd      write (2,*) 'ekont',ekont
7536 cd      write (iout,*) 'eello4',ekont*eel4
7537       return
7538       end
7539 C---------------------------------------------------------------------------
7540       double precision function eello5(i,j,k,l,jj,kk)
7541       implicit real*8 (a-h,o-z)
7542       include 'DIMENSIONS'
7543       include 'COMMON.IOUNITS'
7544       include 'COMMON.CHAIN'
7545       include 'COMMON.DERIV'
7546       include 'COMMON.INTERACT'
7547       include 'COMMON.CONTACTS'
7548       include 'COMMON.TORSION'
7549       include 'COMMON.VAR'
7550       include 'COMMON.GEO'
7551       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7552       double precision ggg1(3),ggg2(3)
7553 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7554 C                                                                              C
7555 C                            Parallel chains                                   C
7556 C                                                                              C
7557 C          o             o                   o             o                   C
7558 C         /l\           / \             \   / \           / \   /              C
7559 C        /   \         /   \             \ /   \         /   \ /               C
7560 C       j| o |l1       | o |              o| o |         | o |o                C
7561 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7562 C      \i/   \         /   \ /             /   \         /   \                 C
7563 C       o    k1             o                                                  C
7564 C         (I)          (II)                (III)          (IV)                 C
7565 C                                                                              C
7566 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7567 C                                                                              C
7568 C                            Antiparallel chains                               C
7569 C                                                                              C
7570 C          o             o                   o             o                   C
7571 C         /j\           / \             \   / \           / \   /              C
7572 C        /   \         /   \             \ /   \         /   \ /               C
7573 C      j1| o |l        | o |              o| o |         | o |o                C
7574 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7575 C      \i/   \         /   \ /             /   \         /   \                 C
7576 C       o     k1            o                                                  C
7577 C         (I)          (II)                (III)          (IV)                 C
7578 C                                                                              C
7579 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7580 C                                                                              C
7581 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7582 C                                                                              C
7583 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7584 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7585 cd        eello5=0.0d0
7586 cd        return
7587 cd      endif
7588 cd      write (iout,*)
7589 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7590 cd     &   ' and',k,l
7591       itk=itortyp(itype(k))
7592       itl=itortyp(itype(l))
7593       itj=itortyp(itype(j))
7594       eello5_1=0.0d0
7595       eello5_2=0.0d0
7596       eello5_3=0.0d0
7597       eello5_4=0.0d0
7598 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7599 cd     &   eel5_3_num,eel5_4_num)
7600       do iii=1,2
7601         do kkk=1,5
7602           do lll=1,3
7603             derx(lll,kkk,iii)=0.0d0
7604           enddo
7605         enddo
7606       enddo
7607 cd      eij=facont_hb(jj,i)
7608 cd      ekl=facont_hb(kk,k)
7609 cd      ekont=eij*ekl
7610 cd      write (iout,*)'Contacts have occurred for peptide groups',
7611 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7612 cd      goto 1111
7613 C Contribution from the graph I.
7614 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7615 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7616       call transpose2(EUg(1,1,k),auxmat(1,1))
7617       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7618       vv(1)=pizda(1,1)-pizda(2,2)
7619       vv(2)=pizda(1,2)+pizda(2,1)
7620       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7621      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7622 C Explicit gradient in virtual-dihedral angles.
7623       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7624      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7625      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7626       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7627       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7628       vv(1)=pizda(1,1)-pizda(2,2)
7629       vv(2)=pizda(1,2)+pizda(2,1)
7630       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7631      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7632      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7633       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7634       vv(1)=pizda(1,1)-pizda(2,2)
7635       vv(2)=pizda(1,2)+pizda(2,1)
7636       if (l.eq.j+1) then
7637         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7638      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7639      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7640       else
7641         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7642      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7643      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7644       endif
7645 C Cartesian gradient
7646       do iii=1,2
7647         do kkk=1,5
7648           do lll=1,3
7649             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7650      &        pizda(1,1))
7651             vv(1)=pizda(1,1)-pizda(2,2)
7652             vv(2)=pizda(1,2)+pizda(2,1)
7653             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7654      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7655      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7656           enddo
7657         enddo
7658       enddo
7659 c      goto 1112
7660 c1111  continue
7661 C Contribution from graph II
7662       call transpose2(EE(1,1,itk),auxmat(1,1))
7663       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7664       vv(1)=pizda(1,1)+pizda(2,2)
7665       vv(2)=pizda(2,1)-pizda(1,2)
7666       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7667      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7668 C Explicit gradient in virtual-dihedral angles.
7669       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7670      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7671       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7672       vv(1)=pizda(1,1)+pizda(2,2)
7673       vv(2)=pizda(2,1)-pizda(1,2)
7674       if (l.eq.j+1) then
7675         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7676      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7677      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7678       else
7679         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7680      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7681      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7682       endif
7683 C Cartesian gradient
7684       do iii=1,2
7685         do kkk=1,5
7686           do lll=1,3
7687             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7688      &        pizda(1,1))
7689             vv(1)=pizda(1,1)+pizda(2,2)
7690             vv(2)=pizda(2,1)-pizda(1,2)
7691             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7692      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7693      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7694           enddo
7695         enddo
7696       enddo
7697 cd      goto 1112
7698 cd1111  continue
7699       if (l.eq.j+1) then
7700 cd        goto 1110
7701 C Parallel orientation
7702 C Contribution from graph III
7703         call transpose2(EUg(1,1,l),auxmat(1,1))
7704         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7705         vv(1)=pizda(1,1)-pizda(2,2)
7706         vv(2)=pizda(1,2)+pizda(2,1)
7707         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7708      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7709 C Explicit gradient in virtual-dihedral angles.
7710         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7711      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7712      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7713         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7714         vv(1)=pizda(1,1)-pizda(2,2)
7715         vv(2)=pizda(1,2)+pizda(2,1)
7716         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7717      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7718      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7719         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7720         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7721         vv(1)=pizda(1,1)-pizda(2,2)
7722         vv(2)=pizda(1,2)+pizda(2,1)
7723         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7724      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7725      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7726 C Cartesian gradient
7727         do iii=1,2
7728           do kkk=1,5
7729             do lll=1,3
7730               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7731      &          pizda(1,1))
7732               vv(1)=pizda(1,1)-pizda(2,2)
7733               vv(2)=pizda(1,2)+pizda(2,1)
7734               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7735      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7736      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7737             enddo
7738           enddo
7739         enddo
7740 cd        goto 1112
7741 C Contribution from graph IV
7742 cd1110    continue
7743         call transpose2(EE(1,1,itl),auxmat(1,1))
7744         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7745         vv(1)=pizda(1,1)+pizda(2,2)
7746         vv(2)=pizda(2,1)-pizda(1,2)
7747         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7748      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7749 C Explicit gradient in virtual-dihedral angles.
7750         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7751      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7752         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7753         vv(1)=pizda(1,1)+pizda(2,2)
7754         vv(2)=pizda(2,1)-pizda(1,2)
7755         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7756      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7757      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7758 C Cartesian gradient
7759         do iii=1,2
7760           do kkk=1,5
7761             do lll=1,3
7762               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7763      &          pizda(1,1))
7764               vv(1)=pizda(1,1)+pizda(2,2)
7765               vv(2)=pizda(2,1)-pizda(1,2)
7766               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7767      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7768      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7769             enddo
7770           enddo
7771         enddo
7772       else
7773 C Antiparallel orientation
7774 C Contribution from graph III
7775 c        goto 1110
7776         call transpose2(EUg(1,1,j),auxmat(1,1))
7777         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7778         vv(1)=pizda(1,1)-pizda(2,2)
7779         vv(2)=pizda(1,2)+pizda(2,1)
7780         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7781      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7782 C Explicit gradient in virtual-dihedral angles.
7783         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7784      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7785      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7786         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7787         vv(1)=pizda(1,1)-pizda(2,2)
7788         vv(2)=pizda(1,2)+pizda(2,1)
7789         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7790      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7791      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7792         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7793         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7794         vv(1)=pizda(1,1)-pizda(2,2)
7795         vv(2)=pizda(1,2)+pizda(2,1)
7796         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7797      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7798      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7799 C Cartesian gradient
7800         do iii=1,2
7801           do kkk=1,5
7802             do lll=1,3
7803               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7804      &          pizda(1,1))
7805               vv(1)=pizda(1,1)-pizda(2,2)
7806               vv(2)=pizda(1,2)+pizda(2,1)
7807               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7808      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7809      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7810             enddo
7811           enddo
7812         enddo
7813 cd        goto 1112
7814 C Contribution from graph IV
7815 1110    continue
7816         call transpose2(EE(1,1,itj),auxmat(1,1))
7817         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7818         vv(1)=pizda(1,1)+pizda(2,2)
7819         vv(2)=pizda(2,1)-pizda(1,2)
7820         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7821      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7822 C Explicit gradient in virtual-dihedral angles.
7823         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7824      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7825         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7826         vv(1)=pizda(1,1)+pizda(2,2)
7827         vv(2)=pizda(2,1)-pizda(1,2)
7828         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7829      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7830      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7831 C Cartesian gradient
7832         do iii=1,2
7833           do kkk=1,5
7834             do lll=1,3
7835               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7836      &          pizda(1,1))
7837               vv(1)=pizda(1,1)+pizda(2,2)
7838               vv(2)=pizda(2,1)-pizda(1,2)
7839               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7840      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7841      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7842             enddo
7843           enddo
7844         enddo
7845       endif
7846 1112  continue
7847       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7848 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7849 cd        write (2,*) 'ijkl',i,j,k,l
7850 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7851 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7852 cd      endif
7853 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7854 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7855 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7856 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7857       if (j.lt.nres-1) then
7858         j1=j+1
7859         j2=j-1
7860       else
7861         j1=j-1
7862         j2=j-2
7863       endif
7864       if (l.lt.nres-1) then
7865         l1=l+1
7866         l2=l-1
7867       else
7868         l1=l-1
7869         l2=l-2
7870       endif
7871 cd      eij=1.0d0
7872 cd      ekl=1.0d0
7873 cd      ekont=1.0d0
7874 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7875 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7876 C        summed up outside the subrouine as for the other subroutines
7877 C        handling long-range interactions. The old code is commented out
7878 C        with "cgrad" to keep track of changes.
7879       do ll=1,3
7880 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7881 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7882         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7883         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7884 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7885 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7886 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7887 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7888 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7889 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7890 c     &   gradcorr5ij,
7891 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7892 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7893 cgrad        ghalf=0.5d0*ggg1(ll)
7894 cd        ghalf=0.0d0
7895         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7896         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7897         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7898         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7899         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7900         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7901 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7902 cgrad        ghalf=0.5d0*ggg2(ll)
7903 cd        ghalf=0.0d0
7904         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7905         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7906         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7907         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7908         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7909         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7910       enddo
7911 cd      goto 1112
7912 cgrad      do m=i+1,j-1
7913 cgrad        do ll=1,3
7914 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7915 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7916 cgrad        enddo
7917 cgrad      enddo
7918 cgrad      do m=k+1,l-1
7919 cgrad        do ll=1,3
7920 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7921 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7922 cgrad        enddo
7923 cgrad      enddo
7924 c1112  continue
7925 cgrad      do m=i+2,j2
7926 cgrad        do ll=1,3
7927 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7928 cgrad        enddo
7929 cgrad      enddo
7930 cgrad      do m=k+2,l2
7931 cgrad        do ll=1,3
7932 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7933 cgrad        enddo
7934 cgrad      enddo
7935 cd      do iii=1,nres-3
7936 cd        write (2,*) iii,g_corr5_loc(iii)
7937 cd      enddo
7938       eello5=ekont*eel5
7939 cd      write (2,*) 'ekont',ekont
7940 cd      write (iout,*) 'eello5',ekont*eel5
7941       return
7942       end
7943 c--------------------------------------------------------------------------
7944       double precision function eello6(i,j,k,l,jj,kk)
7945       implicit real*8 (a-h,o-z)
7946       include 'DIMENSIONS'
7947       include 'COMMON.IOUNITS'
7948       include 'COMMON.CHAIN'
7949       include 'COMMON.DERIV'
7950       include 'COMMON.INTERACT'
7951       include 'COMMON.CONTACTS'
7952       include 'COMMON.TORSION'
7953       include 'COMMON.VAR'
7954       include 'COMMON.GEO'
7955       include 'COMMON.FFIELD'
7956       double precision ggg1(3),ggg2(3)
7957 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7958 cd        eello6=0.0d0
7959 cd        return
7960 cd      endif
7961 cd      write (iout,*)
7962 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7963 cd     &   ' and',k,l
7964       eello6_1=0.0d0
7965       eello6_2=0.0d0
7966       eello6_3=0.0d0
7967       eello6_4=0.0d0
7968       eello6_5=0.0d0
7969       eello6_6=0.0d0
7970 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7971 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7972       do iii=1,2
7973         do kkk=1,5
7974           do lll=1,3
7975             derx(lll,kkk,iii)=0.0d0
7976           enddo
7977         enddo
7978       enddo
7979 cd      eij=facont_hb(jj,i)
7980 cd      ekl=facont_hb(kk,k)
7981 cd      ekont=eij*ekl
7982 cd      eij=1.0d0
7983 cd      ekl=1.0d0
7984 cd      ekont=1.0d0
7985       if (l.eq.j+1) then
7986         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7987         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7988         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7989         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7990         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7991         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7992       else
7993         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7994         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7995         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7996         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7997         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7998           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7999         else
8000           eello6_5=0.0d0
8001         endif
8002         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8003       endif
8004 C If turn contributions are considered, they will be handled separately.
8005       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8006 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8007 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8008 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8009 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8010 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8011 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8012 cd      goto 1112
8013       if (j.lt.nres-1) then
8014         j1=j+1
8015         j2=j-1
8016       else
8017         j1=j-1
8018         j2=j-2
8019       endif
8020       if (l.lt.nres-1) then
8021         l1=l+1
8022         l2=l-1
8023       else
8024         l1=l-1
8025         l2=l-2
8026       endif
8027       do ll=1,3
8028 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8029 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8030 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8031 cgrad        ghalf=0.5d0*ggg1(ll)
8032 cd        ghalf=0.0d0
8033         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8034         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8035         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8036         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8037         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8038         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8039         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8040         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8041 cgrad        ghalf=0.5d0*ggg2(ll)
8042 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8043 cd        ghalf=0.0d0
8044         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8045         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8046         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8047         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8048         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8049         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8050       enddo
8051 cd      goto 1112
8052 cgrad      do m=i+1,j-1
8053 cgrad        do ll=1,3
8054 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8055 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8056 cgrad        enddo
8057 cgrad      enddo
8058 cgrad      do m=k+1,l-1
8059 cgrad        do ll=1,3
8060 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8061 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8062 cgrad        enddo
8063 cgrad      enddo
8064 cgrad1112  continue
8065 cgrad      do m=i+2,j2
8066 cgrad        do ll=1,3
8067 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8068 cgrad        enddo
8069 cgrad      enddo
8070 cgrad      do m=k+2,l2
8071 cgrad        do ll=1,3
8072 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8073 cgrad        enddo
8074 cgrad      enddo
8075 cd      do iii=1,nres-3
8076 cd        write (2,*) iii,g_corr6_loc(iii)
8077 cd      enddo
8078       eello6=ekont*eel6
8079 cd      write (2,*) 'ekont',ekont
8080 cd      write (iout,*) 'eello6',ekont*eel6
8081       return
8082       end
8083 c--------------------------------------------------------------------------
8084       double precision function eello6_graph1(i,j,k,l,imat,swap)
8085       implicit real*8 (a-h,o-z)
8086       include 'DIMENSIONS'
8087       include 'COMMON.IOUNITS'
8088       include 'COMMON.CHAIN'
8089       include 'COMMON.DERIV'
8090       include 'COMMON.INTERACT'
8091       include 'COMMON.CONTACTS'
8092       include 'COMMON.TORSION'
8093       include 'COMMON.VAR'
8094       include 'COMMON.GEO'
8095       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8096       logical swap
8097       logical lprn
8098       common /kutas/ lprn
8099 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8100 C
8101 C      Parallel       Antiparallel
8102 C
8103 C          o             o
8104 C         /l\           /j\
8105 C        /   \         /   \
8106 C       /| o |         | o |\
8107 C     \ j|/k\|  /   \  |/k\|l /
8108 C      \ /   \ /     \ /   \ /
8109 C       o     o       o     o
8110 C       i             i
8111 C
8112 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8113       itk=itortyp(itype(k))
8114       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8115       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8116       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8117       call transpose2(EUgC(1,1,k),auxmat(1,1))
8118       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8119       vv1(1)=pizda1(1,1)-pizda1(2,2)
8120       vv1(2)=pizda1(1,2)+pizda1(2,1)
8121       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8122       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8123       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8124       s5=scalar2(vv(1),Dtobr2(1,i))
8125 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8126       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8127       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8128      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8129      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8130      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8131      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8132      & +scalar2(vv(1),Dtobr2der(1,i)))
8133       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8134       vv1(1)=pizda1(1,1)-pizda1(2,2)
8135       vv1(2)=pizda1(1,2)+pizda1(2,1)
8136       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8137       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8138       if (l.eq.j+1) then
8139         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8140      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8141      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8142      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8143      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8144       else
8145         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8146      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8147      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8148      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8149      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8150       endif
8151       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8152       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8153       vv1(1)=pizda1(1,1)-pizda1(2,2)
8154       vv1(2)=pizda1(1,2)+pizda1(2,1)
8155       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8156      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8157      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8158      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8159       do iii=1,2
8160         if (swap) then
8161           ind=3-iii
8162         else
8163           ind=iii
8164         endif
8165         do kkk=1,5
8166           do lll=1,3
8167             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8168             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8169             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8170             call transpose2(EUgC(1,1,k),auxmat(1,1))
8171             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8172      &        pizda1(1,1))
8173             vv1(1)=pizda1(1,1)-pizda1(2,2)
8174             vv1(2)=pizda1(1,2)+pizda1(2,1)
8175             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8176             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8177      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8178             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8179      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8180             s5=scalar2(vv(1),Dtobr2(1,i))
8181             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8182           enddo
8183         enddo
8184       enddo
8185       return
8186       end
8187 c----------------------------------------------------------------------------
8188       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8189       implicit real*8 (a-h,o-z)
8190       include 'DIMENSIONS'
8191       include 'COMMON.IOUNITS'
8192       include 'COMMON.CHAIN'
8193       include 'COMMON.DERIV'
8194       include 'COMMON.INTERACT'
8195       include 'COMMON.CONTACTS'
8196       include 'COMMON.TORSION'
8197       include 'COMMON.VAR'
8198       include 'COMMON.GEO'
8199       logical swap
8200       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8201      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8202       logical lprn
8203       common /kutas/ lprn
8204 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8205 C                                                                              C
8206 C      Parallel       Antiparallel                                             C
8207 C                                                                              C
8208 C          o             o                                                     C
8209 C     \   /l\           /j\   /                                                C
8210 C      \ /   \         /   \ /                                                 C
8211 C       o| o |         | o |o                                                  C
8212 C     \ j|/k\|      \  |/k\|l                                                  C
8213 C      \ /   \       \ /   \                                                   C
8214 C       o             o                                                        C
8215 C       i             i                                                        C
8216 C                                                                              C
8217 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8218 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8219 C AL 7/4/01 s1 would occur in the sixth-order moment,
8220 C           but not in a cluster cumulant
8221 #ifdef MOMENT
8222       s1=dip(1,jj,i)*dip(1,kk,k)
8223 #endif
8224       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8225       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8226       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8227       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8228       call transpose2(EUg(1,1,k),auxmat(1,1))
8229       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8230       vv(1)=pizda(1,1)-pizda(2,2)
8231       vv(2)=pizda(1,2)+pizda(2,1)
8232       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8233 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8234 #ifdef MOMENT
8235       eello6_graph2=-(s1+s2+s3+s4)
8236 #else
8237       eello6_graph2=-(s2+s3+s4)
8238 #endif
8239 c      eello6_graph2=-s3
8240 C Derivatives in gamma(i-1)
8241       if (i.gt.1) then
8242 #ifdef MOMENT
8243         s1=dipderg(1,jj,i)*dip(1,kk,k)
8244 #endif
8245         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8246         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8247         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8248         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8249 #ifdef MOMENT
8250         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8251 #else
8252         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8253 #endif
8254 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8255       endif
8256 C Derivatives in gamma(k-1)
8257 #ifdef MOMENT
8258       s1=dip(1,jj,i)*dipderg(1,kk,k)
8259 #endif
8260       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8261       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8262       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8263       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8264       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8265       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8266       vv(1)=pizda(1,1)-pizda(2,2)
8267       vv(2)=pizda(1,2)+pizda(2,1)
8268       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8269 #ifdef MOMENT
8270       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8271 #else
8272       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8273 #endif
8274 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8275 C Derivatives in gamma(j-1) or gamma(l-1)
8276       if (j.gt.1) then
8277 #ifdef MOMENT
8278         s1=dipderg(3,jj,i)*dip(1,kk,k)
8279 #endif
8280         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8281         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8282         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8283         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8284         vv(1)=pizda(1,1)-pizda(2,2)
8285         vv(2)=pizda(1,2)+pizda(2,1)
8286         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8287 #ifdef MOMENT
8288         if (swap) then
8289           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8290         else
8291           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8292         endif
8293 #endif
8294         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8295 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8296       endif
8297 C Derivatives in gamma(l-1) or gamma(j-1)
8298       if (l.gt.1) then
8299 #ifdef MOMENT
8300         s1=dip(1,jj,i)*dipderg(3,kk,k)
8301 #endif
8302         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8303         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8304         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8305         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8306         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8307         vv(1)=pizda(1,1)-pizda(2,2)
8308         vv(2)=pizda(1,2)+pizda(2,1)
8309         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8310 #ifdef MOMENT
8311         if (swap) then
8312           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8313         else
8314           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8315         endif
8316 #endif
8317         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8318 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8319       endif
8320 C Cartesian derivatives.
8321       if (lprn) then
8322         write (2,*) 'In eello6_graph2'
8323         do iii=1,2
8324           write (2,*) 'iii=',iii
8325           do kkk=1,5
8326             write (2,*) 'kkk=',kkk
8327             do jjj=1,2
8328               write (2,'(3(2f10.5),5x)')
8329      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8330             enddo
8331           enddo
8332         enddo
8333       endif
8334       do iii=1,2
8335         do kkk=1,5
8336           do lll=1,3
8337 #ifdef MOMENT
8338             if (iii.eq.1) then
8339               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8340             else
8341               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8342             endif
8343 #endif
8344             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8345      &        auxvec(1))
8346             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8347             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8348      &        auxvec(1))
8349             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8350             call transpose2(EUg(1,1,k),auxmat(1,1))
8351             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8352      &        pizda(1,1))
8353             vv(1)=pizda(1,1)-pizda(2,2)
8354             vv(2)=pizda(1,2)+pizda(2,1)
8355             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8356 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8357 #ifdef MOMENT
8358             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8359 #else
8360             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8361 #endif
8362             if (swap) then
8363               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8364             else
8365               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8366             endif
8367           enddo
8368         enddo
8369       enddo
8370       return
8371       end
8372 c----------------------------------------------------------------------------
8373       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8374       implicit real*8 (a-h,o-z)
8375       include 'DIMENSIONS'
8376       include 'COMMON.IOUNITS'
8377       include 'COMMON.CHAIN'
8378       include 'COMMON.DERIV'
8379       include 'COMMON.INTERACT'
8380       include 'COMMON.CONTACTS'
8381       include 'COMMON.TORSION'
8382       include 'COMMON.VAR'
8383       include 'COMMON.GEO'
8384       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8385       logical swap
8386 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8387 C                                                                              C
8388 C      Parallel       Antiparallel                                             C
8389 C                                                                              C
8390 C          o             o                                                     C
8391 C         /l\   /   \   /j\                                                    C
8392 C        /   \ /     \ /   \                                                   C
8393 C       /| o |o       o| o |\                                                  C
8394 C       j|/k\|  /      |/k\|l /                                                C
8395 C        /   \ /       /   \ /                                                 C
8396 C       /     o       /     o                                                  C
8397 C       i             i                                                        C
8398 C                                                                              C
8399 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8400 C
8401 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8402 C           energy moment and not to the cluster cumulant.
8403       iti=itortyp(itype(i))
8404       if (j.lt.nres-1) then
8405         itj1=itortyp(itype(j+1))
8406       else
8407         itj1=ntortyp+1
8408       endif
8409       itk=itortyp(itype(k))
8410       itk1=itortyp(itype(k+1))
8411       if (l.lt.nres-1) then
8412         itl1=itortyp(itype(l+1))
8413       else
8414         itl1=ntortyp+1
8415       endif
8416 #ifdef MOMENT
8417       s1=dip(4,jj,i)*dip(4,kk,k)
8418 #endif
8419       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8420       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8421       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8422       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8423       call transpose2(EE(1,1,itk),auxmat(1,1))
8424       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8425       vv(1)=pizda(1,1)+pizda(2,2)
8426       vv(2)=pizda(2,1)-pizda(1,2)
8427       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8428 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8429 cd     & "sum",-(s2+s3+s4)
8430 #ifdef MOMENT
8431       eello6_graph3=-(s1+s2+s3+s4)
8432 #else
8433       eello6_graph3=-(s2+s3+s4)
8434 #endif
8435 c      eello6_graph3=-s4
8436 C Derivatives in gamma(k-1)
8437       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8438       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8439       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8440       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8441 C Derivatives in gamma(l-1)
8442       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8443       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8444       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8445       vv(1)=pizda(1,1)+pizda(2,2)
8446       vv(2)=pizda(2,1)-pizda(1,2)
8447       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8448       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8449 C Cartesian derivatives.
8450       do iii=1,2
8451         do kkk=1,5
8452           do lll=1,3
8453 #ifdef MOMENT
8454             if (iii.eq.1) then
8455               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8456             else
8457               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8458             endif
8459 #endif
8460             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8461      &        auxvec(1))
8462             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8463             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8464      &        auxvec(1))
8465             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8466             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8467      &        pizda(1,1))
8468             vv(1)=pizda(1,1)+pizda(2,2)
8469             vv(2)=pizda(2,1)-pizda(1,2)
8470             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8471 #ifdef MOMENT
8472             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8473 #else
8474             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8475 #endif
8476             if (swap) then
8477               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8478             else
8479               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8480             endif
8481 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8482           enddo
8483         enddo
8484       enddo
8485       return
8486       end
8487 c----------------------------------------------------------------------------
8488       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8489       implicit real*8 (a-h,o-z)
8490       include 'DIMENSIONS'
8491       include 'COMMON.IOUNITS'
8492       include 'COMMON.CHAIN'
8493       include 'COMMON.DERIV'
8494       include 'COMMON.INTERACT'
8495       include 'COMMON.CONTACTS'
8496       include 'COMMON.TORSION'
8497       include 'COMMON.VAR'
8498       include 'COMMON.GEO'
8499       include 'COMMON.FFIELD'
8500       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8501      & auxvec1(2),auxmat1(2,2)
8502       logical swap
8503 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8504 C                                                                              C
8505 C      Parallel       Antiparallel                                             C
8506 C                                                                              C
8507 C          o             o                                                     C
8508 C         /l\   /   \   /j\                                                    C
8509 C        /   \ /     \ /   \                                                   C
8510 C       /| o |o       o| o |\                                                  C
8511 C     \ j|/k\|      \  |/k\|l                                                  C
8512 C      \ /   \       \ /   \                                                   C
8513 C       o     \       o     \                                                  C
8514 C       i             i                                                        C
8515 C                                                                              C
8516 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8517 C
8518 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8519 C           energy moment and not to the cluster cumulant.
8520 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8521       iti=itortyp(itype(i))
8522       itj=itortyp(itype(j))
8523       if (j.lt.nres-1) then
8524         itj1=itortyp(itype(j+1))
8525       else
8526         itj1=ntortyp+1
8527       endif
8528       itk=itortyp(itype(k))
8529       if (k.lt.nres-1) then
8530         itk1=itortyp(itype(k+1))
8531       else
8532         itk1=ntortyp+1
8533       endif
8534       itl=itortyp(itype(l))
8535       if (l.lt.nres-1) then
8536         itl1=itortyp(itype(l+1))
8537       else
8538         itl1=ntortyp+1
8539       endif
8540 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8541 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8542 cd     & ' itl',itl,' itl1',itl1
8543 #ifdef MOMENT
8544       if (imat.eq.1) then
8545         s1=dip(3,jj,i)*dip(3,kk,k)
8546       else
8547         s1=dip(2,jj,j)*dip(2,kk,l)
8548       endif
8549 #endif
8550       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8551       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8552       if (j.eq.l+1) then
8553         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8554         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8555       else
8556         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8557         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8558       endif
8559       call transpose2(EUg(1,1,k),auxmat(1,1))
8560       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8561       vv(1)=pizda(1,1)-pizda(2,2)
8562       vv(2)=pizda(2,1)+pizda(1,2)
8563       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8564 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8565 #ifdef MOMENT
8566       eello6_graph4=-(s1+s2+s3+s4)
8567 #else
8568       eello6_graph4=-(s2+s3+s4)
8569 #endif
8570 C Derivatives in gamma(i-1)
8571       if (i.gt.1) then
8572 #ifdef MOMENT
8573         if (imat.eq.1) then
8574           s1=dipderg(2,jj,i)*dip(3,kk,k)
8575         else
8576           s1=dipderg(4,jj,j)*dip(2,kk,l)
8577         endif
8578 #endif
8579         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8580         if (j.eq.l+1) then
8581           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8582           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8583         else
8584           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8585           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8586         endif
8587         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8588         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8589 cd          write (2,*) 'turn6 derivatives'
8590 #ifdef MOMENT
8591           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8592 #else
8593           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8594 #endif
8595         else
8596 #ifdef MOMENT
8597           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8598 #else
8599           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8600 #endif
8601         endif
8602       endif
8603 C Derivatives in gamma(k-1)
8604 #ifdef MOMENT
8605       if (imat.eq.1) then
8606         s1=dip(3,jj,i)*dipderg(2,kk,k)
8607       else
8608         s1=dip(2,jj,j)*dipderg(4,kk,l)
8609       endif
8610 #endif
8611       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8612       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8613       if (j.eq.l+1) then
8614         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8615         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8616       else
8617         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8618         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8619       endif
8620       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8621       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8622       vv(1)=pizda(1,1)-pizda(2,2)
8623       vv(2)=pizda(2,1)+pizda(1,2)
8624       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8625       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8626 #ifdef MOMENT
8627         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8628 #else
8629         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8630 #endif
8631       else
8632 #ifdef MOMENT
8633         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8634 #else
8635         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8636 #endif
8637       endif
8638 C Derivatives in gamma(j-1) or gamma(l-1)
8639       if (l.eq.j+1 .and. l.gt.1) then
8640         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8641         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8642         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8643         vv(1)=pizda(1,1)-pizda(2,2)
8644         vv(2)=pizda(2,1)+pizda(1,2)
8645         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8646         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8647       else if (j.gt.1) then
8648         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8649         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8650         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8651         vv(1)=pizda(1,1)-pizda(2,2)
8652         vv(2)=pizda(2,1)+pizda(1,2)
8653         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8654         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8655           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8656         else
8657           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8658         endif
8659       endif
8660 C Cartesian derivatives.
8661       do iii=1,2
8662         do kkk=1,5
8663           do lll=1,3
8664 #ifdef MOMENT
8665             if (iii.eq.1) then
8666               if (imat.eq.1) then
8667                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8668               else
8669                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8670               endif
8671             else
8672               if (imat.eq.1) then
8673                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8674               else
8675                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8676               endif
8677             endif
8678 #endif
8679             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8680      &        auxvec(1))
8681             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8682             if (j.eq.l+1) then
8683               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8684      &          b1(1,itj1),auxvec(1))
8685               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8686             else
8687               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8688      &          b1(1,itl1),auxvec(1))
8689               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8690             endif
8691             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8692      &        pizda(1,1))
8693             vv(1)=pizda(1,1)-pizda(2,2)
8694             vv(2)=pizda(2,1)+pizda(1,2)
8695             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8696             if (swap) then
8697               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8698 #ifdef MOMENT
8699                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8700      &             -(s1+s2+s4)
8701 #else
8702                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8703      &             -(s2+s4)
8704 #endif
8705                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8706               else
8707 #ifdef MOMENT
8708                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8709 #else
8710                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8711 #endif
8712                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8713               endif
8714             else
8715 #ifdef MOMENT
8716               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8717 #else
8718               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8719 #endif
8720               if (l.eq.j+1) then
8721                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8722               else
8723                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8724               endif
8725             endif
8726           enddo
8727         enddo
8728       enddo
8729       return
8730       end
8731 c----------------------------------------------------------------------------
8732       double precision function eello_turn6(i,jj,kk)
8733       implicit real*8 (a-h,o-z)
8734       include 'DIMENSIONS'
8735       include 'COMMON.IOUNITS'
8736       include 'COMMON.CHAIN'
8737       include 'COMMON.DERIV'
8738       include 'COMMON.INTERACT'
8739       include 'COMMON.CONTACTS'
8740       include 'COMMON.TORSION'
8741       include 'COMMON.VAR'
8742       include 'COMMON.GEO'
8743       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8744      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8745      &  ggg1(3),ggg2(3)
8746       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8747      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8748 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8749 C           the respective energy moment and not to the cluster cumulant.
8750       s1=0.0d0
8751       s8=0.0d0
8752       s13=0.0d0
8753 c
8754       eello_turn6=0.0d0
8755       j=i+4
8756       k=i+1
8757       l=i+3
8758       iti=itortyp(itype(i))
8759       itk=itortyp(itype(k))
8760       itk1=itortyp(itype(k+1))
8761       itl=itortyp(itype(l))
8762       itj=itortyp(itype(j))
8763 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8764 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8765 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8766 cd        eello6=0.0d0
8767 cd        return
8768 cd      endif
8769 cd      write (iout,*)
8770 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8771 cd     &   ' and',k,l
8772 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8773       do iii=1,2
8774         do kkk=1,5
8775           do lll=1,3
8776             derx_turn(lll,kkk,iii)=0.0d0
8777           enddo
8778         enddo
8779       enddo
8780 cd      eij=1.0d0
8781 cd      ekl=1.0d0
8782 cd      ekont=1.0d0
8783       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8784 cd      eello6_5=0.0d0
8785 cd      write (2,*) 'eello6_5',eello6_5
8786 #ifdef MOMENT
8787       call transpose2(AEA(1,1,1),auxmat(1,1))
8788       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8789       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8790       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8791 #endif
8792       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8793       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8794       s2 = scalar2(b1(1,itk),vtemp1(1))
8795 #ifdef MOMENT
8796       call transpose2(AEA(1,1,2),atemp(1,1))
8797       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8798       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8799       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8800 #endif
8801       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8802       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8803       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8804 #ifdef MOMENT
8805       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8806       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8807       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8808       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8809       ss13 = scalar2(b1(1,itk),vtemp4(1))
8810       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8811 #endif
8812 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8813 c      s1=0.0d0
8814 c      s2=0.0d0
8815 c      s8=0.0d0
8816 c      s12=0.0d0
8817 c      s13=0.0d0
8818       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8819 C Derivatives in gamma(i+2)
8820       s1d =0.0d0
8821       s8d =0.0d0
8822 #ifdef MOMENT
8823       call transpose2(AEA(1,1,1),auxmatd(1,1))
8824       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8825       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8826       call transpose2(AEAderg(1,1,2),atempd(1,1))
8827       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8828       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8829 #endif
8830       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8831       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8832       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8833 c      s1d=0.0d0
8834 c      s2d=0.0d0
8835 c      s8d=0.0d0
8836 c      s12d=0.0d0
8837 c      s13d=0.0d0
8838       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8839 C Derivatives in gamma(i+3)
8840 #ifdef MOMENT
8841       call transpose2(AEA(1,1,1),auxmatd(1,1))
8842       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8843       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8844       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8845 #endif
8846       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8847       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8848       s2d = scalar2(b1(1,itk),vtemp1d(1))
8849 #ifdef MOMENT
8850       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8851       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8852 #endif
8853       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8854 #ifdef MOMENT
8855       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8856       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8857       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8858 #endif
8859 c      s1d=0.0d0
8860 c      s2d=0.0d0
8861 c      s8d=0.0d0
8862 c      s12d=0.0d0
8863 c      s13d=0.0d0
8864 #ifdef MOMENT
8865       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8866      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8867 #else
8868       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8869      &               -0.5d0*ekont*(s2d+s12d)
8870 #endif
8871 C Derivatives in gamma(i+4)
8872       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8873       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8874       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8875 #ifdef MOMENT
8876       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8877       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8878       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8879 #endif
8880 c      s1d=0.0d0
8881 c      s2d=0.0d0
8882 c      s8d=0.0d0
8883 C      s12d=0.0d0
8884 c      s13d=0.0d0
8885 #ifdef MOMENT
8886       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8887 #else
8888       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8889 #endif
8890 C Derivatives in gamma(i+5)
8891 #ifdef MOMENT
8892       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8893       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8894       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8895 #endif
8896       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8897       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8898       s2d = scalar2(b1(1,itk),vtemp1d(1))
8899 #ifdef MOMENT
8900       call transpose2(AEA(1,1,2),atempd(1,1))
8901       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8902       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8903 #endif
8904       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8905       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8906 #ifdef MOMENT
8907       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8908       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8909       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8910 #endif
8911 c      s1d=0.0d0
8912 c      s2d=0.0d0
8913 c      s8d=0.0d0
8914 c      s12d=0.0d0
8915 c      s13d=0.0d0
8916 #ifdef MOMENT
8917       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8918      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8919 #else
8920       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8921      &               -0.5d0*ekont*(s2d+s12d)
8922 #endif
8923 C Cartesian derivatives
8924       do iii=1,2
8925         do kkk=1,5
8926           do lll=1,3
8927 #ifdef MOMENT
8928             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8929             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8930             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8931 #endif
8932             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8933             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8934      &          vtemp1d(1))
8935             s2d = scalar2(b1(1,itk),vtemp1d(1))
8936 #ifdef MOMENT
8937             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8938             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8939             s8d = -(atempd(1,1)+atempd(2,2))*
8940      &           scalar2(cc(1,1,itl),vtemp2(1))
8941 #endif
8942             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8943      &           auxmatd(1,1))
8944             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8945             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8946 c      s1d=0.0d0
8947 c      s2d=0.0d0
8948 c      s8d=0.0d0
8949 c      s12d=0.0d0
8950 c      s13d=0.0d0
8951 #ifdef MOMENT
8952             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8953      &        - 0.5d0*(s1d+s2d)
8954 #else
8955             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8956      &        - 0.5d0*s2d
8957 #endif
8958 #ifdef MOMENT
8959             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8960      &        - 0.5d0*(s8d+s12d)
8961 #else
8962             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8963      &        - 0.5d0*s12d
8964 #endif
8965           enddo
8966         enddo
8967       enddo
8968 #ifdef MOMENT
8969       do kkk=1,5
8970         do lll=1,3
8971           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8972      &      achuj_tempd(1,1))
8973           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8974           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8975           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8976           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8977           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8978      &      vtemp4d(1))
8979           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8980           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8981           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8982         enddo
8983       enddo
8984 #endif
8985 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8986 cd     &  16*eel_turn6_num
8987 cd      goto 1112
8988       if (j.lt.nres-1) then
8989         j1=j+1
8990         j2=j-1
8991       else
8992         j1=j-1
8993         j2=j-2
8994       endif
8995       if (l.lt.nres-1) then
8996         l1=l+1
8997         l2=l-1
8998       else
8999         l1=l-1
9000         l2=l-2
9001       endif
9002       do ll=1,3
9003 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9004 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9005 cgrad        ghalf=0.5d0*ggg1(ll)
9006 cd        ghalf=0.0d0
9007         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9008         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9009         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9010      &    +ekont*derx_turn(ll,2,1)
9011         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9012         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9013      &    +ekont*derx_turn(ll,4,1)
9014         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9015         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9016         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9017 cgrad        ghalf=0.5d0*ggg2(ll)
9018 cd        ghalf=0.0d0
9019         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9020      &    +ekont*derx_turn(ll,2,2)
9021         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9022         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9023      &    +ekont*derx_turn(ll,4,2)
9024         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9025         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9026         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9027       enddo
9028 cd      goto 1112
9029 cgrad      do m=i+1,j-1
9030 cgrad        do ll=1,3
9031 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9032 cgrad        enddo
9033 cgrad      enddo
9034 cgrad      do m=k+1,l-1
9035 cgrad        do ll=1,3
9036 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9037 cgrad        enddo
9038 cgrad      enddo
9039 cgrad1112  continue
9040 cgrad      do m=i+2,j2
9041 cgrad        do ll=1,3
9042 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9043 cgrad        enddo
9044 cgrad      enddo
9045 cgrad      do m=k+2,l2
9046 cgrad        do ll=1,3
9047 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9048 cgrad        enddo
9049 cgrad      enddo
9050 cd      do iii=1,nres-3
9051 cd        write (2,*) iii,g_corr6_loc(iii)
9052 cd      enddo
9053       eello_turn6=ekont*eel_turn6
9054 cd      write (2,*) 'ekont',ekont
9055 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9056       return
9057       end
9058
9059 C-----------------------------------------------------------------------------
9060       double precision function scalar(u,v)
9061 !DIR$ INLINEALWAYS scalar
9062 #ifndef OSF
9063 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9064 #endif
9065       implicit none
9066       double precision u(3),v(3)
9067 cd      double precision sc
9068 cd      integer i
9069 cd      sc=0.0d0
9070 cd      do i=1,3
9071 cd        sc=sc+u(i)*v(i)
9072 cd      enddo
9073 cd      scalar=sc
9074
9075       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9076       return
9077       end
9078 crc-------------------------------------------------
9079       SUBROUTINE MATVEC2(A1,V1,V2)
9080 !DIR$ INLINEALWAYS MATVEC2
9081 #ifndef OSF
9082 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9083 #endif
9084       implicit real*8 (a-h,o-z)
9085       include 'DIMENSIONS'
9086       DIMENSION A1(2,2),V1(2),V2(2)
9087 c      DO 1 I=1,2
9088 c        VI=0.0
9089 c        DO 3 K=1,2
9090 c    3     VI=VI+A1(I,K)*V1(K)
9091 c        Vaux(I)=VI
9092 c    1 CONTINUE
9093
9094       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9095       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9096
9097       v2(1)=vaux1
9098       v2(2)=vaux2
9099       END
9100 C---------------------------------------
9101       SUBROUTINE MATMAT2(A1,A2,A3)
9102 #ifndef OSF
9103 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9104 #endif
9105       implicit real*8 (a-h,o-z)
9106       include 'DIMENSIONS'
9107       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9108 c      DIMENSION AI3(2,2)
9109 c        DO  J=1,2
9110 c          A3IJ=0.0
9111 c          DO K=1,2
9112 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9113 c          enddo
9114 c          A3(I,J)=A3IJ
9115 c       enddo
9116 c      enddo
9117
9118       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9119       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9120       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9121       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9122
9123       A3(1,1)=AI3_11
9124       A3(2,1)=AI3_21
9125       A3(1,2)=AI3_12
9126       A3(2,2)=AI3_22
9127       END
9128
9129 c-------------------------------------------------------------------------
9130       double precision function scalar2(u,v)
9131 !DIR$ INLINEALWAYS scalar2
9132       implicit none
9133       double precision u(2),v(2)
9134       double precision sc
9135       integer i
9136       scalar2=u(1)*v(1)+u(2)*v(2)
9137       return
9138       end
9139
9140 C-----------------------------------------------------------------------------
9141
9142       subroutine transpose2(a,at)
9143 !DIR$ INLINEALWAYS transpose2
9144 #ifndef OSF
9145 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9146 #endif
9147       implicit none
9148       double precision a(2,2),at(2,2)
9149       at(1,1)=a(1,1)
9150       at(1,2)=a(2,1)
9151       at(2,1)=a(1,2)
9152       at(2,2)=a(2,2)
9153       return
9154       end
9155 c--------------------------------------------------------------------------
9156       subroutine transpose(n,a,at)
9157       implicit none
9158       integer n,i,j
9159       double precision a(n,n),at(n,n)
9160       do i=1,n
9161         do j=1,n
9162           at(j,i)=a(i,j)
9163         enddo
9164       enddo
9165       return
9166       end
9167 C---------------------------------------------------------------------------
9168       subroutine prodmat3(a1,a2,kk,transp,prod)
9169 !DIR$ INLINEALWAYS prodmat3
9170 #ifndef OSF
9171 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9172 #endif
9173       implicit none
9174       integer i,j
9175       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9176       logical transp
9177 crc      double precision auxmat(2,2),prod_(2,2)
9178
9179       if (transp) then
9180 crc        call transpose2(kk(1,1),auxmat(1,1))
9181 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9182 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9183
9184            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9185      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9186            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9187      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9188            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9189      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9190            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9191      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9192
9193       else
9194 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9195 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9196
9197            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9198      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9199            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9200      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9201            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9202      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9203            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9204      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9205
9206       endif
9207 c      call transpose2(a2(1,1),a2t(1,1))
9208
9209 crc      print *,transp
9210 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9211 crc      print *,((prod(i,j),i=1,2),j=1,2)
9212
9213       return
9214       end
9215