source/unres/src_MD/src/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 c      print *,"Processor",myrank," computed USCSC"
 135 #ifdef TIMING
 136 #ifdef MPI
 137       time01=MPI_Wtime()
 138 #else
 139       time00=tcpu()
 140 #endif
 141 #endif
 142       call vec_and_deriv
 143 #ifdef TIMING
 144 #ifdef MPI
 145       time_vec=time_vec+MPI_Wtime()-time01
 146 #else
 147       time_vec=time_vec+tcpu()-time01
 148 #endif
 149 #endif
 150 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 151       if (ipot.lt.6) then
 152 #ifdef SPLITELE
 153          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 154      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 155      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 156      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 157 #else
 158          if (welec.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 #endif
 163             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 164          else
 165             ees=0.0d0
 166             evdw1=0.0d0
 167             eel_loc=0.0d0
 168             eello_turn3=0.0d0
 169             eello_turn4=0.0d0
 170          endif
 171       else
 172 c        write (iout,*) "Soft-spheer ELEC potential"
 173         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 174      &   eello_turn4)
 175       endif
 176 c      print *,"Processor",myrank," computed UELEC"
 177 C
 178 C Calculate excluded-volume interaction energy between peptide groups
 179 C and side chains.
 180 C
 181       if (ipot.lt.6) then
 182        if(wscp.gt.0d0) then
 183         call escp(evdw2,evdw2_14)
 184        else
 185         evdw2=0
 186         evdw2_14=0
 187        endif
 188       else
 189 c        write (iout,*) "Soft-sphere SCP potential"
 190         call escp_soft_sphere(evdw2,evdw2_14)
 191       endif
 192 c
 193 c Calculate the bond-stretching energy
 194 c
 195       call ebond(estr)
 196 C
 197 C Calculate the disulfide-bridge and other energy and the contributions
 198 C from other distance constraints.
 199 cd    print *,'Calling EHPB'
 200       call edis(ehpb)
 201 cd    print *,'EHPB exitted succesfully.'
 202 C
 203 C Calculate the virtual-bond-angle energy.
 204 C
 205       if (wang.gt.0d0) then
 206         call ebend(ebe)
 207       else
 208         ebe=0
 209       endif
 210 c      print *,"Processor",myrank," computed UB"
 211 C
 212 C Calculate the SC local energy.
 213 C
 214       call esc(escloc)
 215 c      print *,"Processor",myrank," computed USC"
 216 C
 217 C Calculate the virtual-bond torsional energy.
 218 C
 219 cd    print *,'nterm=',nterm
 220       if (wtor.gt.0) then
 221        call etor(etors,edihcnstr)
 222       else
 223        etors=0
 224        edihcnstr=0
 225       endif
 226 c      print *,"Processor",myrank," computed Utor"
 227 C
 228 C 6/23/01 Calculate double-torsional energy
 229 C
 230       if (wtor_d.gt.0) then
 231        call etor_d(etors_d)
 232       else
 233        etors_d=0
 234       endif
 235 c      print *,"Processor",myrank," computed Utord"
 236 C
 237 C 21/5/07 Calculate local sicdechain correlation energy
 238 C
 239       if (wsccor.gt.0.0d0) then
 240         call eback_sc_corr(esccor)
 241       else
 242         esccor=0.0d0
 243       endif
 244 c      print *,"Processor",myrank," computed Usccorr"
 245 C
 246 C 12/1/95 Multi-body terms
 247 C
 248       n_corr=0
 249       n_corr1=0
 250       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 251      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 252          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 253 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 254 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 255       else
 256          ecorr=0.0d0
 257          ecorr5=0.0d0
 258          ecorr6=0.0d0
 259          eturn6=0.0d0
 260       endif
 261       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 262          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 263 cd         write (iout,*) "multibody_hb ecorr",ecorr
 264       endif
 265 c      print *,"Processor",myrank," computed Ucorr"
 266 C
 267 C If performing constraint dynamics, call the constraint energy
 268 C  after the equilibration time
 269       if(usampl.and.totT.gt.eq_time) then
 270          call EconstrQ
 271          call Econstr_back
 272       else
 273          Uconst=0.0d0
 274          Uconst_back=0.0d0
 275       endif
 276 #ifdef TIMING
 277 #ifdef MPI
 278       time_enecalc=time_enecalc+MPI_Wtime()-time00
 279 #else
 280       time_enecalc=time_enecalc+tcpu()-time00
 281 #endif
 282 #endif
 283 c      print *,"Processor",myrank," computed Uconstr"
 284 #ifdef TIMING
 285 #ifdef MPI
 286       time00=MPI_Wtime()
 287 #else
 288       time00=tcpu()
 289 #endif
 290 #endif
 291 c
 292 C Sum the energies
 293 C
 294       energia(1)=evdw
 295 #ifdef SCP14
 296       energia(2)=evdw2-evdw2_14
 297       energia(18)=evdw2_14
 298 #else
 299       energia(2)=evdw2
 300       energia(18)=0.0d0
 301 #endif
 302 #ifdef SPLITELE
 303       energia(3)=ees
 304       energia(16)=evdw1
 305 #else
 306       energia(3)=ees+evdw1
 307       energia(16)=0.0d0
 308 #endif
 309       energia(4)=ecorr
 310       energia(5)=ecorr5
 311       energia(6)=ecorr6
 312       energia(7)=eel_loc
 313       energia(8)=eello_turn3
 314       energia(9)=eello_turn4
 315       energia(10)=eturn6
 316       energia(11)=ebe
 317       energia(12)=escloc
 318       energia(13)=etors
 319       energia(14)=etors_d
 320       energia(15)=ehpb
 321       energia(19)=edihcnstr
 322       energia(17)=estr
 323       energia(20)=Uconst+Uconst_back
 324       energia(21)=esccor
 325       energia(22)=evdw_p
 326       energia(23)=evdw_m
 327 c      print *," Processor",myrank," calls SUM_ENERGY"
 328       call sum_energy(energia,.true.)
 329 c      print *," Processor",myrank," left SUM_ENERGY"
 330 #ifdef TIMING
 331 #ifdef MPI
 332       time_sumene=time_sumene+MPI_Wtime()-time00
 333 #else
 334       time_sumene=time_sumene+tcpu()-time00
 335 #endif
 336 #endif
 337       return
 338       end
 339 c-------------------------------------------------------------------------------
 340       subroutine sum_energy(energia,reduce)
 341       implicit real*8 (a-h,o-z)
 342       include 'DIMENSIONS'
 343 #ifndef ISNAN
 344       external proc_proc
 345 #ifdef WINPGI
 346 cMS$ATTRIBUTES C ::  proc_proc
 347 #endif
 348 #endif
 349 #ifdef MPI
 350       include "mpif.h"
 351 #endif
 352       include 'COMMON.SETUP'
 353       include 'COMMON.IOUNITS'
 354       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 355       include 'COMMON.FFIELD'
 356       include 'COMMON.DERIV'
 357       include 'COMMON.INTERACT'
 358       include 'COMMON.SBRIDGE'
 359       include 'COMMON.CHAIN'
 360       include 'COMMON.VAR'
 361       include 'COMMON.CONTROL'
 362       include 'COMMON.TIME1'
 363       logical reduce
 364 #ifdef MPI
 365       if (nfgtasks.gt.1 .and. reduce) then
 366 #ifdef DEBUG
 367         write (iout,*) "energies before REDUCE"
 368         call enerprint(energia)
 369         call flush(iout)
 370 #endif
 371         do i=0,n_ene
 372           enebuff(i)=energia(i)
 373         enddo
 374         time00=MPI_Wtime()
 375         call MPI_Barrier(FG_COMM,IERR)
 376         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 377         time00=MPI_Wtime()
 378         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 379      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 380 #ifdef DEBUG
 381         write (iout,*) "energies after REDUCE"
 382         call enerprint(energia)
 383         call flush(iout)
 384 #endif
 385         time_Reduce=time_Reduce+MPI_Wtime()-time00
 386       endif
 387       if (fg_rank.eq.0) then
 388 #endif
 389 #ifdef TSCSC
 390       evdw=energia(22)+wsct*energia(23)
 391 #else
 392       evdw=energia(1)
 393 #endif
 394 #ifdef SCP14
 395       evdw2=energia(2)+energia(18)
 396       evdw2_14=energia(18)
 397 #else
 398       evdw2=energia(2)
 399 #endif
 400 #ifdef SPLITELE
 401       ees=energia(3)
 402       evdw1=energia(16)
 403 #else
 404       ees=energia(3)
 405       evdw1=0.0d0
 406 #endif
 407       ecorr=energia(4)
 408       ecorr5=energia(5)
 409       ecorr6=energia(6)
 410       eel_loc=energia(7)
 411       eello_turn3=energia(8)
 412       eello_turn4=energia(9)
 413       eturn6=energia(10)
 414       ebe=energia(11)
 415       escloc=energia(12)
 416       etors=energia(13)
 417       etors_d=energia(14)
 418       ehpb=energia(15)
 419       edihcnstr=energia(19)
 420       estr=energia(17)
 421       Uconst=energia(20)
 422       esccor=energia(21)
 423 #ifdef SPLITELE
 424       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 425      & +wang*ebe+wtor*etors+wscloc*escloc
 426      & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5
 427      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 428      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 429      & +wbond*estr+Uconst+wsccor*esccor
 430 #else
 431       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 432      & +wang*ebe+wtor*etors+wscloc*escloc
 433      & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5
 434      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 435      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 436      & +wbond*estr+Uconst+wsccor*esccor
 437 #endif
 438       energia(0)=etot
 439 c detecting NaNQ
 440 #ifdef ISNAN
 441 #ifdef AIX
 442       if (isnan(etot).ne.0) energia(0)=1.0d+99
 443 #else
 444       if (isnan(etot)) energia(0)=1.0d+99
 445 #endif
 446 #else
 447       i=0
 448 #ifdef WINPGI
 449       idumm=proc_proc(etot,i)
 450 #else
 451       call proc_proc(etot,i)
 452 #endif
 453       if(i.eq.1)energia(0)=1.0d+99
 454 #endif
 455 #ifdef MPI
 456       endif
 457 #endif
 458       return
 459       end
 460 c-------------------------------------------------------------------------------
 461       subroutine sum_gradient
 462       implicit real*8 (a-h,o-z)
 463       include 'DIMENSIONS'
 464 #ifndef ISNAN
 465       external proc_proc
 466 #ifdef WINPGI
 467 cMS$ATTRIBUTES C ::  proc_proc
 468 #endif
 469 #endif
 470 #ifdef MPI
 471       include 'mpif.h'
 472 #endif
 473       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 474      &  glocbuf(4*maxres),gradbufc_sum(3,maxres)
 475       include 'COMMON.SETUP'
 476       include 'COMMON.IOUNITS'
 477       include 'COMMON.FFIELD'
 478       include 'COMMON.DERIV'
 479       include 'COMMON.INTERACT'
 480       include 'COMMON.SBRIDGE'
 481       include 'COMMON.CHAIN'
 482       include 'COMMON.VAR'
 483       include 'COMMON.CONTROL'
 484       include 'COMMON.TIME1'
 485       include 'COMMON.MAXGRAD'
 486 #ifdef TIMING
 487 #ifdef MPI
 488       time01=MPI_Wtime()
 489 #else
 490       time01=tcpu()
 491 #endif
 492 #endif
 493 #ifdef DEBUG
 494       write (iout,*) "sum_gradient gvdwc, gvdwx"
 495       do i=1,nres
 496         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 497      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 498       enddo
 499       call flush(iout)
 500 #endif
 501 #ifdef MPI
 502 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 503         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 504      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 505 #endif
 506 C
 507 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 508 C            in virtual-bond-vector coordinates
 509 C
 510 #ifdef DEBUG
 511 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 512 c      do i=1,nres-1
 513 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 514 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 515 c      enddo
 516 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 517 c      do i=1,nres-1
 518 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 519 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 520 c      enddo
 521       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 522       do i=1,nres
 523         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 524      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 525      &   g_corr5_loc(i)
 526       enddo
 527       call flush(iout)
 528 #endif
 529 #ifdef SPLITELE
 530       do i=1,nct
 531         do j=1,3
 532           gradbufc(j,i)=wsc*gvdwc(j,i)+
 533      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 534      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 535      &                wel_loc*gel_loc_long(j,i)+
 536      &                wcorr*gradcorr_long(j,i)+
 537      &                wcorr5*gradcorr5_long(j,i)+
 538      &                wcorr6*gradcorr6_long(j,i)+
 539      &                wturn6*gcorr6_turn_long(j,i)+
 540      &                wstrain*ghpbc(j,i)
 541         enddo
 542       enddo
 543 #else
 544       do i=1,nct
 545         do j=1,3
 546           gradbufc(j,i)=wsc*gvdwc(j,i)+
 547      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 548      &                welec*gelc_long(j,i)+
 549      &                wbond*gradb(j,i)+
 550      &                wel_loc*gel_loc_long(j,i)+
 551      &                wcorr*gradcorr_long(j,i)+
 552      &                wcorr5*gradcorr5_long(j,i)+
 553      &                wcorr6*gradcorr6_long(j,i)+
 554      &                wturn6*gcorr6_turn_long(j,i)+
 555      &                wstrain*ghpbc(j,i)
 556         enddo
 557       enddo
 558 #endif
 559 #ifdef MPI
 560       if (nfgtasks.gt.1) then
 561       time00=MPI_Wtime()
 562 #ifdef DEBUG
 563       write (iout,*) "gradbufc before allreduce"
 564       do i=1,nres
 565         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 566       enddo
 567       call flush(iout)
 568 #endif
 569       do i=1,nres
 570         do j=1,3
 571           gradbufc_sum(j,i)=gradbufc(j,i)
 572         enddo
 573       enddo
 574 #ifdef TIMING
 575 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 576 #endif
 577       do i=nnt,nres
 578         do k=1,3
 579           gradbufc(k,i)=0.0d0
 580         enddo
 581       enddo
 582 #ifdef DEBUG
 583       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 584       write (iout,*) (i," jgrad_start",jgrad_start(i),
 585      &                  " jgrad_end  ",jgrad_end(i),
 586      &                  i=igrad_start,igrad_end)
 587 #endif
 588       do j=1,3
 589         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 590       enddo
 591       do i=nres-2,nnt,-1
 592         do j=1,3
 593           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 594         enddo
 595       enddo
 596 #ifdef DEBUG
 597       write (iout,*) "gradbufc after summing"
 598       do i=1,nres
 599         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 600       enddo
 601       call flush(iout)
 602 #endif
 603       else
 604 #endif
 605 #ifdef DEBUG
 606       write (iout,*) "gradbufc"
 607       do i=1,nres
 608         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 609       enddo
 610       call flush(iout)
 611 #endif
 612       do i=1,nres
 613         do j=1,3
 614           gradbufc_sum(j,i)=gradbufc(j,i)
 615           gradbufc(j,i)=0.0d0
 616         enddo
 617       enddo
 618       do j=1,3
 619         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 620       enddo
 621       do i=nres-2,nnt,-1
 622         do j=1,3
 623           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 624         enddo
 625       enddo
 626 #ifdef DEBUG
 627       write (iout,*) "gradbufc after summing"
 628       do i=1,nres
 629         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 630       enddo
 631       call flush(iout)
 632 #endif
 633 #ifdef MPI
 634       endif
 635 #endif
 636       do k=1,3
 637         gradbufc(k,nres)=0.0d0
 638       enddo
 639       do i=1,nct
 640         do j=1,3
 641 #ifdef SPLITELE
 642           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 643      &                wel_loc*gel_loc(j,i)+
 644      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 645      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 646      &                wel_loc*gel_loc_long(j,i)+
 647      &                wcorr*gradcorr_long(j,i)+
 648      &                wcorr5*gradcorr5_long(j,i)+
 649      &                wcorr6*gradcorr6_long(j,i)+
 650      &                wturn6*gcorr6_turn_long(j,i))+
 651      &                wbond*gradb(j,i)+
 652      &                wcorr*gradcorr(j,i)+
 653      &                wturn3*gcorr3_turn(j,i)+
 654      &                wturn4*gcorr4_turn(j,i)+
 655      &                wcorr5*gradcorr5(j,i)+
 656      &                wcorr6*gradcorr6(j,i)+
 657      &                wturn6*gcorr6_turn(j,i)+
 658      &                wsccor*gsccorc(j,i)
 659      &               +wscloc*gscloc(j,i)
 660 #else
 661           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 662      &                wel_loc*gel_loc(j,i)+
 663      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 664      &                welec*gelc_long(j,i)
 665      &                wel_loc*gel_loc_long(j,i)+
 666      &                wcorr*gcorr_long(j,i)+
 667      &                wcorr5*gradcorr5_long(j,i)+
 668      &                wcorr6*gradcorr6_long(j,i)+
 669      &                wturn6*gcorr6_turn_long(j,i))+
 670      &                wbond*gradb(j,i)+
 671      &                wcorr*gradcorr(j,i)+
 672      &                wturn3*gcorr3_turn(j,i)+
 673      &                wturn4*gcorr4_turn(j,i)+
 674      &                wcorr5*gradcorr5(j,i)+
 675      &                wcorr6*gradcorr6(j,i)+
 676      &                wturn6*gcorr6_turn(j,i)+
 677      &                wsccor*gsccorc(j,i)
 678      &               +wscloc*gscloc(j,i)
 679 #endif
 680           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 681      &                  wbond*gradbx(j,i)+
 682      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 683      &                  wsccor*gsccorx(j,i)
 684      &                 +wscloc*gsclocx(j,i)
 685         enddo
 686       enddo
 687 #ifdef DEBUG
 688       write (iout,*) "gloc before adding corr"
 689       do i=1,4*nres
 690         write (iout,*) i,gloc(i,icg)
 691       enddo
 692 #endif
 693       do i=1,nres-3
 694         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 695      &   +wcorr5*g_corr5_loc(i)
 696      &   +wcorr6*g_corr6_loc(i)
 697      &   +wturn4*gel_loc_turn4(i)
 698      &   +wturn3*gel_loc_turn3(i)
 699      &   +wturn6*gel_loc_turn6(i)
 700      &   +wel_loc*gel_loc_loc(i)
 701      &   +wsccor*gsccor_loc(i)
 702       enddo
 703 #ifdef DEBUG
 704       write (iout,*) "gloc after adding corr"
 705       do i=1,4*nres
 706         write (iout,*) i,gloc(i,icg)
 707       enddo
 708 #endif
 709 #ifdef MPI
 710       if (nfgtasks.gt.1) then
 711         do j=1,3
 712           do i=1,nres
 713             gradbufc(j,i)=gradc(j,i,icg)
 714             gradbufx(j,i)=gradx(j,i,icg)
 715           enddo
 716         enddo
 717         do i=1,4*nres
 718           glocbuf(i)=gloc(i,icg)
 719         enddo
 720         time00=MPI_Wtime()
 721         call MPI_Barrier(FG_COMM,IERR)
 722         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 723         time00=MPI_Wtime()
 724         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 725      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 726         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 727      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 728         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 729      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 730         time_reduce=time_reduce+MPI_Wtime()-time00
 731 #ifdef DEBUG
 732       write (iout,*) "gloc after reduce"
 733       do i=1,4*nres
 734         write (iout,*) i,gloc(i,icg)
 735       enddo
 736 #endif
 737       endif
 738 #endif
 739       if (gnorm_check) then
 740 c
 741 c Compute the maximum elements of the gradient
 742 c
 743       gvdwc_max=0.0d0
 744       gvdwc_scp_max=0.0d0
 745       gelc_max=0.0d0
 746       gvdwpp_max=0.0d0
 747       gradb_max=0.0d0
 748       ghpbc_max=0.0d0
 749       gradcorr_max=0.0d0
 750       gel_loc_max=0.0d0
 751       gcorr3_turn_max=0.0d0
 752       gcorr4_turn_max=0.0d0
 753       gradcorr5_max=0.0d0
 754       gradcorr6_max=0.0d0
 755       gcorr6_turn_max=0.0d0
 756       gsccorc_max=0.0d0
 757       gscloc_max=0.0d0
 758       gvdwx_max=0.0d0
 759       gradx_scp_max=0.0d0
 760       ghpbx_max=0.0d0
 761       gradxorr_max=0.0d0
 762       gsccorx_max=0.0d0
 763       gsclocx_max=0.0d0
 764       do i=1,nct
 765         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 766         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 767         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 768         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 769      &   gvdwc_scp_max=gvdwc_scp_norm
 770         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 771         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 772         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 773         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 774         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 775         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 776         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 777         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 778         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 779         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 780         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 781         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 782         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 783      &    gcorr3_turn(1,i)))
 784         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 785      &    gcorr3_turn_max=gcorr3_turn_norm
 786         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 787      &    gcorr4_turn(1,i)))
 788         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 789      &    gcorr4_turn_max=gcorr4_turn_norm
 790         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 791         if (gradcorr5_norm.gt.gradcorr5_max)
 792      &    gradcorr5_max=gradcorr5_norm
 793         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 794         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 795         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 796      &    gcorr6_turn(1,i)))
 797         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 798      &    gcorr6_turn_max=gcorr6_turn_norm
 799         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 800         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 801         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 802         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 803         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 804         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 805         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 806         if (gradx_scp_norm.gt.gradx_scp_max)
 807      &    gradx_scp_max=gradx_scp_norm
 808         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 809         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 810         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 811         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 812         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 813         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 814         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 815         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 816       enddo
 817       if (gradout) then
 818 #ifdef AIX
 819         open(istat,file=statname,position="append")
 820 #else
 821         open(istat,file=statname,access="append")
 822 #endif
 823         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 824      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 825      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 826      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 827      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 828      &     gsccorx_max,gsclocx_max
 829         close(istat)
 830         if (gvdwc_max.gt.1.0d4) then
 831           write (iout,*) "gvdwc gvdwx gradb gradbx"
 832           do i=nnt,nct
 833             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 834      &        gradb(j,i),gradbx(j,i),j=1,3)
 835           enddo
 836           call pdbout(0.0d0,'cipiszcze',iout)
 837           call flush(iout)
 838         endif
 839       endif
 840       endif
 841 #ifdef DEBUG
 842       write (iout,*) "gradc gradx gloc"
 843       do i=1,nres
 844         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 845      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 846       enddo
 847 #endif
 848 #ifdef TIMING
 849 #ifdef MPI
 850       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 851 #else
 852       time_sumgradient=time_sumgradient+tcpu()-time01
 853 #endif
 854 #endif
 855       return
 856       end
 857 c-------------------------------------------------------------------------------
 858       subroutine rescale_weights(t_bath)
 859       implicit real*8 (a-h,o-z)
 860       include 'DIMENSIONS'
 861       include 'COMMON.IOUNITS'
 862       include 'COMMON.FFIELD'
 863       include 'COMMON.SBRIDGE'
 864       double precision kfac /2.4d0/
 865       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 866 c      facT=temp0/t_bath
 867 c      facT=2*temp0/(t_bath+temp0)
 868       if (rescale_mode.eq.0) then
 869         facT=1.0d0
 870         facT2=1.0d0
 871         facT3=1.0d0
 872         facT4=1.0d0
 873         facT5=1.0d0
 874       else if (rescale_mode.eq.1) then
 875         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 876         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 877         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 878         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 879         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 880       else if (rescale_mode.eq.2) then
 881         x=t_bath/temp0
 882         x2=x*x
 883         x3=x2*x
 884         x4=x3*x
 885         x5=x4*x
 886         facT=licznik/dlog(dexp(x)+dexp(-x))
 887         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 888         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 889         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 890         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 891       else
 892         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 893         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 894 #ifdef MPI
 895        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 896 #endif
 897        stop 555
 898       endif
 899       welec=weights(3)*fact
 900       wcorr=weights(4)*fact3
 901       wcorr5=weights(5)*fact4
 902       wcorr6=weights(6)*fact5
 903       wel_loc=weights(7)*fact2
 904       wturn3=weights(8)*fact2
 905       wturn4=weights(9)*fact3
 906       wturn6=weights(10)*fact5
 907       wtor=weights(13)*fact
 908       wtor_d=weights(14)*fact2
 909       wsccor=weights(21)*fact
 910 #ifdef TSCSC
 911 c      wsct=t_bath/temp0
 912       wsct=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
 913 #endif
 914       return
 915       end
 916 C------------------------------------------------------------------------
 917       subroutine enerprint(energia)
 918       implicit real*8 (a-h,o-z)
 919       include 'DIMENSIONS'
 920       include 'COMMON.IOUNITS'
 921       include 'COMMON.FFIELD'
 922       include 'COMMON.SBRIDGE'
 923       include 'COMMON.MD'
 924       double precision energia(0:n_ene)
 925       etot=energia(0)
 926 #ifdef TSCSC
 927       evdw=energia(22)+wsct*energia(23)
 928 #else
 929       evdw=energia(1)
 930 #endif
 931       evdw2=energia(2)
 932 #ifdef SCP14
 933       evdw2=energia(2)+energia(18)
 934 #else
 935       evdw2=energia(2)
 936 #endif
 937       ees=energia(3)
 938 #ifdef SPLITELE
 939       evdw1=energia(16)
 940 #endif
 941       ecorr=energia(4)
 942       ecorr5=energia(5)
 943       ecorr6=energia(6)
 944       eel_loc=energia(7)
 945       eello_turn3=energia(8)
 946       eello_turn4=energia(9)
 947       eello_turn6=energia(10)
 948       ebe=energia(11)
 949       escloc=energia(12)
 950       etors=energia(13)
 951       etors_d=energia(14)
 952       ehpb=energia(15)
 953       edihcnstr=energia(19)
 954       estr=energia(17)
 955       Uconst=energia(20)
 956       esccor=energia(21)
 957 #ifdef SPLITELE
 958       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
 959      &  estr,wbond,ebe,wang,
 960      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 961      &  ecorr,wcorr,
 962      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 963      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
 964      &  edihcnstr,ebr*nss,
 965      &  Uconst,etot
 966    10 format (/'Virtual-chain energies:'//
 967      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 968      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 969      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 970      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 971      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 972      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 973      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 974      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 975      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 976      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 977      & ' (SS bridges & dist. cnstr.)'/
 978      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 979      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 980      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 981      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 982      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 983      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 984      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 985      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 986      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 987      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 988      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
 989      & 'ETOT=  ',1pE16.6,' (total)')
 990 #else
 991       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
 992      &  estr,wbond,ebe,wang,
 993      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 994      &  ecorr,wcorr,
 995      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 996      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
 997      &  ebr*nss,Uconst,etot
 998    10 format (/'Virtual-chain energies:'//
 999      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1000      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1001      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1002      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1003      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1004      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1005      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1006      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1007      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1008      & ' (SS bridges & dist. cnstr.)'/
1009      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1010      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1011      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1012      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1013      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1014      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1015      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1016      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1017      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1018      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1019      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1020      & 'ETOT=  ',1pE16.6,' (total)')
1021 #endif
1022       return
1023       end
1024 C-----------------------------------------------------------------------
1025       subroutine elj(evdw,evdw_p,evdw_m)
1026 C
1027 C This subroutine calculates the interaction energy of nonbonded side chains
1028 C assuming the LJ potential of interaction.
1029 C
1030       implicit real*8 (a-h,o-z)
1031       include 'DIMENSIONS'
1032       parameter (accur=1.0d-10)
1033       include 'COMMON.GEO'
1034       include 'COMMON.VAR'
1035       include 'COMMON.LOCAL'
1036       include 'COMMON.CHAIN'
1037       include 'COMMON.DERIV'
1038       include 'COMMON.INTERACT'
1039       include 'COMMON.TORSION'
1040       include 'COMMON.SBRIDGE'
1041       include 'COMMON.NAMES'
1042       include 'COMMON.IOUNITS'
1043       include 'COMMON.CONTACTS'
1044       dimension gg(3)
1045 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1046       evdw=0.0D0
1047       do i=iatsc_s,iatsc_e
1048         itypi=itype(i)
1049         itypi1=itype(i+1)
1050         xi=c(1,nres+i)
1051         yi=c(2,nres+i)
1052         zi=c(3,nres+i)
1053 C Change 12/1/95
1054         num_conti=0
1055 C
1056 C Calculate SC interaction energy.
1057 C
1058         do iint=1,nint_gr(i)
1059 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1060 cd   &                  'iend=',iend(i,iint)
1061           do j=istart(i,iint),iend(i,iint)
1062             itypj=itype(j)
1063             xj=c(1,nres+j)-xi
1064             yj=c(2,nres+j)-yi
1065             zj=c(3,nres+j)-zi
1066 C Change 12/1/95 to calculate four-body interactions
1067             rij=xj*xj+yj*yj+zj*zj
1068             rrij=1.0D0/rij
1069 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1070             eps0ij=eps(itypi,itypj)
1071             fac=rrij**expon2
1072             e1=fac*fac*aa(itypi,itypj)
1073             e2=fac*bb(itypi,itypj)
1074             evdwij=e1+e2
1075 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1076 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1077 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1078 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1079 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1080 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1081 #ifdef TSCSC
1082             if (bb(itypi,itypj).gt.0) then
1083                evdw_p=evdw_p+evdwij
1084             else
1085                evdw_m=evdw_m+evdwij
1086             endif
1087 #else
1088             evdw=evdw+evdwij
1089 #endif
1090 C
1091 C Calculate the components of the gradient in DC and X
1092 C
1093             fac=-rrij*(e1+evdwij)
1094             gg(1)=xj*fac
1095             gg(2)=yj*fac
1096             gg(3)=zj*fac
1097 #ifdef TSCSC
1098             if (bb(itypi,itypj).gt.0.0d0) then
1099               do k=1,3
1100                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1101                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1102                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1103                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1104               enddo
1105             else
1106               do k=1,3
1107                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1108                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1109                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1110                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1111               enddo
1112             endif
1113 #else
1114             do k=1,3
1115               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1116               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1117               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1118               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1119             enddo
1120 #endif
1121 cgrad            do k=i,j-1
1122 cgrad              do l=1,3
1123 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1124 cgrad              enddo
1125 cgrad            enddo
1126 C
1127 C 12/1/95, revised on 5/20/97
1128 C
1129 C Calculate the contact function. The ith column of the array JCONT will
1130 C contain the numbers of atoms that make contacts with the atom I (of numbers
1131 C greater than I). The arrays FACONT and GACONT will contain the values of
1132 C the contact function and its derivative.
1133 C
1134 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1135 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1136 C Uncomment next line, if the correlation interactions are contact function only
1137             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1138               rij=dsqrt(rij)
1139               sigij=sigma(itypi,itypj)
1140               r0ij=rs0(itypi,itypj)
1141 C
1142 C Check whether the SC's are not too far to make a contact.
1143 C
1144               rcut=1.5d0*r0ij
1145               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1146 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1147 C
1148               if (fcont.gt.0.0D0) then
1149 C If the SC-SC distance if close to sigma, apply spline.
1150 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1151 cAdam &             fcont1,fprimcont1)
1152 cAdam           fcont1=1.0d0-fcont1
1153 cAdam           if (fcont1.gt.0.0d0) then
1154 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1155 cAdam             fcont=fcont*fcont1
1156 cAdam           endif
1157 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1158 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1159 cga             do k=1,3
1160 cga               gg(k)=gg(k)*eps0ij
1161 cga             enddo
1162 cga             eps0ij=-evdwij*eps0ij
1163 C Uncomment for AL's type of SC correlation interactions.
1164 cadam           eps0ij=-evdwij
1165                 num_conti=num_conti+1
1166                 jcont(num_conti,i)=j
1167                 facont(num_conti,i)=fcont*eps0ij
1168                 fprimcont=eps0ij*fprimcont/rij
1169                 fcont=expon*fcont
1170 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1171 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1172 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1173 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1174                 gacont(1,num_conti,i)=-fprimcont*xj
1175                 gacont(2,num_conti,i)=-fprimcont*yj
1176                 gacont(3,num_conti,i)=-fprimcont*zj
1177 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1178 cd              write (iout,'(2i3,3f10.5)')
1179 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1180               endif
1181             endif
1182           enddo      ! j
1183         enddo        ! iint
1184 C Change 12/1/95
1185         num_cont(i)=num_conti
1186       enddo          ! i
1187       do i=1,nct
1188         do j=1,3
1189           gvdwc(j,i)=expon*gvdwc(j,i)
1190           gvdwx(j,i)=expon*gvdwx(j,i)
1191         enddo
1192       enddo
1193 C******************************************************************************
1194 C
1195 C                              N O T E !!!
1196 C
1197 C To save time, the factor of EXPON has been extracted from ALL components
1198 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1199 C use!
1200 C
1201 C******************************************************************************
1202       return
1203       end
1204 C-----------------------------------------------------------------------------
1205       subroutine eljk(evdw,evdw_p,evdw_m)
1206 C
1207 C This subroutine calculates the interaction energy of nonbonded side chains
1208 C assuming the LJK potential of interaction.
1209 C
1210       implicit real*8 (a-h,o-z)
1211       include 'DIMENSIONS'
1212       include 'COMMON.GEO'
1213       include 'COMMON.VAR'
1214       include 'COMMON.LOCAL'
1215       include 'COMMON.CHAIN'
1216       include 'COMMON.DERIV'
1217       include 'COMMON.INTERACT'
1218       include 'COMMON.IOUNITS'
1219       include 'COMMON.NAMES'
1220       dimension gg(3)
1221       logical scheck
1222 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1223       evdw=0.0D0
1224       do i=iatsc_s,iatsc_e
1225         itypi=itype(i)
1226         itypi1=itype(i+1)
1227         xi=c(1,nres+i)
1228         yi=c(2,nres+i)
1229         zi=c(3,nres+i)
1230 C
1231 C Calculate SC interaction energy.
1232 C
1233         do iint=1,nint_gr(i)
1234           do j=istart(i,iint),iend(i,iint)
1235             itypj=itype(j)
1236             xj=c(1,nres+j)-xi
1237             yj=c(2,nres+j)-yi
1238             zj=c(3,nres+j)-zi
1239             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1240             fac_augm=rrij**expon
1241             e_augm=augm(itypi,itypj)*fac_augm
1242             r_inv_ij=dsqrt(rrij)
1243             rij=1.0D0/r_inv_ij
1244             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1245             fac=r_shift_inv**expon
1246             e1=fac*fac*aa(itypi,itypj)
1247             e2=fac*bb(itypi,itypj)
1248             evdwij=e_augm+e1+e2
1249 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1250 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1251 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1252 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1253 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1254 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1255 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1256 #ifdef TSCSC
1257             if (bb(itypi,itypj).gt.0) then
1258                evdw_p=evdw_p+evdwij
1259             else
1260                evdw_m=evdw_m+evdwij
1261             endif
1262 #else
1263             evdw=evdw+evdwij
1264 #endif
1265 C
1266 C Calculate the components of the gradient in DC and X
1267 C
1268             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1269             gg(1)=xj*fac
1270             gg(2)=yj*fac
1271             gg(3)=zj*fac
1272 #ifdef TSCSC
1273             if (bb(itypi,itypj).gt.0.0d0) then
1274               do k=1,3
1275                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1276                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1277                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1278                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1279               enddo
1280             else
1281               do k=1,3
1282                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1283                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1284                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1285                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1286               enddo
1287             endif
1288 #else
1289             do k=1,3
1290               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1291               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1292               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1293               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1294             enddo
1295 #endif
1296 cgrad            do k=i,j-1
1297 cgrad              do l=1,3
1298 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1299 cgrad              enddo
1300 cgrad            enddo
1301           enddo      ! j
1302         enddo        ! iint
1303       enddo          ! i
1304       do i=1,nct
1305         do j=1,3
1306           gvdwc(j,i)=expon*gvdwc(j,i)
1307           gvdwx(j,i)=expon*gvdwx(j,i)
1308         enddo
1309       enddo
1310       return
1311       end
1312 C-----------------------------------------------------------------------------
1313       subroutine ebp(evdw,evdw_p,evdw_m)
1314 C
1315 C This subroutine calculates the interaction energy of nonbonded side chains
1316 C assuming the Berne-Pechukas potential of interaction.
1317 C
1318       implicit real*8 (a-h,o-z)
1319       include 'DIMENSIONS'
1320       include 'COMMON.GEO'
1321       include 'COMMON.VAR'
1322       include 'COMMON.LOCAL'
1323       include 'COMMON.CHAIN'
1324       include 'COMMON.DERIV'
1325       include 'COMMON.NAMES'
1326       include 'COMMON.INTERACT'
1327       include 'COMMON.IOUNITS'
1328       include 'COMMON.CALC'
1329       common /srutu/ icall
1330 c     double precision rrsave(maxdim)
1331       logical lprn
1332       evdw=0.0D0
1333 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1334       evdw=0.0D0
1335 c     if (icall.eq.0) then
1336 c       lprn=.true.
1337 c     else
1338         lprn=.false.
1339 c     endif
1340       ind=0
1341       do i=iatsc_s,iatsc_e
1342         itypi=itype(i)
1343         itypi1=itype(i+1)
1344         xi=c(1,nres+i)
1345         yi=c(2,nres+i)
1346         zi=c(3,nres+i)
1347         dxi=dc_norm(1,nres+i)
1348         dyi=dc_norm(2,nres+i)
1349         dzi=dc_norm(3,nres+i)
1350 c        dsci_inv=dsc_inv(itypi)
1351         dsci_inv=vbld_inv(i+nres)
1352 C
1353 C Calculate SC interaction energy.
1354 C
1355         do iint=1,nint_gr(i)
1356           do j=istart(i,iint),iend(i,iint)
1357             ind=ind+1
1358             itypj=itype(j)
1359 c            dscj_inv=dsc_inv(itypj)
1360             dscj_inv=vbld_inv(j+nres)
1361             chi1=chi(itypi,itypj)
1362             chi2=chi(itypj,itypi)
1363             chi12=chi1*chi2
1364             chip1=chip(itypi)
1365             chip2=chip(itypj)
1366             chip12=chip1*chip2
1367             alf1=alp(itypi)
1368             alf2=alp(itypj)
1369             alf12=0.5D0*(alf1+alf2)
1370 C For diagnostics only!!!
1371 c           chi1=0.0D0
1372 c           chi2=0.0D0
1373 c           chi12=0.0D0
1374 c           chip1=0.0D0
1375 c           chip2=0.0D0
1376 c           chip12=0.0D0
1377 c           alf1=0.0D0
1378 c           alf2=0.0D0
1379 c           alf12=0.0D0
1380             xj=c(1,nres+j)-xi
1381             yj=c(2,nres+j)-yi
1382             zj=c(3,nres+j)-zi
1383             dxj=dc_norm(1,nres+j)
1384             dyj=dc_norm(2,nres+j)
1385             dzj=dc_norm(3,nres+j)
1386             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1387 cd          if (icall.eq.0) then
1388 cd            rrsave(ind)=rrij
1389 cd          else
1390 cd            rrij=rrsave(ind)
1391 cd          endif
1392             rij=dsqrt(rrij)
1393 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1394             call sc_angular
1395 C Calculate whole angle-dependent part of epsilon and contributions
1396 C to its derivatives
1397             fac=(rrij*sigsq)**expon2
1398             e1=fac*fac*aa(itypi,itypj)
1399             e2=fac*bb(itypi,itypj)
1400             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1401             eps2der=evdwij*eps3rt
1402             eps3der=evdwij*eps2rt
1403             evdwij=evdwij*eps2rt*eps3rt
1404 #ifdef TSCSC
1405             if (bb(itypi,itypj).gt.0) then
1406                evdw_p=evdw_p+evdwij
1407             else
1408                evdw_m=evdw_m+evdwij
1409             endif
1410 #else
1411             evdw=evdw+evdwij
1412 #endif
1413             if (lprn) then
1414             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1415             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1416 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1417 cd     &        restyp(itypi),i,restyp(itypj),j,
1418 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1419 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1420 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1421 cd     &        evdwij
1422             endif
1423 C Calculate gradient components.
1424             e1=e1*eps1*eps2rt**2*eps3rt**2
1425             fac=-expon*(e1+evdwij)
1426             sigder=fac/sigsq
1427             fac=rrij*fac
1428 C Calculate radial part of the gradient
1429             gg(1)=xj*fac
1430             gg(2)=yj*fac
1431             gg(3)=zj*fac
1432 C Calculate the angular part of the gradient and sum add the contributions
1433 C to the appropriate components of the Cartesian gradient.
1434 #ifdef TSCSC
1435             if (bb(itypi,itypj).gt.0) then
1436                call sc_grad
1437             else
1438                call sc_grad_T
1439             endif
1440 #else
1441             call sc_grad
1442 #endif
1443           enddo      ! j
1444         enddo        ! iint
1445       enddo          ! i
1446 c     stop
1447       return
1448       end
1449 C-----------------------------------------------------------------------------
1450       subroutine egb(evdw,evdw_p,evdw_m)
1451 C
1452 C This subroutine calculates the interaction energy of nonbonded side chains
1453 C assuming the Gay-Berne potential of interaction.
1454 C
1455       implicit real*8 (a-h,o-z)
1456       include 'DIMENSIONS'
1457       include 'COMMON.GEO'
1458       include 'COMMON.VAR'
1459       include 'COMMON.LOCAL'
1460       include 'COMMON.CHAIN'
1461       include 'COMMON.DERIV'
1462       include 'COMMON.NAMES'
1463       include 'COMMON.INTERACT'
1464       include 'COMMON.IOUNITS'
1465       include 'COMMON.CALC'
1466       include 'COMMON.CONTROL'
1467       logical lprn
1468       evdw=0.0D0
1469 ccccc      energy_dec=.false.
1470 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1471       evdw=0.0D0
1472       evdw_p=0.0D0
1473       evdw_m=0.0D0
1474       lprn=.false.
1475 c     if (icall.eq.0) lprn=.false.
1476       ind=0
1477       do i=iatsc_s,iatsc_e
1478         itypi=itype(i)
1479         itypi1=itype(i+1)
1480         xi=c(1,nres+i)
1481         yi=c(2,nres+i)
1482         zi=c(3,nres+i)
1483         dxi=dc_norm(1,nres+i)
1484         dyi=dc_norm(2,nres+i)
1485         dzi=dc_norm(3,nres+i)
1486 c        dsci_inv=dsc_inv(itypi)
1487         dsci_inv=vbld_inv(i+nres)
1488 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1489 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1490 C
1491 C Calculate SC interaction energy.
1492 C
1493         do iint=1,nint_gr(i)
1494           do j=istart(i,iint),iend(i,iint)
1495             ind=ind+1
1496             itypj=itype(j)
1497 c            dscj_inv=dsc_inv(itypj)
1498             dscj_inv=vbld_inv(j+nres)
1499 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1500 c     &       1.0d0/vbld(j+nres)
1501 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1502             sig0ij=sigma(itypi,itypj)
1503             chi1=chi(itypi,itypj)
1504             chi2=chi(itypj,itypi)
1505             chi12=chi1*chi2
1506             chip1=chip(itypi)
1507             chip2=chip(itypj)
1508             chip12=chip1*chip2
1509             alf1=alp(itypi)
1510             alf2=alp(itypj)
1511             alf12=0.5D0*(alf1+alf2)
1512 C For diagnostics only!!!
1513 c           chi1=0.0D0
1514 c           chi2=0.0D0
1515 c           chi12=0.0D0
1516 c           chip1=0.0D0
1517 c           chip2=0.0D0
1518 c           chip12=0.0D0
1519 c           alf1=0.0D0
1520 c           alf2=0.0D0
1521 c           alf12=0.0D0
1522             xj=c(1,nres+j)-xi
1523             yj=c(2,nres+j)-yi
1524             zj=c(3,nres+j)-zi
1525             dxj=dc_norm(1,nres+j)
1526             dyj=dc_norm(2,nres+j)
1527             dzj=dc_norm(3,nres+j)
1528 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1529 c            write (iout,*) "j",j," dc_norm",
1530 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1531             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1532             rij=dsqrt(rrij)
1533 C Calculate angle-dependent terms of energy and contributions to their
1534 C derivatives.
1535             call sc_angular
1536             sigsq=1.0D0/sigsq
1537             sig=sig0ij*dsqrt(sigsq)
1538             rij_shift=1.0D0/rij-sig+sig0ij
1539 c for diagnostics; uncomment
1540 c            rij_shift=1.2*sig0ij
1541 C I hate to put IF's in the loops, but here don't have another choice!!!!
1542             if (rij_shift.le.0.0D0) then
1543               evdw=1.0D20
1544 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1545 cd     &        restyp(itypi),i,restyp(itypj),j,
1546 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1547               return
1548             endif
1549             sigder=-sig*sigsq
1550 c---------------------------------------------------------------
1551             rij_shift=1.0D0/rij_shift
1552             fac=rij_shift**expon
1553             e1=fac*fac*aa(itypi,itypj)
1554             e2=fac*bb(itypi,itypj)
1555             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1556             eps2der=evdwij*eps3rt
1557             eps3der=evdwij*eps2rt
1558 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1559 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1560             evdwij=evdwij*eps2rt*eps3rt
1561 #ifdef TSCSC
1562             if (bb(itypi,itypj).gt.0) then
1563                evdw_p=evdw_p+evdwij
1564             else
1565                evdw_m=evdw_m+evdwij
1566             endif
1567 #else
1568             evdw=evdw+evdwij
1569 #endif
1570             if (lprn) then
1571             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1572             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1573             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1574      &        restyp(itypi),i,restyp(itypj),j,
1575      &        epsi,sigm,chi1,chi2,chip1,chip2,
1576      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1577      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1578      &        evdwij
1579             endif
1580
1581             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1582      &                        'evdw',i,j,evdwij
1583
1584 C Calculate gradient components.
1585             e1=e1*eps1*eps2rt**2*eps3rt**2
1586             fac=-expon*(e1+evdwij)*rij_shift
1587             sigder=fac*sigder
1588             fac=rij*fac
1589 c            fac=0.0d0
1590 C Calculate the radial part of the gradient
1591             gg(1)=xj*fac
1592             gg(2)=yj*fac
1593             gg(3)=zj*fac
1594 C Calculate angular part of the gradient.
1595 #ifdef TSCSC
1596             if (bb(itypi,itypj).gt.0) then
1597                call sc_grad
1598             else
1599                call sc_grad_T
1600             endif
1601 #else
1602             call sc_grad
1603 #endif
1604           enddo      ! j
1605         enddo        ! iint
1606       enddo          ! i
1607 c      write (iout,*) "Number of loop steps in EGB:",ind
1608 cccc      energy_dec=.false.
1609       return
1610       end
1611 C-----------------------------------------------------------------------------
1612       subroutine egbv(evdw,evdw_p,evdw_m)
1613 C
1614 C This subroutine calculates the interaction energy of nonbonded side chains
1615 C assuming the Gay-Berne-Vorobjev potential of interaction.
1616 C
1617       implicit real*8 (a-h,o-z)
1618       include 'DIMENSIONS'
1619       include 'COMMON.GEO'
1620       include 'COMMON.VAR'
1621       include 'COMMON.LOCAL'
1622       include 'COMMON.CHAIN'
1623       include 'COMMON.DERIV'
1624       include 'COMMON.NAMES'
1625       include 'COMMON.INTERACT'
1626       include 'COMMON.IOUNITS'
1627       include 'COMMON.CALC'
1628       common /srutu/ icall
1629       logical lprn
1630       evdw=0.0D0
1631 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1632       evdw=0.0D0
1633       lprn=.false.
1634 c     if (icall.eq.0) lprn=.true.
1635       ind=0
1636       do i=iatsc_s,iatsc_e
1637         itypi=itype(i)
1638         itypi1=itype(i+1)
1639         xi=c(1,nres+i)
1640         yi=c(2,nres+i)
1641         zi=c(3,nres+i)
1642         dxi=dc_norm(1,nres+i)
1643         dyi=dc_norm(2,nres+i)
1644         dzi=dc_norm(3,nres+i)
1645 c        dsci_inv=dsc_inv(itypi)
1646         dsci_inv=vbld_inv(i+nres)
1647 C
1648 C Calculate SC interaction energy.
1649 C
1650         do iint=1,nint_gr(i)
1651           do j=istart(i,iint),iend(i,iint)
1652             ind=ind+1
1653             itypj=itype(j)
1654 c            dscj_inv=dsc_inv(itypj)
1655             dscj_inv=vbld_inv(j+nres)
1656             sig0ij=sigma(itypi,itypj)
1657             r0ij=r0(itypi,itypj)
1658             chi1=chi(itypi,itypj)
1659             chi2=chi(itypj,itypi)
1660             chi12=chi1*chi2
1661             chip1=chip(itypi)
1662             chip2=chip(itypj)
1663             chip12=chip1*chip2
1664             alf1=alp(itypi)
1665             alf2=alp(itypj)
1666             alf12=0.5D0*(alf1+alf2)
1667 C For diagnostics only!!!
1668 c           chi1=0.0D0
1669 c           chi2=0.0D0
1670 c           chi12=0.0D0
1671 c           chip1=0.0D0
1672 c           chip2=0.0D0
1673 c           chip12=0.0D0
1674 c           alf1=0.0D0
1675 c           alf2=0.0D0
1676 c           alf12=0.0D0
1677             xj=c(1,nres+j)-xi
1678             yj=c(2,nres+j)-yi
1679             zj=c(3,nres+j)-zi
1680             dxj=dc_norm(1,nres+j)
1681             dyj=dc_norm(2,nres+j)
1682             dzj=dc_norm(3,nres+j)
1683             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1684             rij=dsqrt(rrij)
1685 C Calculate angle-dependent terms of energy and contributions to their
1686 C derivatives.
1687             call sc_angular
1688             sigsq=1.0D0/sigsq
1689             sig=sig0ij*dsqrt(sigsq)
1690             rij_shift=1.0D0/rij-sig+r0ij
1691 C I hate to put IF's in the loops, but here don't have another choice!!!!
1692             if (rij_shift.le.0.0D0) then
1693               evdw=1.0D20
1694               return
1695             endif
1696             sigder=-sig*sigsq
1697 c---------------------------------------------------------------
1698             rij_shift=1.0D0/rij_shift
1699             fac=rij_shift**expon
1700             e1=fac*fac*aa(itypi,itypj)
1701             e2=fac*bb(itypi,itypj)
1702             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1703             eps2der=evdwij*eps3rt
1704             eps3der=evdwij*eps2rt
1705             fac_augm=rrij**expon
1706             e_augm=augm(itypi,itypj)*fac_augm
1707             evdwij=evdwij*eps2rt*eps3rt
1708 #ifdef TSCSC
1709             if (bb(itypi,itypj).gt.0) then
1710                evdw_p=evdw_p+evdwij+e_augm
1711             else
1712                evdw_m=evdw_m+evdwij+e_augm
1713             endif
1714 #else
1715             evdw=evdw+evdwij+e_augm
1716 #endif
1717             if (lprn) then
1718             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1719             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1720             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1721      &        restyp(itypi),i,restyp(itypj),j,
1722      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1723      &        chi1,chi2,chip1,chip2,
1724      &        eps1,eps2rt**2,eps3rt**2,
1725      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1726      &        evdwij+e_augm
1727             endif
1728 C Calculate gradient components.
1729             e1=e1*eps1*eps2rt**2*eps3rt**2
1730             fac=-expon*(e1+evdwij)*rij_shift
1731             sigder=fac*sigder
1732             fac=rij*fac-2*expon*rrij*e_augm
1733 C Calculate the radial part of the gradient
1734             gg(1)=xj*fac
1735             gg(2)=yj*fac
1736             gg(3)=zj*fac
1737 C Calculate angular part of the gradient.
1738 #ifdef TSCSC
1739             if (bb(itypi,itypj).gt.0) then
1740                call sc_grad
1741             else
1742                call sc_grad_T
1743             endif
1744 #else
1745             call sc_grad
1746 #endif
1747           enddo      ! j
1748         enddo        ! iint
1749       enddo          ! i
1750       end
1751 C-----------------------------------------------------------------------------
1752       subroutine sc_angular
1753 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1754 C om12. Called by ebp, egb, and egbv.
1755       implicit none
1756       include 'COMMON.CALC'
1757       include 'COMMON.IOUNITS'
1758       erij(1)=xj*rij
1759       erij(2)=yj*rij
1760       erij(3)=zj*rij
1761       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1762       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1763       om12=dxi*dxj+dyi*dyj+dzi*dzj
1764       chiom12=chi12*om12
1765 C Calculate eps1(om12) and its derivative in om12
1766       faceps1=1.0D0-om12*chiom12
1767       faceps1_inv=1.0D0/faceps1
1768       eps1=dsqrt(faceps1_inv)
1769 C Following variable is eps1*deps1/dom12
1770       eps1_om12=faceps1_inv*chiom12
1771 c diagnostics only
1772 c      faceps1_inv=om12
1773 c      eps1=om12
1774 c      eps1_om12=1.0d0
1775 c      write (iout,*) "om12",om12," eps1",eps1
1776 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1777 C and om12.
1778       om1om2=om1*om2
1779       chiom1=chi1*om1
1780       chiom2=chi2*om2
1781       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1782       sigsq=1.0D0-facsig*faceps1_inv
1783       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1784       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1785       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1786 c diagnostics only
1787 c      sigsq=1.0d0
1788 c      sigsq_om1=0.0d0
1789 c      sigsq_om2=0.0d0
1790 c      sigsq_om12=0.0d0
1791 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1792 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1793 c     &    " eps1",eps1
1794 C Calculate eps2 and its derivatives in om1, om2, and om12.
1795       chipom1=chip1*om1
1796       chipom2=chip2*om2
1797       chipom12=chip12*om12
1798       facp=1.0D0-om12*chipom12
1799       facp_inv=1.0D0/facp
1800       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1801 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1802 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1803 C Following variable is the square root of eps2
1804       eps2rt=1.0D0-facp1*facp_inv
1805 C Following three variables are the derivatives of the square root of eps
1806 C in om1, om2, and om12.
1807       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1808       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1809       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1810 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1811       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1812 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1813 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1814 c     &  " eps2rt_om12",eps2rt_om12
1815 C Calculate whole angle-dependent part of epsilon and contributions
1816 C to its derivatives
1817       return
1818       end
1819
1820 C----------------------------------------------------------------------------
1821       subroutine sc_grad_T
1822       implicit real*8 (a-h,o-z)
1823       include 'DIMENSIONS'
1824       include 'COMMON.CHAIN'
1825       include 'COMMON.DERIV'
1826       include 'COMMON.CALC'
1827       include 'COMMON.IOUNITS'
1828       double precision dcosom1(3),dcosom2(3)
1829       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1830       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1831       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1832      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1833 c diagnostics only
1834 c      eom1=0.0d0
1835 c      eom2=0.0d0
1836 c      eom12=evdwij*eps1_om12
1837 c end diagnostics
1838 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1839 c     &  " sigder",sigder
1840 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1841 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1842       do k=1,3
1843         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1844         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1845       enddo
1846       do k=1,3
1847         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1848       enddo
1849 c      write (iout,*) "gg",(gg(k),k=1,3)
1850       do k=1,3
1851         gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1852      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1853      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1854         gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1855      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1856      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1857 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1858 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1859 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1860 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1861       enddo
1862 C
1863 C Calculate the components of the gradient in DC and X
1864 C
1865 cgrad      do k=i,j-1
1866 cgrad        do l=1,3
1867 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1868 cgrad        enddo
1869 cgrad      enddo
1870       do l=1,3
1871         gvdwcT(l,i)=gvdwcT(l,i)-gg(l)
1872         gvdwcT(l,j)=gvdwcT(l,j)+gg(l)
1873       enddo
1874       return
1875       end
1876
1877 C----------------------------------------------------------------------------
1878       subroutine sc_grad
1879       implicit real*8 (a-h,o-z)
1880       include 'DIMENSIONS'
1881       include 'COMMON.CHAIN'
1882       include 'COMMON.DERIV'
1883       include 'COMMON.CALC'
1884       include 'COMMON.IOUNITS'
1885       double precision dcosom1(3),dcosom2(3)
1886       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1887       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1888       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1889      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1890 c diagnostics only
1891 c      eom1=0.0d0
1892 c      eom2=0.0d0
1893 c      eom12=evdwij*eps1_om12
1894 c end diagnostics
1895 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1896 c     &  " sigder",sigder
1897 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1898 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1899       do k=1,3
1900         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1901         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1902       enddo
1903       do k=1,3
1904         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1905       enddo
1906 c      write (iout,*) "gg",(gg(k),k=1,3)
1907       do k=1,3
1908         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1909      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1910      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1911         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1912      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1913      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1914 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1915 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1916 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1917 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1918       enddo
1919 C
1920 C Calculate the components of the gradient in DC and X
1921 C
1922 cgrad      do k=i,j-1
1923 cgrad        do l=1,3
1924 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1925 cgrad        enddo
1926 cgrad      enddo
1927       do l=1,3
1928         gvdwc(l,i)=gvdwc(l,i)-gg(l)
1929         gvdwc(l,j)=gvdwc(l,j)+gg(l)
1930       enddo
1931       return
1932       end
1933 C-----------------------------------------------------------------------
1934       subroutine e_softsphere(evdw)
1935 C
1936 C This subroutine calculates the interaction energy of nonbonded side chains
1937 C assuming the LJ potential of interaction.
1938 C
1939       implicit real*8 (a-h,o-z)
1940       include 'DIMENSIONS'
1941       parameter (accur=1.0d-10)
1942       include 'COMMON.GEO'
1943       include 'COMMON.VAR'
1944       include 'COMMON.LOCAL'
1945       include 'COMMON.CHAIN'
1946       include 'COMMON.DERIV'
1947       include 'COMMON.INTERACT'
1948       include 'COMMON.TORSION'
1949       include 'COMMON.SBRIDGE'
1950       include 'COMMON.NAMES'
1951       include 'COMMON.IOUNITS'
1952       include 'COMMON.CONTACTS'
1953       dimension gg(3)
1954 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1955       evdw=0.0D0
1956       do i=iatsc_s,iatsc_e
1957         itypi=itype(i)
1958         itypi1=itype(i+1)
1959         xi=c(1,nres+i)
1960         yi=c(2,nres+i)
1961         zi=c(3,nres+i)
1962 C
1963 C Calculate SC interaction energy.
1964 C
1965         do iint=1,nint_gr(i)
1966 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1967 cd   &                  'iend=',iend(i,iint)
1968           do j=istart(i,iint),iend(i,iint)
1969             itypj=itype(j)
1970             xj=c(1,nres+j)-xi
1971             yj=c(2,nres+j)-yi
1972             zj=c(3,nres+j)-zi
1973             rij=xj*xj+yj*yj+zj*zj
1974 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1975             r0ij=r0(itypi,itypj)
1976             r0ijsq=r0ij*r0ij
1977 c            print *,i,j,r0ij,dsqrt(rij)
1978             if (rij.lt.r0ijsq) then
1979               evdwij=0.25d0*(rij-r0ijsq)**2
1980               fac=rij-r0ijsq
1981             else
1982               evdwij=0.0d0
1983               fac=0.0d0
1984             endif
1985             evdw=evdw+evdwij
1986 C
1987 C Calculate the components of the gradient in DC and X
1988 C
1989             gg(1)=xj*fac
1990             gg(2)=yj*fac
1991             gg(3)=zj*fac
1992             do k=1,3
1993               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1994               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1995               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1996               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1997             enddo
1998 cgrad            do k=i,j-1
1999 cgrad              do l=1,3
2000 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2001 cgrad              enddo
2002 cgrad            enddo
2003           enddo ! j
2004         enddo ! iint
2005       enddo ! i
2006       return
2007       end
2008 C--------------------------------------------------------------------------
2009       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2010      &              eello_turn4)
2011 C
2012 C Soft-sphere potential of p-p interaction
2013 C
2014       implicit real*8 (a-h,o-z)
2015       include 'DIMENSIONS'
2016       include 'COMMON.CONTROL'
2017       include 'COMMON.IOUNITS'
2018       include 'COMMON.GEO'
2019       include 'COMMON.VAR'
2020       include 'COMMON.LOCAL'
2021       include 'COMMON.CHAIN'
2022       include 'COMMON.DERIV'
2023       include 'COMMON.INTERACT'
2024       include 'COMMON.CONTACTS'
2025       include 'COMMON.TORSION'
2026       include 'COMMON.VECTORS'
2027       include 'COMMON.FFIELD'
2028       dimension ggg(3)
2029 cd      write(iout,*) 'In EELEC_soft_sphere'
2030       ees=0.0D0
2031       evdw1=0.0D0
2032       eel_loc=0.0d0
2033       eello_turn3=0.0d0
2034       eello_turn4=0.0d0
2035       ind=0
2036       do i=iatel_s,iatel_e
2037         dxi=dc(1,i)
2038         dyi=dc(2,i)
2039         dzi=dc(3,i)
2040         xmedi=c(1,i)+0.5d0*dxi
2041         ymedi=c(2,i)+0.5d0*dyi
2042         zmedi=c(3,i)+0.5d0*dzi
2043         num_conti=0
2044 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2045         do j=ielstart(i),ielend(i)
2046           ind=ind+1
2047           iteli=itel(i)
2048           itelj=itel(j)
2049           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2050           r0ij=rpp(iteli,itelj)
2051           r0ijsq=r0ij*r0ij
2052           dxj=dc(1,j)
2053           dyj=dc(2,j)
2054           dzj=dc(3,j)
2055           xj=c(1,j)+0.5D0*dxj-xmedi
2056           yj=c(2,j)+0.5D0*dyj-ymedi
2057           zj=c(3,j)+0.5D0*dzj-zmedi
2058           rij=xj*xj+yj*yj+zj*zj
2059           if (rij.lt.r0ijsq) then
2060             evdw1ij=0.25d0*(rij-r0ijsq)**2
2061             fac=rij-r0ijsq
2062           else
2063             evdw1ij=0.0d0
2064             fac=0.0d0
2065           endif
2066           evdw1=evdw1+evdw1ij
2067 C
2068 C Calculate contributions to the Cartesian gradient.
2069 C
2070           ggg(1)=fac*xj
2071           ggg(2)=fac*yj
2072           ggg(3)=fac*zj
2073           do k=1,3
2074             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2075             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2076           enddo
2077 *
2078 * Loop over residues i+1 thru j-1.
2079 *
2080 cgrad          do k=i+1,j-1
2081 cgrad            do l=1,3
2082 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2083 cgrad            enddo
2084 cgrad          enddo
2085         enddo ! j
2086       enddo   ! i
2087 cgrad      do i=nnt,nct-1
2088 cgrad        do k=1,3
2089 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2090 cgrad        enddo
2091 cgrad        do j=i+1,nct-1
2092 cgrad          do k=1,3
2093 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2094 cgrad          enddo
2095 cgrad        enddo
2096 cgrad      enddo
2097       return
2098       end
2099 c------------------------------------------------------------------------------
2100       subroutine vec_and_deriv
2101       implicit real*8 (a-h,o-z)
2102       include 'DIMENSIONS'
2103 #ifdef MPI
2104       include 'mpif.h'
2105 #endif
2106       include 'COMMON.IOUNITS'
2107       include 'COMMON.GEO'
2108       include 'COMMON.VAR'
2109       include 'COMMON.LOCAL'
2110       include 'COMMON.CHAIN'
2111       include 'COMMON.VECTORS'
2112       include 'COMMON.SETUP'
2113       include 'COMMON.TIME1'
2114       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2115 C Compute the local reference systems. For reference system (i), the
2116 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2117 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2118 #ifdef PARVEC
2119       do i=ivec_start,ivec_end
2120 #else
2121       do i=1,nres-1
2122 #endif
2123           if (i.eq.nres-1) then
2124 C Case of the last full residue
2125 C Compute the Z-axis
2126             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2127             costh=dcos(pi-theta(nres))
2128             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2129             do k=1,3
2130               uz(k,i)=fac*uz(k,i)
2131             enddo
2132 C Compute the derivatives of uz
2133             uzder(1,1,1)= 0.0d0
2134             uzder(2,1,1)=-dc_norm(3,i-1)
2135             uzder(3,1,1)= dc_norm(2,i-1)
2136             uzder(1,2,1)= dc_norm(3,i-1)
2137             uzder(2,2,1)= 0.0d0
2138             uzder(3,2,1)=-dc_norm(1,i-1)
2139             uzder(1,3,1)=-dc_norm(2,i-1)
2140             uzder(2,3,1)= dc_norm(1,i-1)
2141             uzder(3,3,1)= 0.0d0
2142             uzder(1,1,2)= 0.0d0
2143             uzder(2,1,2)= dc_norm(3,i)
2144             uzder(3,1,2)=-dc_norm(2,i)
2145             uzder(1,2,2)=-dc_norm(3,i)
2146             uzder(2,2,2)= 0.0d0
2147             uzder(3,2,2)= dc_norm(1,i)
2148             uzder(1,3,2)= dc_norm(2,i)
2149             uzder(2,3,2)=-dc_norm(1,i)
2150             uzder(3,3,2)= 0.0d0
2151 C Compute the Y-axis
2152             facy=fac
2153             do k=1,3
2154               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2155             enddo
2156 C Compute the derivatives of uy
2157             do j=1,3
2158               do k=1,3
2159                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2160      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2161                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2162               enddo
2163               uyder(j,j,1)=uyder(j,j,1)-costh
2164               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2165             enddo
2166             do j=1,2
2167               do k=1,3
2168                 do l=1,3
2169                   uygrad(l,k,j,i)=uyder(l,k,j)
2170                   uzgrad(l,k,j,i)=uzder(l,k,j)
2171                 enddo
2172               enddo
2173             enddo
2174             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2175             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2176             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2177             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2178           else
2179 C Other residues
2180 C Compute the Z-axis
2181             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2182             costh=dcos(pi-theta(i+2))
2183             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2184             do k=1,3
2185               uz(k,i)=fac*uz(k,i)
2186             enddo
2187 C Compute the derivatives of uz
2188             uzder(1,1,1)= 0.0d0
2189             uzder(2,1,1)=-dc_norm(3,i+1)
2190             uzder(3,1,1)= dc_norm(2,i+1)
2191             uzder(1,2,1)= dc_norm(3,i+1)
2192             uzder(2,2,1)= 0.0d0
2193             uzder(3,2,1)=-dc_norm(1,i+1)
2194             uzder(1,3,1)=-dc_norm(2,i+1)
2195             uzder(2,3,1)= dc_norm(1,i+1)
2196             uzder(3,3,1)= 0.0d0
2197             uzder(1,1,2)= 0.0d0
2198             uzder(2,1,2)= dc_norm(3,i)
2199             uzder(3,1,2)=-dc_norm(2,i)
2200             uzder(1,2,2)=-dc_norm(3,i)
2201             uzder(2,2,2)= 0.0d0
2202             uzder(3,2,2)= dc_norm(1,i)
2203             uzder(1,3,2)= dc_norm(2,i)
2204             uzder(2,3,2)=-dc_norm(1,i)
2205             uzder(3,3,2)= 0.0d0
2206 C Compute the Y-axis
2207             facy=fac
2208             do k=1,3
2209               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2210             enddo
2211 C Compute the derivatives of uy
2212             do j=1,3
2213               do k=1,3
2214                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2215      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2216                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2217               enddo
2218               uyder(j,j,1)=uyder(j,j,1)-costh
2219               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2220             enddo
2221             do j=1,2
2222               do k=1,3
2223                 do l=1,3
2224                   uygrad(l,k,j,i)=uyder(l,k,j)
2225                   uzgrad(l,k,j,i)=uzder(l,k,j)
2226                 enddo
2227               enddo
2228             enddo
2229             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2230             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2231             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2232             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2233           endif
2234       enddo
2235       do i=1,nres-1
2236         vbld_inv_temp(1)=vbld_inv(i+1)
2237         if (i.lt.nres-1) then
2238           vbld_inv_temp(2)=vbld_inv(i+2)
2239           else
2240           vbld_inv_temp(2)=vbld_inv(i)
2241           endif
2242         do j=1,2
2243           do k=1,3
2244             do l=1,3
2245               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2246               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2247             enddo
2248           enddo
2249         enddo
2250       enddo
2251 #if defined(PARVEC) && defined(MPI)
2252       if (nfgtasks1.gt.1) then
2253         time00=MPI_Wtime()
2254 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2255 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2256 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2257         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2258      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2259      &   FG_COMM1,IERR)
2260         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2261      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2262      &   FG_COMM1,IERR)
2263         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2264      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2265      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2266         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2267      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2268      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2269         time_gather=time_gather+MPI_Wtime()-time00
2270       endif
2271 c      if (fg_rank.eq.0) then
2272 c        write (iout,*) "Arrays UY and UZ"
2273 c        do i=1,nres-1
2274 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2275 c     &     (uz(k,i),k=1,3)
2276 c        enddo
2277 c      endif
2278 #endif
2279       return
2280       end
2281 C-----------------------------------------------------------------------------
2282       subroutine check_vecgrad
2283       implicit real*8 (a-h,o-z)
2284       include 'DIMENSIONS'
2285       include 'COMMON.IOUNITS'
2286       include 'COMMON.GEO'
2287       include 'COMMON.VAR'
2288       include 'COMMON.LOCAL'
2289       include 'COMMON.CHAIN'
2290       include 'COMMON.VECTORS'
2291       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2292       dimension uyt(3,maxres),uzt(3,maxres)
2293       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2294       double precision delta /1.0d-7/
2295       call vec_and_deriv
2296 cd      do i=1,nres
2297 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2298 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2299 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2300 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2301 cd     &     (dc_norm(if90,i),if90=1,3)
2302 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2303 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2304 cd          write(iout,'(a)')
2305 cd      enddo
2306       do i=1,nres
2307         do j=1,2
2308           do k=1,3
2309             do l=1,3
2310               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2311               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2312             enddo
2313           enddo
2314         enddo
2315       enddo
2316       call vec_and_deriv
2317       do i=1,nres
2318         do j=1,3
2319           uyt(j,i)=uy(j,i)
2320           uzt(j,i)=uz(j,i)
2321         enddo
2322       enddo
2323       do i=1,nres
2324 cd        write (iout,*) 'i=',i
2325         do k=1,3
2326           erij(k)=dc_norm(k,i)
2327         enddo
2328         do j=1,3
2329           do k=1,3
2330             dc_norm(k,i)=erij(k)
2331           enddo
2332           dc_norm(j,i)=dc_norm(j,i)+delta
2333 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2334 c          do k=1,3
2335 c            dc_norm(k,i)=dc_norm(k,i)/fac
2336 c          enddo
2337 c          write (iout,*) (dc_norm(k,i),k=1,3)
2338 c          write (iout,*) (erij(k),k=1,3)
2339           call vec_and_deriv
2340           do k=1,3
2341             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2342             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2343             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2344             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2345           enddo
2346 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2347 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2348 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2349         enddo
2350         do k=1,3
2351           dc_norm(k,i)=erij(k)
2352         enddo
2353 cd        do k=1,3
2354 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2355 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2356 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2357 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2358 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2359 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2360 cd          write (iout,'(a)')
2361 cd        enddo
2362       enddo
2363       return
2364       end
2365 C--------------------------------------------------------------------------
2366       subroutine set_matrices
2367       implicit real*8 (a-h,o-z)
2368       include 'DIMENSIONS'
2369 #ifdef MPI
2370       include "mpif.h"
2371       include "COMMON.SETUP"
2372       integer IERR
2373       integer status(MPI_STATUS_SIZE)
2374 #endif
2375       include 'COMMON.IOUNITS'
2376       include 'COMMON.GEO'
2377       include 'COMMON.VAR'
2378       include 'COMMON.LOCAL'
2379       include 'COMMON.CHAIN'
2380       include 'COMMON.DERIV'
2381       include 'COMMON.INTERACT'
2382       include 'COMMON.CONTACTS'
2383       include 'COMMON.TORSION'
2384       include 'COMMON.VECTORS'
2385       include 'COMMON.FFIELD'
2386       double precision auxvec(2),auxmat(2,2)
2387 C
2388 C Compute the virtual-bond-torsional-angle dependent quantities needed
2389 C to calculate the el-loc multibody terms of various order.
2390 C
2391 #ifdef PARMAT
2392       do i=ivec_start+2,ivec_end+2
2393 #else
2394       do i=3,nres+1
2395 #endif
2396         if (i .lt. nres+1) then
2397           sin1=dsin(phi(i))
2398           cos1=dcos(phi(i))
2399           sintab(i-2)=sin1
2400           costab(i-2)=cos1
2401           obrot(1,i-2)=cos1
2402           obrot(2,i-2)=sin1
2403           sin2=dsin(2*phi(i))
2404           cos2=dcos(2*phi(i))
2405           sintab2(i-2)=sin2
2406           costab2(i-2)=cos2
2407           obrot2(1,i-2)=cos2
2408           obrot2(2,i-2)=sin2
2409           Ug(1,1,i-2)=-cos1
2410           Ug(1,2,i-2)=-sin1
2411           Ug(2,1,i-2)=-sin1
2412           Ug(2,2,i-2)= cos1
2413           Ug2(1,1,i-2)=-cos2
2414           Ug2(1,2,i-2)=-sin2
2415           Ug2(2,1,i-2)=-sin2
2416           Ug2(2,2,i-2)= cos2
2417         else
2418           costab(i-2)=1.0d0
2419           sintab(i-2)=0.0d0
2420           obrot(1,i-2)=1.0d0
2421           obrot(2,i-2)=0.0d0
2422           obrot2(1,i-2)=0.0d0
2423           obrot2(2,i-2)=0.0d0
2424           Ug(1,1,i-2)=1.0d0
2425           Ug(1,2,i-2)=0.0d0
2426           Ug(2,1,i-2)=0.0d0
2427           Ug(2,2,i-2)=1.0d0
2428           Ug2(1,1,i-2)=0.0d0
2429           Ug2(1,2,i-2)=0.0d0
2430           Ug2(2,1,i-2)=0.0d0
2431           Ug2(2,2,i-2)=0.0d0
2432         endif
2433         if (i .gt. 3 .and. i .lt. nres+1) then
2434           obrot_der(1,i-2)=-sin1
2435           obrot_der(2,i-2)= cos1
2436           Ugder(1,1,i-2)= sin1
2437           Ugder(1,2,i-2)=-cos1
2438           Ugder(2,1,i-2)=-cos1
2439           Ugder(2,2,i-2)=-sin1
2440           dwacos2=cos2+cos2
2441           dwasin2=sin2+sin2
2442           obrot2_der(1,i-2)=-dwasin2
2443           obrot2_der(2,i-2)= dwacos2
2444           Ug2der(1,1,i-2)= dwasin2
2445           Ug2der(1,2,i-2)=-dwacos2
2446           Ug2der(2,1,i-2)=-dwacos2
2447           Ug2der(2,2,i-2)=-dwasin2
2448         else
2449           obrot_der(1,i-2)=0.0d0
2450           obrot_der(2,i-2)=0.0d0
2451           Ugder(1,1,i-2)=0.0d0
2452           Ugder(1,2,i-2)=0.0d0
2453           Ugder(2,1,i-2)=0.0d0
2454           Ugder(2,2,i-2)=0.0d0
2455           obrot2_der(1,i-2)=0.0d0
2456           obrot2_der(2,i-2)=0.0d0
2457           Ug2der(1,1,i-2)=0.0d0
2458           Ug2der(1,2,i-2)=0.0d0
2459           Ug2der(2,1,i-2)=0.0d0
2460           Ug2der(2,2,i-2)=0.0d0
2461         endif
2462 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2463         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2464           iti = itortyp(itype(i-2))
2465         else
2466           iti=ntortyp+1
2467         endif
2468 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2469         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2470           iti1 = itortyp(itype(i-1))
2471         else
2472           iti1=ntortyp+1
2473         endif
2474 cd        write (iout,*) '*******i',i,' iti1',iti
2475 cd        write (iout,*) 'b1',b1(:,iti)
2476 cd        write (iout,*) 'b2',b2(:,iti)
2477 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2478 c        if (i .gt. iatel_s+2) then
2479         if (i .gt. nnt+2) then
2480           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2481           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2482           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2483      &    then
2484           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2485           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2486           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2487           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2488           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2489           endif
2490         else
2491           do k=1,2
2492             Ub2(k,i-2)=0.0d0
2493             Ctobr(k,i-2)=0.0d0
2494             Dtobr2(k,i-2)=0.0d0
2495             do l=1,2
2496               EUg(l,k,i-2)=0.0d0
2497               CUg(l,k,i-2)=0.0d0
2498               DUg(l,k,i-2)=0.0d0
2499               DtUg2(l,k,i-2)=0.0d0
2500             enddo
2501           enddo
2502         endif
2503         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2504         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2505         do k=1,2
2506           muder(k,i-2)=Ub2der(k,i-2)
2507         enddo
2508 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2509         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2510           iti1 = itortyp(itype(i-1))
2511         else
2512           iti1=ntortyp+1
2513         endif
2514         do k=1,2
2515           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2516         enddo
2517 cd        write (iout,*) 'mu ',mu(:,i-2)
2518 cd        write (iout,*) 'mu1',mu1(:,i-2)
2519 cd        write (iout,*) 'mu2',mu2(:,i-2)
2520         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2521      &  then
2522         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2523         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2524         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2525         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2526         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2527 C Vectors and matrices dependent on a single virtual-bond dihedral.
2528         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2529         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2530         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2531         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2532         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2533         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2534         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2535         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2536         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2537         endif
2538       enddo
2539 C Matrices dependent on two consecutive virtual-bond dihedrals.
2540 C The order of matrices is from left to right.
2541       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2542      &then
2543 c      do i=max0(ivec_start,2),ivec_end
2544       do i=2,nres-1
2545         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2546         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2547         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2548         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2549         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2550         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2551         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2552         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2553       enddo
2554       endif
2555 #if defined(MPI) && defined(PARMAT)
2556 #ifdef DEBUG
2557 c      if (fg_rank.eq.0) then
2558         write (iout,*) "Arrays UG and UGDER before GATHER"
2559         do i=1,nres-1
2560           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2561      &     ((ug(l,k,i),l=1,2),k=1,2),
2562      &     ((ugder(l,k,i),l=1,2),k=1,2)
2563         enddo
2564         write (iout,*) "Arrays UG2 and UG2DER"
2565         do i=1,nres-1
2566           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2567      &     ((ug2(l,k,i),l=1,2),k=1,2),
2568      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2569         enddo
2570         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2571         do i=1,nres-1
2572           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2573      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2574      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2575         enddo
2576         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2577         do i=1,nres-1
2578           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2579      &     costab(i),sintab(i),costab2(i),sintab2(i)
2580         enddo
2581         write (iout,*) "Array MUDER"
2582         do i=1,nres-1
2583           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2584         enddo
2585 c      endif
2586 #endif
2587       if (nfgtasks.gt.1) then
2588         time00=MPI_Wtime()
2589 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2590 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2591 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2592 #ifdef MATGATHER
2593         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2594      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2595      &   FG_COMM1,IERR)
2596         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2597      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2598      &   FG_COMM1,IERR)
2599         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2600      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2601      &   FG_COMM1,IERR)
2602         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2603      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2604      &   FG_COMM1,IERR)
2605         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2606      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2607      &   FG_COMM1,IERR)
2608         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2609      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2610      &   FG_COMM1,IERR)
2611         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2612      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2613      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2614         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2615      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2616      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2617         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2618      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2619      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2620         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2621      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2622      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2623         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2624      &  then
2625         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2626      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2627      &   FG_COMM1,IERR)
2628         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2629      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2630      &   FG_COMM1,IERR)
2631         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2632      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2633      &   FG_COMM1,IERR)
2634        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2635      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2636      &   FG_COMM1,IERR)
2637         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2638      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2639      &   FG_COMM1,IERR)
2640         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2641      &   ivec_count(fg_rank1),
2642      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2643      &   FG_COMM1,IERR)
2644         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2645      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2646      &   FG_COMM1,IERR)
2647         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2648      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2649      &   FG_COMM1,IERR)
2650         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2651      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2652      &   FG_COMM1,IERR)
2653         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2654      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2655      &   FG_COMM1,IERR)
2656         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2657      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2658      &   FG_COMM1,IERR)
2659         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2660      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2661      &   FG_COMM1,IERR)
2662         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2663      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2664      &   FG_COMM1,IERR)
2665         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2666      &   ivec_count(fg_rank1),
2667      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2668      &   FG_COMM1,IERR)
2669         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2670      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2671      &   FG_COMM1,IERR)
2672        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2673      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2674      &   FG_COMM1,IERR)
2675         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2676      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2677      &   FG_COMM1,IERR)
2678        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2679      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2680      &   FG_COMM1,IERR)
2681         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2682      &   ivec_count(fg_rank1),
2683      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2684      &   FG_COMM1,IERR)
2685         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2686      &   ivec_count(fg_rank1),
2687      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2688      &   FG_COMM1,IERR)
2689         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2690      &   ivec_count(fg_rank1),
2691      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2692      &   MPI_MAT2,FG_COMM1,IERR)
2693         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2694      &   ivec_count(fg_rank1),
2695      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2696      &   MPI_MAT2,FG_COMM1,IERR)
2697         endif
2698 #else
2699 c Passes matrix info through the ring
2700       isend=fg_rank1
2701       irecv=fg_rank1-1
2702       if (irecv.lt.0) irecv=nfgtasks1-1
2703       iprev=irecv
2704       inext=fg_rank1+1
2705       if (inext.ge.nfgtasks1) inext=0
2706       do i=1,nfgtasks1-1
2707 c        write (iout,*) "isend",isend," irecv",irecv
2708 c        call flush(iout)
2709         lensend=lentyp(isend)
2710         lenrecv=lentyp(irecv)
2711 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2712 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2713 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2714 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2715 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2716 c        write (iout,*) "Gather ROTAT1"
2717 c        call flush(iout)
2718 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2719 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2720 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2721 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2722 c        write (iout,*) "Gather ROTAT2"
2723 c        call flush(iout)
2724         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2725      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2726      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2727      &   iprev,4400+irecv,FG_COMM,status,IERR)
2728 c        write (iout,*) "Gather ROTAT_OLD"
2729 c        call flush(iout)
2730         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2731      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2732      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2733      &   iprev,5500+irecv,FG_COMM,status,IERR)
2734 c        write (iout,*) "Gather PRECOMP11"
2735 c        call flush(iout)
2736         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2737      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2738      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2739      &   iprev,6600+irecv,FG_COMM,status,IERR)
2740 c        write (iout,*) "Gather PRECOMP12"
2741 c        call flush(iout)
2742         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2743      &  then
2744         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2745      &   MPI_ROTAT2(lensend),inext,7700+isend,
2746      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2747      &   iprev,7700+irecv,FG_COMM,status,IERR)
2748 c        write (iout,*) "Gather PRECOMP21"
2749 c        call flush(iout)
2750         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2751      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2752      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2753      &   iprev,8800+irecv,FG_COMM,status,IERR)
2754 c        write (iout,*) "Gather PRECOMP22"
2755 c        call flush(iout)
2756         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2757      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2758      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2759      &   MPI_PRECOMP23(lenrecv),
2760      &   iprev,9900+irecv,FG_COMM,status,IERR)
2761 c        write (iout,*) "Gather PRECOMP23"
2762 c        call flush(iout)
2763         endif
2764         isend=irecv
2765         irecv=irecv-1
2766         if (irecv.lt.0) irecv=nfgtasks1-1
2767       enddo
2768 #endif
2769         time_gather=time_gather+MPI_Wtime()-time00
2770       endif
2771 #ifdef DEBUG
2772 c      if (fg_rank.eq.0) then
2773         write (iout,*) "Arrays UG and UGDER"
2774         do i=1,nres-1
2775           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2776      &     ((ug(l,k,i),l=1,2),k=1,2),
2777      &     ((ugder(l,k,i),l=1,2),k=1,2)
2778         enddo
2779         write (iout,*) "Arrays UG2 and UG2DER"
2780         do i=1,nres-1
2781           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2782      &     ((ug2(l,k,i),l=1,2),k=1,2),
2783      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2784         enddo
2785         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2786         do i=1,nres-1
2787           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2788      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2789      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2790         enddo
2791         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2792         do i=1,nres-1
2793           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2794      &     costab(i),sintab(i),costab2(i),sintab2(i)
2795         enddo
2796         write (iout,*) "Array MUDER"
2797         do i=1,nres-1
2798           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2799         enddo
2800 c      endif
2801 #endif
2802 #endif
2803 cd      do i=1,nres
2804 cd        iti = itortyp(itype(i))
2805 cd        write (iout,*) i
2806 cd        do j=1,2
2807 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2808 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2809 cd        enddo
2810 cd      enddo
2811       return
2812       end
2813 C--------------------------------------------------------------------------
2814       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2815 C
2816 C This subroutine calculates the average interaction energy and its gradient
2817 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2818 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2819 C The potential depends both on the distance of peptide-group centers and on
2820 C the orientation of the CA-CA virtual bonds.
2821 C
2822       implicit real*8 (a-h,o-z)
2823 #ifdef MPI
2824       include 'mpif.h'
2825 #endif
2826       include 'DIMENSIONS'
2827       include 'COMMON.CONTROL'
2828       include 'COMMON.SETUP'
2829       include 'COMMON.IOUNITS'
2830       include 'COMMON.GEO'
2831       include 'COMMON.VAR'
2832       include 'COMMON.LOCAL'
2833       include 'COMMON.CHAIN'
2834       include 'COMMON.DERIV'
2835       include 'COMMON.INTERACT'
2836       include 'COMMON.CONTACTS'
2837       include 'COMMON.TORSION'
2838       include 'COMMON.VECTORS'
2839       include 'COMMON.FFIELD'
2840       include 'COMMON.TIME1'
2841       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2842      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2843       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2844      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2845       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2846      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2847      &    num_conti,j1,j2
2848 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2849 #ifdef MOMENT
2850       double precision scal_el /1.0d0/
2851 #else
2852       double precision scal_el /0.5d0/
2853 #endif
2854 C 12/13/98
2855 C 13-go grudnia roku pamietnego...
2856       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2857      &                   0.0d0,1.0d0,0.0d0,
2858      &                   0.0d0,0.0d0,1.0d0/
2859 cd      write(iout,*) 'In EELEC'
2860 cd      do i=1,nloctyp
2861 cd        write(iout,*) 'Type',i
2862 cd        write(iout,*) 'B1',B1(:,i)
2863 cd        write(iout,*) 'B2',B2(:,i)
2864 cd        write(iout,*) 'CC',CC(:,:,i)
2865 cd        write(iout,*) 'DD',DD(:,:,i)
2866 cd        write(iout,*) 'EE',EE(:,:,i)
2867 cd      enddo
2868 cd      call check_vecgrad
2869 cd      stop
2870       if (icheckgrad.eq.1) then
2871         do i=1,nres-1
2872           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2873           do k=1,3
2874             dc_norm(k,i)=dc(k,i)*fac
2875           enddo
2876 c          write (iout,*) 'i',i,' fac',fac
2877         enddo
2878       endif
2879       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2880      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2881      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2882 c        call vec_and_deriv
2883 #ifdef TIMING
2884         time01=MPI_Wtime()
2885 #endif
2886         call set_matrices
2887 #ifdef TIMING
2888         time_mat=time_mat+MPI_Wtime()-time01
2889 #endif
2890       endif
2891 cd      do i=1,nres-1
2892 cd        write (iout,*) 'i=',i
2893 cd        do k=1,3
2894 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2895 cd        enddo
2896 cd        do k=1,3
2897 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2898 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2899 cd        enddo
2900 cd      enddo
2901       t_eelecij=0.0d0
2902       ees=0.0D0
2903       evdw1=0.0D0
2904       eel_loc=0.0d0
2905       eello_turn3=0.0d0
2906       eello_turn4=0.0d0
2907       ind=0
2908       do i=1,nres
2909         num_cont_hb(i)=0
2910       enddo
2911 cd      print '(a)','Enter EELEC'
2912 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2913       do i=1,nres
2914         gel_loc_loc(i)=0.0d0
2915         gcorr_loc(i)=0.0d0
2916       enddo
2917 c
2918 c
2919 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2920 C
2921 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2922 C
2923       do i=iturn3_start,iturn3_end
2924         dxi=dc(1,i)
2925         dyi=dc(2,i)
2926         dzi=dc(3,i)
2927         dx_normi=dc_norm(1,i)
2928         dy_normi=dc_norm(2,i)
2929         dz_normi=dc_norm(3,i)
2930         xmedi=c(1,i)+0.5d0*dxi
2931         ymedi=c(2,i)+0.5d0*dyi
2932         zmedi=c(3,i)+0.5d0*dzi
2933         num_conti=0
2934         call eelecij(i,i+2,ees,evdw1,eel_loc)
2935         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2936         num_cont_hb(i)=num_conti
2937       enddo
2938       do i=iturn4_start,iturn4_end
2939         dxi=dc(1,i)
2940         dyi=dc(2,i)
2941         dzi=dc(3,i)
2942         dx_normi=dc_norm(1,i)
2943         dy_normi=dc_norm(2,i)
2944         dz_normi=dc_norm(3,i)
2945         xmedi=c(1,i)+0.5d0*dxi
2946         ymedi=c(2,i)+0.5d0*dyi
2947         zmedi=c(3,i)+0.5d0*dzi
2948         num_conti=num_cont_hb(i)
2949         call eelecij(i,i+3,ees,evdw1,eel_loc)
2950         if (wturn4.gt.0.0d0) call eturn4(i,eello_turn4)
2951         num_cont_hb(i)=num_conti
2952       enddo   ! i
2953 c
2954 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2955 c
2956       do i=iatel_s,iatel_e
2957         dxi=dc(1,i)
2958         dyi=dc(2,i)
2959         dzi=dc(3,i)
2960         dx_normi=dc_norm(1,i)
2961         dy_normi=dc_norm(2,i)
2962         dz_normi=dc_norm(3,i)
2963         xmedi=c(1,i)+0.5d0*dxi
2964         ymedi=c(2,i)+0.5d0*dyi
2965         zmedi=c(3,i)+0.5d0*dzi
2966 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2967         num_conti=num_cont_hb(i)
2968         do j=ielstart(i),ielend(i)
2969           call eelecij(i,j,ees,evdw1,eel_loc)
2970         enddo ! j
2971         num_cont_hb(i)=num_conti
2972       enddo   ! i
2973 c      write (iout,*) "Number of loop steps in EELEC:",ind
2974 cd      do i=1,nres
2975 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2976 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2977 cd      enddo
2978 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2979 ccc      eel_loc=eel_loc+eello_turn3
2980 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2981       return
2982       end
2983 C-------------------------------------------------------------------------------
2984       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2985       implicit real*8 (a-h,o-z)
2986       include 'DIMENSIONS'
2987 #ifdef MPI
2988       include "mpif.h"
2989 #endif
2990       include 'COMMON.CONTROL'
2991       include 'COMMON.IOUNITS'
2992       include 'COMMON.GEO'
2993       include 'COMMON.VAR'
2994       include 'COMMON.LOCAL'
2995       include 'COMMON.CHAIN'
2996       include 'COMMON.DERIV'
2997       include 'COMMON.INTERACT'
2998       include 'COMMON.CONTACTS'
2999       include 'COMMON.TORSION'
3000       include 'COMMON.VECTORS'
3001       include 'COMMON.FFIELD'
3002       include 'COMMON.TIME1'
3003       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3004      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3005       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3006      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3007       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3008      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3009      &    num_conti,j1,j2
3010 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3011 #ifdef MOMENT
3012       double precision scal_el /1.0d0/
3013 #else
3014       double precision scal_el /0.5d0/
3015 #endif
3016 C 12/13/98
3017 C 13-go grudnia roku pamietnego...
3018       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3019      &                   0.0d0,1.0d0,0.0d0,
3020      &                   0.0d0,0.0d0,1.0d0/
3021 c          time00=MPI_Wtime()
3022 cd      write (iout,*) "eelecij",i,j
3023 c          ind=ind+1
3024           iteli=itel(i)
3025           itelj=itel(j)
3026           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3027           aaa=app(iteli,itelj)
3028           bbb=bpp(iteli,itelj)
3029           ael6i=ael6(iteli,itelj)
3030           ael3i=ael3(iteli,itelj)
3031           dxj=dc(1,j)
3032           dyj=dc(2,j)
3033           dzj=dc(3,j)
3034           dx_normj=dc_norm(1,j)
3035           dy_normj=dc_norm(2,j)
3036           dz_normj=dc_norm(3,j)
3037           xj=c(1,j)+0.5D0*dxj-xmedi
3038           yj=c(2,j)+0.5D0*dyj-ymedi
3039           zj=c(3,j)+0.5D0*dzj-zmedi
3040           rij=xj*xj+yj*yj+zj*zj
3041           rrmij=1.0D0/rij
3042           rij=dsqrt(rij)
3043           rmij=1.0D0/rij
3044           r3ij=rrmij*rmij
3045           r6ij=r3ij*r3ij
3046           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3047           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3048           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3049           fac=cosa-3.0D0*cosb*cosg
3050           ev1=aaa*r6ij*r6ij
3051 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3052           if (j.eq.i+2) ev1=scal_el*ev1
3053           ev2=bbb*r6ij
3054           fac3=ael6i*r6ij
3055           fac4=ael3i*r3ij
3056           evdwij=ev1+ev2
3057           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3058           el2=fac4*fac
3059           eesij=el1+el2
3060 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3061           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3062           ees=ees+eesij
3063           evdw1=evdw1+evdwij
3064 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3065 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3066 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3067 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3068
3069           if (energy_dec) then
3070               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3071               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3072           endif
3073
3074 C
3075 C Calculate contributions to the Cartesian gradient.
3076 C
3077 #ifdef SPLITELE
3078           facvdw=-6*rrmij*(ev1+evdwij)
3079           facel=-3*rrmij*(el1+eesij)
3080           fac1=fac
3081           erij(1)=xj*rmij
3082           erij(2)=yj*rmij
3083           erij(3)=zj*rmij
3084 *
3085 * Radial derivatives. First process both termini of the fragment (i,j)
3086 *
3087           ggg(1)=facel*xj
3088           ggg(2)=facel*yj
3089           ggg(3)=facel*zj
3090 c          do k=1,3
3091 c            ghalf=0.5D0*ggg(k)
3092 c            gelc(k,i)=gelc(k,i)+ghalf
3093 c            gelc(k,j)=gelc(k,j)+ghalf
3094 c          enddo
3095 c 9/28/08 AL Gradient compotents will be summed only at the end
3096           do k=1,3
3097             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3098             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3099           enddo
3100 *
3101 * Loop over residues i+1 thru j-1.
3102 *
3103 cgrad          do k=i+1,j-1
3104 cgrad            do l=1,3
3105 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3106 cgrad            enddo
3107 cgrad          enddo
3108           ggg(1)=facvdw*xj
3109           ggg(2)=facvdw*yj
3110           ggg(3)=facvdw*zj
3111 c          do k=1,3
3112 c            ghalf=0.5D0*ggg(k)
3113 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3114 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3115 c          enddo
3116 c 9/28/08 AL Gradient compotents will be summed only at the end
3117           do k=1,3
3118             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3119             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3120           enddo
3121 *
3122 * Loop over residues i+1 thru j-1.
3123 *
3124 cgrad          do k=i+1,j-1
3125 cgrad            do l=1,3
3126 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3127 cgrad            enddo
3128 cgrad          enddo
3129 #else
3130           facvdw=ev1+evdwij
3131           facel=el1+eesij
3132           fac1=fac
3133           fac=-3*rrmij*(facvdw+facvdw+facel)
3134           erij(1)=xj*rmij
3135           erij(2)=yj*rmij
3136           erij(3)=zj*rmij
3137 *
3138 * Radial derivatives. First process both termini of the fragment (i,j)
3139 *
3140           ggg(1)=fac*xj
3141           ggg(2)=fac*yj
3142           ggg(3)=fac*zj
3143 c          do k=1,3
3144 c            ghalf=0.5D0*ggg(k)
3145 c            gelc(k,i)=gelc(k,i)+ghalf
3146 c            gelc(k,j)=gelc(k,j)+ghalf
3147 c          enddo
3148 c 9/28/08 AL Gradient compotents will be summed only at the end
3149           do k=1,3
3150             gelc_long(k,j)=gelc(k,j)+ggg(k)
3151             gelc_long(k,i)=gelc(k,i)-ggg(k)
3152           enddo
3153 *
3154 * Loop over residues i+1 thru j-1.
3155 *
3156 cgrad          do k=i+1,j-1
3157 cgrad            do l=1,3
3158 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3159 cgrad            enddo
3160 cgrad          enddo
3161 c 9/28/08 AL Gradient compotents will be summed only at the end
3162           ggg(1)=facvdw*xj
3163           ggg(2)=facvdw*yj
3164           ggg(3)=facvdw*zj
3165           do k=1,3
3166             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3167             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3168           enddo
3169 #endif
3170 *
3171 * Angular part
3172 *
3173           ecosa=2.0D0*fac3*fac1+fac4
3174           fac4=-3.0D0*fac4
3175           fac3=-6.0D0*fac3
3176           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3177           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3178           do k=1,3
3179             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3180             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3181           enddo
3182 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3183 cd   &          (dcosg(k),k=1,3)
3184           do k=1,3
3185             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3186           enddo
3187 c          do k=1,3
3188 c            ghalf=0.5D0*ggg(k)
3189 c            gelc(k,i)=gelc(k,i)+ghalf
3190 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3191 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3192 c            gelc(k,j)=gelc(k,j)+ghalf
3193 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3194 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3195 c          enddo
3196 cgrad          do k=i+1,j-1
3197 cgrad            do l=1,3
3198 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3199 cgrad            enddo
3200 cgrad          enddo
3201           do k=1,3
3202             gelc(k,i)=gelc(k,i)
3203      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3204      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3205             gelc(k,j)=gelc(k,j)
3206      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3207      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3208             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3209             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3210           enddo
3211           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3212      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3213      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3214 C
3215 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3216 C   energy of a peptide unit is assumed in the form of a second-order
3217 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3218 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3219 C   are computed for EVERY pair of non-contiguous peptide groups.
3220 C
3221           if (j.lt.nres-1) then
3222             j1=j+1
3223             j2=j-1
3224           else
3225             j1=j-1
3226             j2=j-2
3227           endif
3228           kkk=0
3229           do k=1,2
3230             do l=1,2
3231               kkk=kkk+1
3232               muij(kkk)=mu(k,i)*mu(l,j)
3233             enddo
3234           enddo
3235 cd         write (iout,*) 'EELEC: i',i,' j',j
3236 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3237 cd          write(iout,*) 'muij',muij
3238           ury=scalar(uy(1,i),erij)
3239           urz=scalar(uz(1,i),erij)
3240           vry=scalar(uy(1,j),erij)
3241           vrz=scalar(uz(1,j),erij)
3242           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3243           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3244           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3245           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3246           fac=dsqrt(-ael6i)*r3ij
3247           a22=a22*fac
3248           a23=a23*fac
3249           a32=a32*fac
3250           a33=a33*fac
3251 cd          write (iout,'(4i5,4f10.5)')
3252 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3253 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3254 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3255 cd     &      uy(:,j),uz(:,j)
3256 cd          write (iout,'(4f10.5)')
3257 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3258 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3259 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3260 cd           write (iout,'(9f10.5/)')
3261 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3262 C Derivatives of the elements of A in virtual-bond vectors
3263           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3264           do k=1,3
3265             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3266             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3267             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3268             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3269             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3270             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3271             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3272             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3273             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3274             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3275             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3276             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3277           enddo
3278 C Compute radial contributions to the gradient
3279           facr=-3.0d0*rrmij
3280           a22der=a22*facr
3281           a23der=a23*facr
3282           a32der=a32*facr
3283           a33der=a33*facr
3284           agg(1,1)=a22der*xj
3285           agg(2,1)=a22der*yj
3286           agg(3,1)=a22der*zj
3287           agg(1,2)=a23der*xj
3288           agg(2,2)=a23der*yj
3289           agg(3,2)=a23der*zj
3290           agg(1,3)=a32der*xj
3291           agg(2,3)=a32der*yj
3292           agg(3,3)=a32der*zj
3293           agg(1,4)=a33der*xj
3294           agg(2,4)=a33der*yj
3295           agg(3,4)=a33der*zj
3296 C Add the contributions coming from er
3297           fac3=-3.0d0*fac
3298           do k=1,3
3299             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3300             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3301             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3302             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3303           enddo
3304           do k=1,3
3305 C Derivatives in DC(i)
3306 cgrad            ghalf1=0.5d0*agg(k,1)
3307 cgrad            ghalf2=0.5d0*agg(k,2)
3308 cgrad            ghalf3=0.5d0*agg(k,3)
3309 cgrad            ghalf4=0.5d0*agg(k,4)
3310             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3311      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3312             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3313      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3314             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3315      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3316             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3317      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3318 C Derivatives in DC(i+1)
3319             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3320      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3321             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3322      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3323             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3324      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3325             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3326      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3327 C Derivatives in DC(j)
3328             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3329      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3330             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3331      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3332             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3333      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3334             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3335      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3336 C Derivatives in DC(j+1) or DC(nres-1)
3337             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3338      &      -3.0d0*vryg(k,3)*ury)
3339             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3340      &      -3.0d0*vrzg(k,3)*ury)
3341             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3342      &      -3.0d0*vryg(k,3)*urz)
3343             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3344      &      -3.0d0*vrzg(k,3)*urz)
3345 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3346 cgrad              do l=1,4
3347 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3348 cgrad              enddo
3349 cgrad            endif
3350           enddo
3351           acipa(1,1)=a22
3352           acipa(1,2)=a23
3353           acipa(2,1)=a32
3354           acipa(2,2)=a33
3355           a22=-a22
3356           a23=-a23
3357           do l=1,2
3358             do k=1,3
3359               agg(k,l)=-agg(k,l)
3360               aggi(k,l)=-aggi(k,l)
3361               aggi1(k,l)=-aggi1(k,l)
3362               aggj(k,l)=-aggj(k,l)
3363               aggj1(k,l)=-aggj1(k,l)
3364             enddo
3365           enddo
3366           if (j.lt.nres-1) then
3367             a22=-a22
3368             a32=-a32
3369             do l=1,3,2
3370               do k=1,3
3371                 agg(k,l)=-agg(k,l)
3372                 aggi(k,l)=-aggi(k,l)
3373                 aggi1(k,l)=-aggi1(k,l)
3374                 aggj(k,l)=-aggj(k,l)
3375                 aggj1(k,l)=-aggj1(k,l)
3376               enddo
3377             enddo
3378           else
3379             a22=-a22
3380             a23=-a23
3381             a32=-a32
3382             a33=-a33
3383             do l=1,4
3384               do k=1,3
3385                 agg(k,l)=-agg(k,l)
3386                 aggi(k,l)=-aggi(k,l)
3387                 aggi1(k,l)=-aggi1(k,l)
3388                 aggj(k,l)=-aggj(k,l)
3389                 aggj1(k,l)=-aggj1(k,l)
3390               enddo
3391             enddo
3392           endif
3393           ENDIF ! WCORR
3394           IF (wel_loc.gt.0.0d0) THEN
3395 C Contribution to the local-electrostatic energy coming from the i-j pair
3396           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3397      &     +a33*muij(4)
3398 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3399
3400           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3401      &            'eelloc',i,j,eel_loc_ij
3402
3403           eel_loc=eel_loc+eel_loc_ij
3404 C Partial derivatives in virtual-bond dihedral angles gamma
3405           if (i.gt.1)
3406      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3407      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3408      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3409           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3410      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3411      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3412 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3413           do l=1,3
3414             ggg(l)=agg(l,1)*muij(1)+
3415      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3416             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3417             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3418 cgrad            ghalf=0.5d0*ggg(l)
3419 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3420 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3421           enddo
3422 cgrad          do k=i+1,j2
3423 cgrad            do l=1,3
3424 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3425 cgrad            enddo
3426 cgrad          enddo
3427 C Remaining derivatives of eello
3428           do l=1,3
3429             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3430      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3431             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3432      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3433             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3434      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3435             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3436      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3437           enddo
3438           ENDIF
3439 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3440 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3441           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3442      &       .and. num_conti.le.maxconts) then
3443 c            write (iout,*) i,j," entered corr"
3444 C
3445 C Calculate the contact function. The ith column of the array JCONT will
3446 C contain the numbers of atoms that make contacts with the atom I (of numbers
3447 C greater than I). The arrays FACONT and GACONT will contain the values of
3448 C the contact function and its derivative.
3449 c           r0ij=1.02D0*rpp(iteli,itelj)
3450 c           r0ij=1.11D0*rpp(iteli,itelj)
3451             r0ij=2.20D0*rpp(iteli,itelj)
3452 c           r0ij=1.55D0*rpp(iteli,itelj)
3453             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3454             if (fcont.gt.0.0D0) then
3455               num_conti=num_conti+1
3456               if (num_conti.gt.maxconts) then
3457                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3458      &                         ' will skip next contacts for this conf.'
3459               else
3460                 jcont_hb(num_conti,i)=j
3461 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3462 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3463                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3464      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3465 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3466 C  terms.
3467                 d_cont(num_conti,i)=rij
3468 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3469 C     --- Electrostatic-interaction matrix ---
3470                 a_chuj(1,1,num_conti,i)=a22
3471                 a_chuj(1,2,num_conti,i)=a23
3472                 a_chuj(2,1,num_conti,i)=a32
3473                 a_chuj(2,2,num_conti,i)=a33
3474 C     --- Gradient of rij
3475                 do kkk=1,3
3476                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3477                 enddo
3478                 kkll=0
3479                 do k=1,2
3480                   do l=1,2
3481                     kkll=kkll+1
3482                     do m=1,3
3483                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3484                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3485                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3486                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3487                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3488                     enddo
3489                   enddo
3490                 enddo
3491                 ENDIF
3492                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3493 C Calculate contact energies
3494                 cosa4=4.0D0*cosa
3495                 wij=cosa-3.0D0*cosb*cosg
3496                 cosbg1=cosb+cosg
3497                 cosbg2=cosb-cosg
3498 c               fac3=dsqrt(-ael6i)/r0ij**3
3499                 fac3=dsqrt(-ael6i)*r3ij
3500 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3501                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3502                 if (ees0tmp.gt.0) then
3503                   ees0pij=dsqrt(ees0tmp)
3504                 else
3505                   ees0pij=0
3506                 endif
3507 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3508                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3509                 if (ees0tmp.gt.0) then
3510                   ees0mij=dsqrt(ees0tmp)
3511                 else
3512                   ees0mij=0
3513                 endif
3514 c               ees0mij=0.0D0
3515                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3516                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3517 C Diagnostics. Comment out or remove after debugging!
3518 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3519 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3520 c               ees0m(num_conti,i)=0.0D0
3521 C End diagnostics.
3522 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3523 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3524 C Angular derivatives of the contact function
3525                 ees0pij1=fac3/ees0pij
3526                 ees0mij1=fac3/ees0mij
3527                 fac3p=-3.0D0*fac3*rrmij
3528                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3529                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3530 c               ees0mij1=0.0D0
3531                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3532                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3533                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3534                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3535                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3536                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3537                 ecosap=ecosa1+ecosa2
3538                 ecosbp=ecosb1+ecosb2
3539                 ecosgp=ecosg1+ecosg2
3540                 ecosam=ecosa1-ecosa2
3541                 ecosbm=ecosb1-ecosb2
3542                 ecosgm=ecosg1-ecosg2
3543 C Diagnostics
3544 c               ecosap=ecosa1
3545 c               ecosbp=ecosb1
3546 c               ecosgp=ecosg1
3547 c               ecosam=0.0D0
3548 c               ecosbm=0.0D0
3549 c               ecosgm=0.0D0
3550 C End diagnostics
3551                 facont_hb(num_conti,i)=fcont
3552                 fprimcont=fprimcont/rij
3553 cd              facont_hb(num_conti,i)=1.0D0
3554 C Following line is for diagnostics.
3555 cd              fprimcont=0.0D0
3556                 do k=1,3
3557                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3558                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3559                 enddo
3560                 do k=1,3
3561                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3562                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3563                 enddo
3564                 gggp(1)=gggp(1)+ees0pijp*xj
3565                 gggp(2)=gggp(2)+ees0pijp*yj
3566                 gggp(3)=gggp(3)+ees0pijp*zj
3567                 gggm(1)=gggm(1)+ees0mijp*xj
3568                 gggm(2)=gggm(2)+ees0mijp*yj
3569                 gggm(3)=gggm(3)+ees0mijp*zj
3570 C Derivatives due to the contact function
3571                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3572                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3573                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3574                 do k=1,3
3575 c
3576 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3577 c          following the change of gradient-summation algorithm.
3578 c
3579 cgrad                  ghalfp=0.5D0*gggp(k)
3580 cgrad                  ghalfm=0.5D0*gggm(k)
3581                   gacontp_hb1(k,num_conti,i)=!ghalfp
3582      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3583      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3584                   gacontp_hb2(k,num_conti,i)=!ghalfp
3585      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3586      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3587                   gacontp_hb3(k,num_conti,i)=gggp(k)
3588                   gacontm_hb1(k,num_conti,i)=!ghalfm
3589      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3590      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3591                   gacontm_hb2(k,num_conti,i)=!ghalfm
3592      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3593      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3594                   gacontm_hb3(k,num_conti,i)=gggm(k)
3595                 enddo
3596 C Diagnostics. Comment out or remove after debugging!
3597 cdiag           do k=1,3
3598 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3599 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3600 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3601 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3602 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3603 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3604 cdiag           enddo
3605               ENDIF ! wcorr
3606               endif  ! num_conti.le.maxconts
3607             endif  ! fcont.gt.0
3608           endif    ! j.gt.i+1
3609           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3610             do k=1,4
3611               do l=1,3
3612                 ghalf=0.5d0*agg(l,k)
3613                 aggi(l,k)=aggi(l,k)+ghalf
3614                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3615                 aggj(l,k)=aggj(l,k)+ghalf
3616               enddo
3617             enddo
3618             if (j.eq.nres-1 .and. i.lt.j-2) then
3619               do k=1,4
3620                 do l=1,3
3621                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3622                 enddo
3623               enddo
3624             endif
3625           endif
3626 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3627       return
3628       end
3629 C-----------------------------------------------------------------------------
3630       subroutine eturn3(i,eello_turn3)
3631 C Third- and fourth-order contributions from turns
3632       implicit real*8 (a-h,o-z)
3633       include 'DIMENSIONS'
3634       include 'COMMON.IOUNITS'
3635       include 'COMMON.GEO'
3636       include 'COMMON.VAR'
3637       include 'COMMON.LOCAL'
3638       include 'COMMON.CHAIN'
3639       include 'COMMON.DERIV'
3640       include 'COMMON.INTERACT'
3641       include 'COMMON.CONTACTS'
3642       include 'COMMON.TORSION'
3643       include 'COMMON.VECTORS'
3644       include 'COMMON.FFIELD'
3645       include 'COMMON.CONTROL'
3646       dimension ggg(3)
3647       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3648      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3649      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3650       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3651      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3652       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3653      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3654      &    num_conti,j1,j2
3655       j=i+2
3656 c      write (iout,*) "eturn3",i,j,j1,j2
3657       a_temp(1,1)=a22
3658       a_temp(1,2)=a23
3659       a_temp(2,1)=a32
3660       a_temp(2,2)=a33
3661 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3662 C
3663 C               Third-order contributions
3664 C
3665 C                 (i+2)o----(i+3)
3666 C                      | |
3667 C                      | |
3668 C                 (i+1)o----i
3669 C
3670 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3671 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3672         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3673         call transpose2(auxmat(1,1),auxmat1(1,1))
3674         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3675         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3676         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3677      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3678 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3679 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3680 cd     &    ' eello_turn3_num',4*eello_turn3_num
3681 C Derivatives in gamma(i)
3682         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3683         call transpose2(auxmat2(1,1),auxmat3(1,1))
3684         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3685         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3686 C Derivatives in gamma(i+1)
3687         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3688         call transpose2(auxmat2(1,1),auxmat3(1,1))
3689         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3690         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3691      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3692 C Cartesian derivatives
3693         do l=1,3
3694 c            ghalf1=0.5d0*agg(l,1)
3695 c            ghalf2=0.5d0*agg(l,2)
3696 c            ghalf3=0.5d0*agg(l,3)
3697 c            ghalf4=0.5d0*agg(l,4)
3698           a_temp(1,1)=aggi(l,1)!+ghalf1
3699           a_temp(1,2)=aggi(l,2)!+ghalf2
3700           a_temp(2,1)=aggi(l,3)!+ghalf3
3701           a_temp(2,2)=aggi(l,4)!+ghalf4
3702           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3703           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3704      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3705           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3706           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3707           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3708           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3709           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3710           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3711      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3712           a_temp(1,1)=aggj(l,1)!+ghalf1
3713           a_temp(1,2)=aggj(l,2)!+ghalf2
3714           a_temp(2,1)=aggj(l,3)!+ghalf3
3715           a_temp(2,2)=aggj(l,4)!+ghalf4
3716           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3717           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3718      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3719           a_temp(1,1)=aggj1(l,1)
3720           a_temp(1,2)=aggj1(l,2)
3721           a_temp(2,1)=aggj1(l,3)
3722           a_temp(2,2)=aggj1(l,4)
3723           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3724           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3725      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3726         enddo
3727       return
3728       end
3729 C-------------------------------------------------------------------------------
3730       subroutine eturn4(i,eello_turn4)
3731 C Third- and fourth-order contributions from turns
3732       implicit real*8 (a-h,o-z)
3733       include 'DIMENSIONS'
3734       include 'COMMON.IOUNITS'
3735       include 'COMMON.GEO'
3736       include 'COMMON.VAR'
3737       include 'COMMON.LOCAL'
3738       include 'COMMON.CHAIN'
3739       include 'COMMON.DERIV'
3740       include 'COMMON.INTERACT'
3741       include 'COMMON.CONTACTS'
3742       include 'COMMON.TORSION'
3743       include 'COMMON.VECTORS'
3744       include 'COMMON.FFIELD'
3745       include 'COMMON.CONTROL'
3746       dimension ggg(3)
3747       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3748      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3749      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3750       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3751      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3752       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3753      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3754      &    num_conti,j1,j2
3755       j=i+3
3756 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3757 C
3758 C               Fourth-order contributions
3759 C
3760 C                 (i+3)o----(i+4)
3761 C                     /  |
3762 C               (i+2)o   |
3763 C                     \  |
3764 C                 (i+1)o----i
3765 C
3766 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3767 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3768 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3769         a_temp(1,1)=a22
3770         a_temp(1,2)=a23
3771         a_temp(2,1)=a32
3772         a_temp(2,2)=a33
3773         iti1=itortyp(itype(i+1))
3774         iti2=itortyp(itype(i+2))
3775         iti3=itortyp(itype(i+3))
3776 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3777         call transpose2(EUg(1,1,i+1),e1t(1,1))
3778         call transpose2(Eug(1,1,i+2),e2t(1,1))
3779         call transpose2(Eug(1,1,i+3),e3t(1,1))
3780         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3781         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3782         s1=scalar2(b1(1,iti2),auxvec(1))
3783         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3784         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3785         s2=scalar2(b1(1,iti1),auxvec(1))
3786         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3787         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3788         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3789         eello_turn4=eello_turn4-(s1+s2+s3)
3790         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3791      &      'eturn4',i,j,-(s1+s2+s3)
3792 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3793 cd     &    ' eello_turn4_num',8*eello_turn4_num
3794 C Derivatives in gamma(i)
3795         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3796         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3797         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3798         s1=scalar2(b1(1,iti2),auxvec(1))
3799         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3800         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3801         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3802 C Derivatives in gamma(i+1)
3803         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3804         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3805         s2=scalar2(b1(1,iti1),auxvec(1))
3806         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3807         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3808         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3809         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3810 C Derivatives in gamma(i+2)
3811         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3812         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3813         s1=scalar2(b1(1,iti2),auxvec(1))
3814         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3815         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3816         s2=scalar2(b1(1,iti1),auxvec(1))
3817         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3818         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3819         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3820         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3821 C Cartesian derivatives
3822 C Derivatives of this turn contributions in DC(i+2)
3823         if (j.lt.nres-1) then
3824           do l=1,3
3825             a_temp(1,1)=agg(l,1)
3826             a_temp(1,2)=agg(l,2)
3827             a_temp(2,1)=agg(l,3)
3828             a_temp(2,2)=agg(l,4)
3829             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3830             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3831             s1=scalar2(b1(1,iti2),auxvec(1))
3832             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3833             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3834             s2=scalar2(b1(1,iti1),auxvec(1))
3835             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3836             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3837             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3838             ggg(l)=-(s1+s2+s3)
3839             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3840           enddo
3841         endif
3842 C Remaining derivatives of this turn contribution
3843         do l=1,3
3844           a_temp(1,1)=aggi(l,1)
3845           a_temp(1,2)=aggi(l,2)
3846           a_temp(2,1)=aggi(l,3)
3847           a_temp(2,2)=aggi(l,4)
3848           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3849           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3850           s1=scalar2(b1(1,iti2),auxvec(1))
3851           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3852           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3853           s2=scalar2(b1(1,iti1),auxvec(1))
3854           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3855           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3856           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3857           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3858           a_temp(1,1)=aggi1(l,1)
3859           a_temp(1,2)=aggi1(l,2)
3860           a_temp(2,1)=aggi1(l,3)
3861           a_temp(2,2)=aggi1(l,4)
3862           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3863           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3864           s1=scalar2(b1(1,iti2),auxvec(1))
3865           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3866           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3867           s2=scalar2(b1(1,iti1),auxvec(1))
3868           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3869           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3870           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3871           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3872           a_temp(1,1)=aggj(l,1)
3873           a_temp(1,2)=aggj(l,2)
3874           a_temp(2,1)=aggj(l,3)
3875           a_temp(2,2)=aggj(l,4)
3876           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3877           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3878           s1=scalar2(b1(1,iti2),auxvec(1))
3879           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3880           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3881           s2=scalar2(b1(1,iti1),auxvec(1))
3882           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3883           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3884           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3885           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3886           a_temp(1,1)=aggj1(l,1)
3887           a_temp(1,2)=aggj1(l,2)
3888           a_temp(2,1)=aggj1(l,3)
3889           a_temp(2,2)=aggj1(l,4)
3890           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3891           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3892           s1=scalar2(b1(1,iti2),auxvec(1))
3893           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3894           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3895           s2=scalar2(b1(1,iti1),auxvec(1))
3896           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3897           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3898           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3899 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3900           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3901         enddo
3902       return
3903       end
3904 C-----------------------------------------------------------------------------
3905       subroutine vecpr(u,v,w)
3906       implicit real*8(a-h,o-z)
3907       dimension u(3),v(3),w(3)
3908       w(1)=u(2)*v(3)-u(3)*v(2)
3909       w(2)=-u(1)*v(3)+u(3)*v(1)
3910       w(3)=u(1)*v(2)-u(2)*v(1)
3911       return
3912       end
3913 C-----------------------------------------------------------------------------
3914       subroutine unormderiv(u,ugrad,unorm,ungrad)
3915 C This subroutine computes the derivatives of a normalized vector u, given
3916 C the derivatives computed without normalization conditions, ugrad. Returns
3917 C ungrad.
3918       implicit none
3919       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3920       double precision vec(3)
3921       double precision scalar
3922       integer i,j
3923 c      write (2,*) 'ugrad',ugrad
3924 c      write (2,*) 'u',u
3925       do i=1,3
3926         vec(i)=scalar(ugrad(1,i),u(1))
3927       enddo
3928 c      write (2,*) 'vec',vec
3929       do i=1,3
3930         do j=1,3
3931           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3932         enddo
3933       enddo
3934 c      write (2,*) 'ungrad',ungrad
3935       return
3936       end
3937 C-----------------------------------------------------------------------------
3938       subroutine escp_soft_sphere(evdw2,evdw2_14)
3939 C
3940 C This subroutine calculates the excluded-volume interaction energy between
3941 C peptide-group centers and side chains and its gradient in virtual-bond and
3942 C side-chain vectors.
3943 C
3944       implicit real*8 (a-h,o-z)
3945       include 'DIMENSIONS'
3946       include 'COMMON.GEO'
3947       include 'COMMON.VAR'
3948       include 'COMMON.LOCAL'
3949       include 'COMMON.CHAIN'
3950       include 'COMMON.DERIV'
3951       include 'COMMON.INTERACT'
3952       include 'COMMON.FFIELD'
3953       include 'COMMON.IOUNITS'
3954       include 'COMMON.CONTROL'
3955       dimension ggg(3)
3956       evdw2=0.0D0
3957       evdw2_14=0.0d0
3958       r0_scp=4.5d0
3959 cd    print '(a)','Enter ESCP'
3960 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3961       do i=iatscp_s,iatscp_e
3962         iteli=itel(i)
3963         xi=0.5D0*(c(1,i)+c(1,i+1))
3964         yi=0.5D0*(c(2,i)+c(2,i+1))
3965         zi=0.5D0*(c(3,i)+c(3,i+1))
3966
3967         do iint=1,nscp_gr(i)
3968
3969         do j=iscpstart(i,iint),iscpend(i,iint)
3970           itypj=itype(j)
3971 C Uncomment following three lines for SC-p interactions
3972 c         xj=c(1,nres+j)-xi
3973 c         yj=c(2,nres+j)-yi
3974 c         zj=c(3,nres+j)-zi
3975 C Uncomment following three lines for Ca-p interactions
3976           xj=c(1,j)-xi
3977           yj=c(2,j)-yi
3978           zj=c(3,j)-zi
3979           rij=xj*xj+yj*yj+zj*zj
3980           r0ij=r0_scp
3981           r0ijsq=r0ij*r0ij
3982           if (rij.lt.r0ijsq) then
3983             evdwij=0.25d0*(rij-r0ijsq)**2
3984             fac=rij-r0ijsq
3985           else
3986             evdwij=0.0d0
3987             fac=0.0d0
3988           endif
3989           evdw2=evdw2+evdwij
3990 C
3991 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3992 C
3993           ggg(1)=xj*fac
3994           ggg(2)=yj*fac
3995           ggg(3)=zj*fac
3996 cgrad          if (j.lt.i) then
3997 cd          write (iout,*) 'j<i'
3998 C Uncomment following three lines for SC-p interactions
3999 c           do k=1,3
4000 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4001 c           enddo
4002 cgrad          else
4003 cd          write (iout,*) 'j>i'
4004 cgrad            do k=1,3
4005 cgrad              ggg(k)=-ggg(k)
4006 C Uncomment following line for SC-p interactions
4007 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4008 cgrad            enddo
4009 cgrad          endif
4010 cgrad          do k=1,3
4011 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4012 cgrad          enddo
4013 cgrad          kstart=min0(i+1,j)
4014 cgrad          kend=max0(i-1,j-1)
4015 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4016 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4017 cgrad          do k=kstart,kend
4018 cgrad            do l=1,3
4019 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4020 cgrad            enddo
4021 cgrad          enddo
4022           do k=1,3
4023             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4024             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4025           enddo
4026         enddo
4027
4028         enddo ! iint
4029       enddo ! i
4030       return
4031       end
4032 C-----------------------------------------------------------------------------
4033       subroutine escp(evdw2,evdw2_14)
4034 C
4035 C This subroutine calculates the excluded-volume interaction energy between
4036 C peptide-group centers and side chains and its gradient in virtual-bond and
4037 C side-chain vectors.
4038 C
4039       implicit real*8 (a-h,o-z)
4040       include 'DIMENSIONS'
4041       include 'COMMON.GEO'
4042       include 'COMMON.VAR'
4043       include 'COMMON.LOCAL'
4044       include 'COMMON.CHAIN'
4045       include 'COMMON.DERIV'
4046       include 'COMMON.INTERACT'
4047       include 'COMMON.FFIELD'
4048       include 'COMMON.IOUNITS'
4049       include 'COMMON.CONTROL'
4050       dimension ggg(3)
4051       evdw2=0.0D0
4052       evdw2_14=0.0d0
4053 cd    print '(a)','Enter ESCP'
4054 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4055       do i=iatscp_s,iatscp_e
4056         iteli=itel(i)
4057         xi=0.5D0*(c(1,i)+c(1,i+1))
4058         yi=0.5D0*(c(2,i)+c(2,i+1))
4059         zi=0.5D0*(c(3,i)+c(3,i+1))
4060
4061         do iint=1,nscp_gr(i)
4062
4063         do j=iscpstart(i,iint),iscpend(i,iint)
4064           itypj=itype(j)
4065 C Uncomment following three lines for SC-p interactions
4066 c         xj=c(1,nres+j)-xi
4067 c         yj=c(2,nres+j)-yi
4068 c         zj=c(3,nres+j)-zi
4069 C Uncomment following three lines for Ca-p interactions
4070           xj=c(1,j)-xi
4071           yj=c(2,j)-yi
4072           zj=c(3,j)-zi
4073           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4074           fac=rrij**expon2
4075           e1=fac*fac*aad(itypj,iteli)
4076           e2=fac*bad(itypj,iteli)
4077           if (iabs(j-i) .le. 2) then
4078             e1=scal14*e1
4079             e2=scal14*e2
4080             evdw2_14=evdw2_14+e1+e2
4081           endif
4082           evdwij=e1+e2
4083           evdw2=evdw2+evdwij
4084           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4085      &        'evdw2',i,j,evdwij
4086 C
4087 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4088 C
4089           fac=-(evdwij+e1)*rrij
4090           ggg(1)=xj*fac
4091           ggg(2)=yj*fac
4092           ggg(3)=zj*fac
4093 cgrad          if (j.lt.i) then
4094 cd          write (iout,*) 'j<i'
4095 C Uncomment following three lines for SC-p interactions
4096 c           do k=1,3
4097 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4098 c           enddo
4099 cgrad          else
4100 cd          write (iout,*) 'j>i'
4101 cgrad            do k=1,3
4102 cgrad              ggg(k)=-ggg(k)
4103 C Uncomment following line for SC-p interactions
4104 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4105 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4106 cgrad            enddo
4107 cgrad          endif
4108 cgrad          do k=1,3
4109 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4110 cgrad          enddo
4111 cgrad          kstart=min0(i+1,j)
4112 cgrad          kend=max0(i-1,j-1)
4113 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4114 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4115 cgrad          do k=kstart,kend
4116 cgrad            do l=1,3
4117 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4118 cgrad            enddo
4119 cgrad          enddo
4120           do k=1,3
4121             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4122             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4123           enddo
4124         enddo
4125
4126         enddo ! iint
4127       enddo ! i
4128       do i=1,nct
4129         do j=1,3
4130           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4131           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4132           gradx_scp(j,i)=expon*gradx_scp(j,i)
4133         enddo
4134       enddo
4135 C******************************************************************************
4136 C
4137 C                              N O T E !!!
4138 C
4139 C To save time the factor EXPON has been extracted from ALL components
4140 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4141 C use!
4142 C
4143 C******************************************************************************
4144       return
4145       end
4146 C--------------------------------------------------------------------------
4147       subroutine edis(ehpb)
4148 C
4149 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4150 C
4151       implicit real*8 (a-h,o-z)
4152       include 'DIMENSIONS'
4153       include 'COMMON.SBRIDGE'
4154       include 'COMMON.CHAIN'
4155       include 'COMMON.DERIV'
4156       include 'COMMON.VAR'
4157       include 'COMMON.INTERACT'
4158       include 'COMMON.IOUNITS'
4159       dimension ggg(3)
4160       ehpb=0.0D0
4161 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4162 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4163       if (link_end.eq.0) return
4164       do i=link_start,link_end
4165 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4166 C CA-CA distance used in regularization of structure.
4167         ii=ihpb(i)
4168         jj=jhpb(i)
4169 C iii and jjj point to the residues for which the distance is assigned.
4170         if (ii.gt.nres) then
4171           iii=ii-nres
4172           jjj=jj-nres
4173         else
4174           iii=ii
4175           jjj=jj
4176         endif
4177 cd        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj
4178 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4179 C    distance and angle dependent SS bond potential.
4180         if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4181           call ssbond_ene(iii,jjj,eij)
4182           ehpb=ehpb+2*eij
4183 cd          write (iout,*) "eij",eij
4184         else
4185 C Calculate the distance between the two points and its difference from the
4186 C target distance.
4187         dd=dist(ii,jj)
4188         rdis=dd-dhpb(i)
4189 C Get the force constant corresponding to this distance.
4190         waga=forcon(i)
4191 C Calculate the contribution to energy.
4192         ehpb=ehpb+waga*rdis*rdis
4193 C
4194 C Evaluate gradient.
4195 C
4196         fac=waga*rdis/dd
4197 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4198 cd   &   ' waga=',waga,' fac=',fac
4199         do j=1,3
4200           ggg(j)=fac*(c(j,jj)-c(j,ii))
4201         enddo
4202 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4203 C If this is a SC-SC distance, we need to calculate the contributions to the
4204 C Cartesian gradient in the SC vectors (ghpbx).
4205         if (iii.lt.ii) then
4206           do j=1,3
4207             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4208             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4209           enddo
4210         endif
4211 cgrad        do j=iii,jjj-1
4212 cgrad          do k=1,3
4213 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4214 cgrad          enddo
4215 cgrad        enddo
4216         do k=1,3
4217           ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4218           ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4219         enddo
4220         endif
4221       enddo
4222       ehpb=0.5D0*ehpb
4223       return
4224       end
4225 C--------------------------------------------------------------------------
4226       subroutine ssbond_ene(i,j,eij)
4227 C
4228 C Calculate the distance and angle dependent SS-bond potential energy
4229 C using a free-energy function derived based on RHF/6-31G** ab initio
4230 C calculations of diethyl disulfide.
4231 C
4232 C A. Liwo and U. Kozlowska, 11/24/03
4233 C
4234       implicit real*8 (a-h,o-z)
4235       include 'DIMENSIONS'
4236       include 'COMMON.SBRIDGE'
4237       include 'COMMON.CHAIN'
4238       include 'COMMON.DERIV'
4239       include 'COMMON.LOCAL'
4240       include 'COMMON.INTERACT'
4241       include 'COMMON.VAR'
4242       include 'COMMON.IOUNITS'
4243       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4244       itypi=itype(i)
4245       xi=c(1,nres+i)
4246       yi=c(2,nres+i)
4247       zi=c(3,nres+i)
4248       dxi=dc_norm(1,nres+i)
4249       dyi=dc_norm(2,nres+i)
4250       dzi=dc_norm(3,nres+i)
4251 c      dsci_inv=dsc_inv(itypi)
4252       dsci_inv=vbld_inv(nres+i)
4253       itypj=itype(j)
4254 c      dscj_inv=dsc_inv(itypj)
4255       dscj_inv=vbld_inv(nres+j)
4256       xj=c(1,nres+j)-xi
4257       yj=c(2,nres+j)-yi
4258       zj=c(3,nres+j)-zi
4259       dxj=dc_norm(1,nres+j)
4260       dyj=dc_norm(2,nres+j)
4261       dzj=dc_norm(3,nres+j)
4262       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4263       rij=dsqrt(rrij)
4264       erij(1)=xj*rij
4265       erij(2)=yj*rij
4266       erij(3)=zj*rij
4267       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4268       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4269       om12=dxi*dxj+dyi*dyj+dzi*dzj
4270       do k=1,3
4271         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4272         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4273       enddo
4274       rij=1.0d0/rij
4275       deltad=rij-d0cm
4276       deltat1=1.0d0-om1
4277       deltat2=1.0d0+om2
4278       deltat12=om2-om1+2.0d0
4279       cosphi=om12-om1*om2
4280       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4281      &  +akct*deltad*deltat12
4282      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4283 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4284 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4285 c     &  " deltat12",deltat12," eij",eij
4286       ed=2*akcm*deltad+akct*deltat12
4287       pom1=akct*deltad
4288       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4289       eom1=-2*akth*deltat1-pom1-om2*pom2
4290       eom2= 2*akth*deltat2+pom1-om1*pom2
4291       eom12=pom2
4292       do k=1,3
4293         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4294         ghpbx(k,i)=ghpbx(k,i)-ggk
4295      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4296      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4297         ghpbx(k,j)=ghpbx(k,j)+ggk
4298      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4299      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4300         ghpbc(k,i)=ghpbc(k,i)-ggk
4301         ghpbc(k,j)=ghpbc(k,j)+ggk
4302       enddo
4303 C
4304 C Calculate the components of the gradient in DC and X
4305 C
4306 cgrad      do k=i,j-1
4307 cgrad        do l=1,3
4308 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4309 cgrad        enddo
4310 cgrad      enddo
4311       return
4312       end
4313 C--------------------------------------------------------------------------
4314       subroutine ebond(estr)
4315 c
4316 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4317 c
4318       implicit real*8 (a-h,o-z)
4319       include 'DIMENSIONS'
4320       include 'COMMON.LOCAL'
4321       include 'COMMON.GEO'
4322       include 'COMMON.INTERACT'
4323       include 'COMMON.DERIV'
4324       include 'COMMON.VAR'
4325       include 'COMMON.CHAIN'
4326       include 'COMMON.IOUNITS'
4327       include 'COMMON.NAMES'
4328       include 'COMMON.FFIELD'
4329       include 'COMMON.CONTROL'
4330       include 'COMMON.SETUP'
4331       double precision u(3),ud(3)
4332       estr=0.0d0
4333       do i=ibondp_start,ibondp_end
4334         diff = vbld(i)-vbldp0
4335 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4336         estr=estr+diff*diff
4337         do j=1,3
4338           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4339         enddo
4340 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4341       enddo
4342       estr=0.5d0*AKP*estr
4343 c
4344 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4345 c
4346       do i=ibond_start,ibond_end
4347         iti=itype(i)
4348         if (iti.ne.10) then
4349           nbi=nbondterm(iti)
4350           if (nbi.eq.1) then
4351             diff=vbld(i+nres)-vbldsc0(1,iti)
4352 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4353 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4354             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4355             do j=1,3
4356               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4357             enddo
4358           else
4359             do j=1,nbi
4360               diff=vbld(i+nres)-vbldsc0(j,iti)
4361               ud(j)=aksc(j,iti)*diff
4362               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4363             enddo
4364             uprod=u(1)
4365             do j=2,nbi
4366               uprod=uprod*u(j)
4367             enddo
4368             usum=0.0d0
4369             usumsqder=0.0d0
4370             do j=1,nbi
4371               uprod1=1.0d0
4372               uprod2=1.0d0
4373               do k=1,nbi
4374                 if (k.ne.j) then
4375                   uprod1=uprod1*u(k)
4376                   uprod2=uprod2*u(k)*u(k)
4377                 endif
4378               enddo
4379               usum=usum+uprod1
4380               usumsqder=usumsqder+ud(j)*uprod2
4381             enddo
4382             estr=estr+uprod/usum
4383             do j=1,3
4384              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4385             enddo
4386           endif
4387         endif
4388       enddo
4389       return
4390       end
4391 #ifdef CRYST_THETA
4392 C--------------------------------------------------------------------------
4393       subroutine ebend(etheta)
4394 C
4395 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4396 C angles gamma and its derivatives in consecutive thetas and gammas.
4397 C
4398       implicit real*8 (a-h,o-z)
4399       include 'DIMENSIONS'
4400       include 'COMMON.LOCAL'
4401       include 'COMMON.GEO'
4402       include 'COMMON.INTERACT'
4403       include 'COMMON.DERIV'
4404       include 'COMMON.VAR'
4405       include 'COMMON.CHAIN'
4406       include 'COMMON.IOUNITS'
4407       include 'COMMON.NAMES'
4408       include 'COMMON.FFIELD'
4409       include 'COMMON.CONTROL'
4410       common /calcthet/ term1,term2,termm,diffak,ratak,
4411      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4412      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4413       double precision y(2),z(2)
4414       delta=0.02d0*pi
4415 c      time11=dexp(-2*time)
4416 c      time12=1.0d0
4417       etheta=0.0D0
4418 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4419       do i=ithet_start,ithet_end
4420 C Zero the energy function and its derivative at 0 or pi.
4421         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4422         it=itype(i-1)
4423         if (i.gt.3) then
4424 #ifdef OSF
4425           phii=phi(i)
4426           if (phii.ne.phii) phii=150.0
4427 #else
4428           phii=phi(i)
4429 #endif
4430           y(1)=dcos(phii)
4431           y(2)=dsin(phii)
4432         else
4433           y(1)=0.0D0
4434           y(2)=0.0D0
4435         endif
4436         if (i.lt.nres) then
4437 #ifdef OSF
4438           phii1=phi(i+1)
4439           if (phii1.ne.phii1) phii1=150.0
4440           phii1=pinorm(phii1)
4441           z(1)=cos(phii1)
4442 #else
4443           phii1=phi(i+1)
4444           z(1)=dcos(phii1)
4445 #endif
4446           z(2)=dsin(phii1)
4447         else
4448           z(1)=0.0D0
4449           z(2)=0.0D0
4450         endif
4451 C Calculate the "mean" value of theta from the part of the distribution
4452 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4453 C In following comments this theta will be referred to as t_c.
4454         thet_pred_mean=0.0d0
4455         do k=1,2
4456           athetk=athet(k,it)
4457           bthetk=bthet(k,it)
4458           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4459         enddo
4460         dthett=thet_pred_mean*ssd
4461         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4462 C Derivatives of the "mean" values in gamma1 and gamma2.
4463         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
4464         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
4465         if (theta(i).gt.pi-delta) then
4466           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4467      &         E_tc0)
4468           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4469           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4470           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4471      &        E_theta)
4472           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4473      &        E_tc)
4474         else if (theta(i).lt.delta) then
4475           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4476           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4477           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4478      &        E_theta)
4479           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4480           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4481      &        E_tc)
4482         else
4483           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4484      &        E_theta,E_tc)
4485         endif
4486         etheta=etheta+ethetai
4487         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4488      &      'ebend',i,ethetai
4489         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4490         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4491         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4492       enddo
4493 C Ufff.... We've done all this!!!
4494       return
4495       end
4496 C---------------------------------------------------------------------------
4497       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4498      &     E_tc)
4499       implicit real*8 (a-h,o-z)
4500       include 'DIMENSIONS'
4501       include 'COMMON.LOCAL'
4502       include 'COMMON.IOUNITS'
4503       common /calcthet/ term1,term2,termm,diffak,ratak,
4504      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4505      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4506 C Calculate the contributions to both Gaussian lobes.
4507 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4508 C The "polynomial part" of the "standard deviation" of this part of
4509 C the distribution.
4510         sig=polthet(3,it)
4511         do j=2,0,-1
4512           sig=sig*thet_pred_mean+polthet(j,it)
4513         enddo
4514 C Derivative of the "interior part" of the "standard deviation of the"
4515 C gamma-dependent Gaussian lobe in t_c.
4516         sigtc=3*polthet(3,it)
4517         do j=2,1,-1
4518           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4519         enddo
4520         sigtc=sig*sigtc
4521 C Set the parameters of both Gaussian lobes of the distribution.
4522 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4523         fac=sig*sig+sigc0(it)
4524         sigcsq=fac+fac
4525         sigc=1.0D0/sigcsq
4526 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4527         sigsqtc=-4.0D0*sigcsq*sigtc
4528 c       print *,i,sig,sigtc,sigsqtc
4529 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4530         sigtc=-sigtc/(fac*fac)
4531 C Following variable is sigma(t_c)**(-2)
4532         sigcsq=sigcsq*sigcsq
4533         sig0i=sig0(it)
4534         sig0inv=1.0D0/sig0i**2
4535         delthec=thetai-thet_pred_mean
4536         delthe0=thetai-theta0i
4537         term1=-0.5D0*sigcsq*delthec*delthec
4538         term2=-0.5D0*sig0inv*delthe0*delthe0
4539 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4540 C NaNs in taking the logarithm. We extract the largest exponent which is added
4541 C to the energy (this being the log of the distribution) at the end of energy
4542 C term evaluation for this virtual-bond angle.
4543         if (term1.gt.term2) then
4544           termm=term1
4545           term2=dexp(term2-termm)
4546           term1=1.0d0
4547         else
4548           termm=term2
4549           term1=dexp(term1-termm)
4550           term2=1.0d0
4551         endif
4552 C The ratio between the gamma-independent and gamma-dependent lobes of
4553 C the distribution is a Gaussian function of thet_pred_mean too.
4554         diffak=gthet(2,it)-thet_pred_mean
4555         ratak=diffak/gthet(3,it)**2
4556         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4557 C Let's differentiate it in thet_pred_mean NOW.
4558         aktc=ak*ratak
4559 C Now put together the distribution terms to make complete distribution.
4560         termexp=term1+ak*term2
4561         termpre=sigc+ak*sig0i
4562 C Contribution of the bending energy from this theta is just the -log of
4563 C the sum of the contributions from the two lobes and the pre-exponential
4564 C factor. Simple enough, isn't it?
4565         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4566 C NOW the derivatives!!!
4567 C 6/6/97 Take into account the deformation.
4568         E_theta=(delthec*sigcsq*term1
4569      &       +ak*delthe0*sig0inv*term2)/termexp
4570         E_tc=((sigtc+aktc*sig0i)/termpre
4571      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4572      &       aktc*term2)/termexp)
4573       return
4574       end
4575 c-----------------------------------------------------------------------------
4576       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4577       implicit real*8 (a-h,o-z)
4578       include 'DIMENSIONS'
4579       include 'COMMON.LOCAL'
4580       include 'COMMON.IOUNITS'
4581       common /calcthet/ term1,term2,termm,diffak,ratak,
4582      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4583      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4584       delthec=thetai-thet_pred_mean
4585       delthe0=thetai-theta0i
4586 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4587       t3 = thetai-thet_pred_mean
4588       t6 = t3**2
4589       t9 = term1
4590       t12 = t3*sigcsq
4591       t14 = t12+t6*sigsqtc
4592       t16 = 1.0d0
4593       t21 = thetai-theta0i
4594       t23 = t21**2
4595       t26 = term2
4596       t27 = t21*t26
4597       t32 = termexp
4598       t40 = t32**2
4599       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4600      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4601      & *(-t12*t9-ak*sig0inv*t27)
4602       return
4603       end
4604 #else
4605 C--------------------------------------------------------------------------
4606       subroutine ebend(etheta)
4607 C
4608 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4609 C angles gamma and its derivatives in consecutive thetas and gammas.
4610 C ab initio-derived potentials from
4611 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4612 C
4613       implicit real*8 (a-h,o-z)
4614       include 'DIMENSIONS'
4615       include 'COMMON.LOCAL'
4616       include 'COMMON.GEO'
4617       include 'COMMON.INTERACT'
4618       include 'COMMON.DERIV'
4619       include 'COMMON.VAR'
4620       include 'COMMON.CHAIN'
4621       include 'COMMON.IOUNITS'
4622       include 'COMMON.NAMES'
4623       include 'COMMON.FFIELD'
4624       include 'COMMON.CONTROL'
4625       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4626      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4627      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4628      & sinph1ph2(maxdouble,maxdouble)
4629       logical lprn /.false./, lprn1 /.false./
4630       etheta=0.0D0
4631       do i=ithet_start,ithet_end
4632         dethetai=0.0d0
4633         dephii=0.0d0
4634         dephii1=0.0d0
4635         theti2=0.5d0*theta(i)
4636         ityp2=ithetyp(itype(i-1))
4637         do k=1,nntheterm
4638           coskt(k)=dcos(k*theti2)
4639           sinkt(k)=dsin(k*theti2)
4640         enddo
4641         if (i.gt.3) then
4642 #ifdef OSF
4643           phii=phi(i)
4644           if (phii.ne.phii) phii=150.0
4645 #else
4646           phii=phi(i)
4647 #endif
4648           ityp1=ithetyp(itype(i-2))
4649           do k=1,nsingle
4650             cosph1(k)=dcos(k*phii)
4651             sinph1(k)=dsin(k*phii)
4652           enddo
4653         else
4654           phii=0.0d0
4655           ityp1=nthetyp+1
4656           do k=1,nsingle
4657             cosph1(k)=0.0d0
4658             sinph1(k)=0.0d0
4659           enddo
4660         endif
4661         if (i.lt.nres) then
4662 #ifdef OSF
4663           phii1=phi(i+1)
4664           if (phii1.ne.phii1) phii1=150.0
4665           phii1=pinorm(phii1)
4666 #else
4667           phii1=phi(i+1)
4668 #endif
4669           ityp3=ithetyp(itype(i))
4670           do k=1,nsingle
4671             cosph2(k)=dcos(k*phii1)
4672             sinph2(k)=dsin(k*phii1)
4673           enddo
4674         else
4675           phii1=0.0d0
4676           ityp3=nthetyp+1
4677           do k=1,nsingle
4678             cosph2(k)=0.0d0
4679             sinph2(k)=0.0d0
4680           enddo
4681         endif
4682         ethetai=aa0thet(ityp1,ityp2,ityp3)
4683         do k=1,ndouble
4684           do l=1,k-1
4685             ccl=cosph1(l)*cosph2(k-l)
4686             ssl=sinph1(l)*sinph2(k-l)
4687             scl=sinph1(l)*cosph2(k-l)
4688             csl=cosph1(l)*sinph2(k-l)
4689             cosph1ph2(l,k)=ccl-ssl
4690             cosph1ph2(k,l)=ccl+ssl
4691             sinph1ph2(l,k)=scl+csl
4692             sinph1ph2(k,l)=scl-csl
4693           enddo
4694         enddo
4695         if (lprn) then
4696         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4697      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4698         write (iout,*) "coskt and sinkt"
4699         do k=1,nntheterm
4700           write (iout,*) k,coskt(k),sinkt(k)
4701         enddo
4702         endif
4703         do k=1,ntheterm
4704           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4705           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4706      &      *coskt(k)
4707           if (lprn)
4708      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4709      &     " ethetai",ethetai
4710         enddo
4711         if (lprn) then
4712         write (iout,*) "cosph and sinph"
4713         do k=1,nsingle
4714           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4715         enddo
4716         write (iout,*) "cosph1ph2 and sinph2ph2"
4717         do k=2,ndouble
4718           do l=1,k-1
4719             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4720      &         sinph1ph2(l,k),sinph1ph2(k,l)
4721           enddo
4722         enddo
4723         write(iout,*) "ethetai",ethetai
4724         endif
4725         do m=1,ntheterm2
4726           do k=1,nsingle
4727             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4728      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4729      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4730      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4731             ethetai=ethetai+sinkt(m)*aux
4732             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4733             dephii=dephii+k*sinkt(m)*(
4734      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4735      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4736             dephii1=dephii1+k*sinkt(m)*(
4737      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4738      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4739             if (lprn)
4740      &      write (iout,*) "m",m," k",k," bbthet",
4741      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4742      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4743      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4744      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4745           enddo
4746         enddo
4747         if (lprn)
4748      &  write(iout,*) "ethetai",ethetai
4749         do m=1,ntheterm3
4750           do k=2,ndouble
4751             do l=1,k-1
4752               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4753      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4754      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4755      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4756               ethetai=ethetai+sinkt(m)*aux
4757               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4758               dephii=dephii+l*sinkt(m)*(
4759      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4760      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4761      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4762      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4763               dephii1=dephii1+(k-l)*sinkt(m)*(
4764      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4765      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4766      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
4767      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4768               if (lprn) then
4769               write (iout,*) "m",m," k",k," l",l," ffthet",
4770      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
4771      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
4772      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
4773      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4774               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4775      &            cosph1ph2(k,l)*sinkt(m),
4776      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4777               endif
4778             enddo
4779           enddo
4780         enddo
4781 10      continue
4782         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4783      &   i,theta(i)*rad2deg,phii*rad2deg,
4784      &   phii1*rad2deg,ethetai
4785         etheta=etheta+ethetai
4786         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4787         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4788         gloc(nphi+i-2,icg)=wang*dethetai
4789       enddo
4790       return
4791       end
4792 #endif
4793 #ifdef CRYST_SC
4794 c-----------------------------------------------------------------------------
4795       subroutine esc(escloc)
4796 C Calculate the local energy of a side chain and its derivatives in the
4797 C corresponding virtual-bond valence angles THETA and the spherical angles
4798 C ALPHA and OMEGA.
4799       implicit real*8 (a-h,o-z)
4800       include 'DIMENSIONS'
4801       include 'COMMON.GEO'
4802       include 'COMMON.LOCAL'
4803       include 'COMMON.VAR'
4804       include 'COMMON.INTERACT'
4805       include 'COMMON.DERIV'
4806       include 'COMMON.CHAIN'
4807       include 'COMMON.IOUNITS'
4808       include 'COMMON.NAMES'
4809       include 'COMMON.FFIELD'
4810       include 'COMMON.CONTROL'
4811       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4812      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4813       common /sccalc/ time11,time12,time112,theti,it,nlobit
4814       delta=0.02d0*pi
4815       escloc=0.0D0
4816 c     write (iout,'(a)') 'ESC'
4817       do i=loc_start,loc_end
4818         it=itype(i)
4819         if (it.eq.10) goto 1
4820         nlobit=nlob(it)
4821 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4822 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4823         theti=theta(i+1)-pipol
4824         x(1)=dtan(theti)
4825         x(2)=alph(i)
4826         x(3)=omeg(i)
4827
4828         if (x(2).gt.pi-delta) then
4829           xtemp(1)=x(1)
4830           xtemp(2)=pi-delta
4831           xtemp(3)=x(3)
4832           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4833           xtemp(2)=pi
4834           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4835           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4836      &        escloci,dersc(2))
4837           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4838      &        ddersc0(1),dersc(1))
4839           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4840      &        ddersc0(3),dersc(3))
4841           xtemp(2)=pi-delta
4842           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4843           xtemp(2)=pi
4844           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4845           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4846      &            dersc0(2),esclocbi,dersc02)
4847           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4848      &            dersc12,dersc01)
4849           call splinthet(x(2),0.5d0*delta,ss,ssd)
4850           dersc0(1)=dersc01
4851           dersc0(2)=dersc02
4852           dersc0(3)=0.0d0
4853           do k=1,3
4854             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4855           enddo
4856           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4857 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4858 c    &             esclocbi,ss,ssd
4859           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4860 c         escloci=esclocbi
4861 c         write (iout,*) escloci
4862         else if (x(2).lt.delta) then
4863           xtemp(1)=x(1)
4864           xtemp(2)=delta
4865           xtemp(3)=x(3)
4866           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4867           xtemp(2)=0.0d0
4868           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4869           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4870      &        escloci,dersc(2))
4871           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4872      &        ddersc0(1),dersc(1))
4873           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4874      &        ddersc0(3),dersc(3))
4875           xtemp(2)=delta
4876           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4877           xtemp(2)=0.0d0
4878           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4879           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4880      &            dersc0(2),esclocbi,dersc02)
4881           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4882      &            dersc12,dersc01)
4883           dersc0(1)=dersc01
4884           dersc0(2)=dersc02
4885           dersc0(3)=0.0d0
4886           call splinthet(x(2),0.5d0*delta,ss,ssd)
4887           do k=1,3
4888             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4889           enddo
4890           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4891 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4892 c    &             esclocbi,ss,ssd
4893           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4894 c         write (iout,*) escloci
4895         else
4896           call enesc(x,escloci,dersc,ddummy,.false.)
4897         endif
4898
4899         escloc=escloc+escloci
4900         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4901      &     'escloc',i,escloci
4902 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4903
4904         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4905      &   wscloc*dersc(1)
4906         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4907         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4908     1   continue
4909       enddo
4910       return
4911       end
4912 C---------------------------------------------------------------------------
4913       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4914       implicit real*8 (a-h,o-z)
4915       include 'DIMENSIONS'
4916       include 'COMMON.GEO'
4917       include 'COMMON.LOCAL'
4918       include 'COMMON.IOUNITS'
4919       common /sccalc/ time11,time12,time112,theti,it,nlobit
4920       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4921       double precision contr(maxlob,-1:1)
4922       logical mixed
4923 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4924         escloc_i=0.0D0
4925         do j=1,3
4926           dersc(j)=0.0D0
4927           if (mixed) ddersc(j)=0.0d0
4928         enddo
4929         x3=x(3)
4930
4931 C Because of periodicity of the dependence of the SC energy in omega we have
4932 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4933 C To avoid underflows, first compute & store the exponents.
4934
4935         do iii=-1,1
4936
4937           x(3)=x3+iii*dwapi
4938
4939           do j=1,nlobit
4940             do k=1,3
4941               z(k)=x(k)-censc(k,j,it)
4942             enddo
4943             do k=1,3
4944               Axk=0.0D0
4945               do l=1,3
4946                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4947               enddo
4948               Ax(k,j,iii)=Axk
4949             enddo
4950             expfac=0.0D0
4951             do k=1,3
4952               expfac=expfac+Ax(k,j,iii)*z(k)
4953             enddo
4954             contr(j,iii)=expfac
4955           enddo ! j
4956
4957         enddo ! iii
4958
4959         x(3)=x3
4960 C As in the case of ebend, we want to avoid underflows in exponentiation and
4961 C subsequent NaNs and INFs in energy calculation.
4962 C Find the largest exponent
4963         emin=contr(1,-1)
4964         do iii=-1,1
4965           do j=1,nlobit
4966             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4967           enddo
4968         enddo
4969         emin=0.5D0*emin
4970 cd      print *,'it=',it,' emin=',emin
4971
4972 C Compute the contribution to SC energy and derivatives
4973         do iii=-1,1
4974
4975           do j=1,nlobit
4976 #ifdef OSF
4977             adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin
4978             if(adexp.ne.adexp) adexp=1.0
4979             expfac=dexp(adexp)
4980 #else
4981             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
4982 #endif
4983 cd          print *,'j=',j,' expfac=',expfac
4984             escloc_i=escloc_i+expfac
4985             do k=1,3
4986               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4987             enddo
4988             if (mixed) then
4989               do k=1,3,2
4990                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4991      &            +gaussc(k,2,j,it))*expfac
4992               enddo
4993             endif
4994           enddo
4995
4996         enddo ! iii
4997
4998         dersc(1)=dersc(1)/cos(theti)**2
4999         ddersc(1)=ddersc(1)/cos(theti)**2
5000         ddersc(3)=ddersc(3)
5001
5002         escloci=-(dlog(escloc_i)-emin)
5003         do j=1,3
5004           dersc(j)=dersc(j)/escloc_i
5005         enddo
5006         if (mixed) then
5007           do j=1,3,2
5008             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5009           enddo
5010         endif
5011       return
5012       end
5013 C------------------------------------------------------------------------------
5014       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5015       implicit real*8 (a-h,o-z)
5016       include 'DIMENSIONS'
5017       include 'COMMON.GEO'
5018       include 'COMMON.LOCAL'
5019       include 'COMMON.IOUNITS'
5020       common /sccalc/ time11,time12,time112,theti,it,nlobit
5021       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5022       double precision contr(maxlob)
5023       logical mixed
5024
5025       escloc_i=0.0D0
5026
5027       do j=1,3
5028         dersc(j)=0.0D0
5029       enddo
5030
5031       do j=1,nlobit
5032         do k=1,2
5033           z(k)=x(k)-censc(k,j,it)
5034         enddo
5035         z(3)=dwapi
5036         do k=1,3
5037           Axk=0.0D0
5038           do l=1,3
5039             Axk=Axk+gaussc(l,k,j,it)*z(l)
5040           enddo
5041           Ax(k,j)=Axk
5042         enddo
5043         expfac=0.0D0
5044         do k=1,3
5045           expfac=expfac+Ax(k,j)*z(k)
5046         enddo
5047         contr(j)=expfac
5048       enddo ! j
5049
5050 C As in the case of ebend, we want to avoid underflows in exponentiation and
5051 C subsequent NaNs and INFs in energy calculation.
5052 C Find the largest exponent
5053       emin=contr(1)
5054       do j=1,nlobit
5055         if (emin.gt.contr(j)) emin=contr(j)
5056       enddo
5057       emin=0.5D0*emin
5058
5059 C Compute the contribution to SC energy and derivatives
5060
5061       dersc12=0.0d0
5062       do j=1,nlobit
5063         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
5064         escloc_i=escloc_i+expfac
5065         do k=1,2
5066           dersc(k)=dersc(k)+Ax(k,j)*expfac
5067         enddo
5068         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5069      &            +gaussc(1,2,j,it))*expfac
5070         dersc(3)=0.0d0
5071       enddo
5072
5073       dersc(1)=dersc(1)/cos(theti)**2
5074       dersc12=dersc12/cos(theti)**2
5075       escloci=-(dlog(escloc_i)-emin)
5076       do j=1,2
5077         dersc(j)=dersc(j)/escloc_i
5078       enddo
5079       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5080       return
5081       end
5082 #else
5083 c----------------------------------------------------------------------------------
5084       subroutine esc(escloc)
5085 C Calculate the local energy of a side chain and its derivatives in the
5086 C corresponding virtual-bond valence angles THETA and the spherical angles
5087 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5088 C added by Urszula Kozlowska. 07/11/2007
5089 C
5090       implicit real*8 (a-h,o-z)
5091       include 'DIMENSIONS'
5092       include 'COMMON.GEO'
5093       include 'COMMON.LOCAL'
5094       include 'COMMON.VAR'
5095       include 'COMMON.SCROT'
5096       include 'COMMON.INTERACT'
5097       include 'COMMON.DERIV'
5098       include 'COMMON.CHAIN'
5099       include 'COMMON.IOUNITS'
5100       include 'COMMON.NAMES'
5101       include 'COMMON.FFIELD'
5102       include 'COMMON.CONTROL'
5103       include 'COMMON.VECTORS'
5104       double precision x_prime(3),y_prime(3),z_prime(3)
5105      &    , sumene,dsc_i,dp2_i,x(65),
5106      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5107      &    de_dxx,de_dyy,de_dzz,de_dt
5108       double precision s1_t,s1_6_t,s2_t,s2_6_t
5109       double precision
5110      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5111      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5112      & dt_dCi(3),dt_dCi1(3)
5113       common /sccalc/ time11,time12,time112,theti,it,nlobit
5114       delta=0.02d0*pi
5115       escloc=0.0D0
5116       do i=loc_start,loc_end
5117         costtab(i+1) =dcos(theta(i+1))
5118         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5119         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5120         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5121         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5122         cosfac=dsqrt(cosfac2)
5123         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5124         sinfac=dsqrt(sinfac2)
5125         it=itype(i)
5126         if (it.eq.10) goto 1
5127 c
5128 C  Compute the axes of tghe local cartesian coordinates system; store in
5129 c   x_prime, y_prime and z_prime
5130 c
5131         do j=1,3
5132           x_prime(j) = 0.00
5133           y_prime(j) = 0.00
5134           z_prime(j) = 0.00
5135         enddo
5136 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5137 C     &   dc_norm(3,i+nres)
5138         do j = 1,3
5139           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5140           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5141         enddo
5142         do j = 1,3
5143           z_prime(j) = -uz(j,i-1)
5144         enddo
5145 c       write (2,*) "i",i
5146 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5147 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5148 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5149 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5150 c      & " xy",scalar(x_prime(1),y_prime(1)),
5151 c      & " xz",scalar(x_prime(1),z_prime(1)),
5152 c      & " yy",scalar(y_prime(1),y_prime(1)),
5153 c      & " yz",scalar(y_prime(1),z_prime(1)),
5154 c      & " zz",scalar(z_prime(1),z_prime(1))
5155 c
5156 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5157 C to local coordinate system. Store in xx, yy, zz.
5158 c
5159         xx=0.0d0
5160         yy=0.0d0
5161         zz=0.0d0
5162         do j = 1,3
5163           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5164           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5165           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5166         enddo
5167
5168         xxtab(i)=xx
5169         yytab(i)=yy
5170         zztab(i)=zz
5171 C
5172 C Compute the energy of the ith side cbain
5173 C
5174 c        write (2,*) "xx",xx," yy",yy," zz",zz
5175         it=itype(i)
5176         do j = 1,65
5177           x(j) = sc_parmin(j,it)
5178         enddo
5179 #ifdef CHECK_COORD
5180 Cc diagnostics - remove later
5181         xx1 = dcos(alph(2))
5182         yy1 = dsin(alph(2))*dcos(omeg(2))
5183         zz1 = -dsin(alph(2))*dsin(omeg(2))
5184         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5185      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5186      &    xx1,yy1,zz1
5187 C,"  --- ", xx_w,yy_w,zz_w
5188 c end diagnostics
5189 #endif
5190         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5191      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5192      &   + x(10)*yy*zz
5193         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5194      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5195      & + x(20)*yy*zz
5196         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5197      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5198      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5199      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5200      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5201      &  +x(40)*xx*yy*zz
5202         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5203      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5204      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5205      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5206      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5207      &  +x(60)*xx*yy*zz
5208         dsc_i   = 0.743d0+x(61)
5209         dp2_i   = 1.9d0+x(62)
5210         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5211      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5212         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5213      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5214         s1=(1+x(63))/(0.1d0 + dscp1)
5215         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5216         s2=(1+x(65))/(0.1d0 + dscp2)
5217         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5218         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5219      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5220 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5221 c     &   sumene4,
5222 c     &   dscp1,dscp2,sumene
5223 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5224         escloc = escloc + sumene
5225 c        write (2,*) "i",i," escloc",sumene,escloc
5226 #ifdef DEBUG
5227 C
5228 C This section to check the numerical derivatives of the energy of ith side
5229 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5230 C #define DEBUG in the code to turn it on.
5231 C
5232         write (2,*) "sumene               =",sumene
5233         aincr=1.0d-7
5234         xxsave=xx
5235         xx=xx+aincr
5236         write (2,*) xx,yy,zz
5237         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5238         de_dxx_num=(sumenep-sumene)/aincr
5239         xx=xxsave
5240         write (2,*) "xx+ sumene from enesc=",sumenep
5241         yysave=yy
5242         yy=yy+aincr
5243         write (2,*) xx,yy,zz
5244         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5245         de_dyy_num=(sumenep-sumene)/aincr
5246         yy=yysave
5247         write (2,*) "yy+ sumene from enesc=",sumenep
5248         zzsave=zz
5249         zz=zz+aincr
5250         write (2,*) xx,yy,zz
5251         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5252         de_dzz_num=(sumenep-sumene)/aincr
5253         zz=zzsave
5254         write (2,*) "zz+ sumene from enesc=",sumenep
5255         costsave=cost2tab(i+1)
5256         sintsave=sint2tab(i+1)
5257         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5258         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5259         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5260         de_dt_num=(sumenep-sumene)/aincr
5261         write (2,*) " t+ sumene from enesc=",sumenep
5262         cost2tab(i+1)=costsave
5263         sint2tab(i+1)=sintsave
5264 C End of diagnostics section.
5265 #endif
5266 C
5267 C Compute the gradient of esc
5268 C
5269         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5270         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5271         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5272         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5273         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5274         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5275         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5276         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5277         pom1=(sumene3*sint2tab(i+1)+sumene1)
5278      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5279         pom2=(sumene4*cost2tab(i+1)+sumene2)
5280      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5281         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5282         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5283      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5284      &  +x(40)*yy*zz
5285         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5286         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5287      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5288      &  +x(60)*yy*zz
5289         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5290      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5291      &        +(pom1+pom2)*pom_dx
5292 #ifdef DEBUG
5293         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5294 #endif
5295 C
5296         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5297         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5298      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5299      &  +x(40)*xx*zz
5300         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5301         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5302      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5303      &  +x(59)*zz**2 +x(60)*xx*zz
5304         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5305      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5306      &        +(pom1-pom2)*pom_dy
5307 #ifdef DEBUG
5308         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5309 #endif
5310 C
5311         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5312      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5313      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5314      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5315      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5316      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5317      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5318      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5319 #ifdef DEBUG
5320         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5321 #endif
5322 C
5323         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5324      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5325      &  +pom1*pom_dt1+pom2*pom_dt2
5326 #ifdef DEBUG
5327         write(2,*), "de_dt = ", de_dt,de_dt_num
5328 #endif
5329 c
5330 C
5331        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5332        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5333        cosfac2xx=cosfac2*xx
5334        sinfac2yy=sinfac2*yy
5335        do k = 1,3
5336          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5337      &      vbld_inv(i+1)
5338          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5339      &      vbld_inv(i)
5340          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5341          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5342 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5343 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5344 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5345 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5346          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5347          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5348          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5349          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5350          dZZ_Ci1(k)=0.0d0
5351          dZZ_Ci(k)=0.0d0
5352          do j=1,3
5353            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5354            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5355          enddo
5356
5357          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5358          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5359          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5360 c
5361          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5362          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5363        enddo
5364
5365        do k=1,3
5366          dXX_Ctab(k,i)=dXX_Ci(k)
5367          dXX_C1tab(k,i)=dXX_Ci1(k)
5368          dYY_Ctab(k,i)=dYY_Ci(k)
5369          dYY_C1tab(k,i)=dYY_Ci1(k)
5370          dZZ_Ctab(k,i)=dZZ_Ci(k)
5371          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5372          dXX_XYZtab(k,i)=dXX_XYZ(k)
5373          dYY_XYZtab(k,i)=dYY_XYZ(k)
5374          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5375        enddo
5376
5377        do k = 1,3
5378 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5379 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5380 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5381 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5382 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5383 c     &    dt_dci(k)
5384 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5385 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5386          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5387      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5388          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5389      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5390          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5391      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5392        enddo
5393 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5394 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5395
5396 C to check gradient call subroutine check_grad
5397
5398     1 continue
5399       enddo
5400       return
5401       end
5402 c------------------------------------------------------------------------------
5403       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5404       implicit none
5405       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5406      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5407       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5408      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5409      &   + x(10)*yy*zz
5410       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5411      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5412      & + x(20)*yy*zz
5413       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5414      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5415      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5416      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5417      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5418      &  +x(40)*xx*yy*zz
5419       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5420      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5421      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5422      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5423      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5424      &  +x(60)*xx*yy*zz
5425       dsc_i   = 0.743d0+x(61)
5426       dp2_i   = 1.9d0+x(62)
5427       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5428      &          *(xx*cost2+yy*sint2))
5429       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5430      &          *(xx*cost2-yy*sint2))
5431       s1=(1+x(63))/(0.1d0 + dscp1)
5432       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5433       s2=(1+x(65))/(0.1d0 + dscp2)
5434       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5435       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5436      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5437       enesc=sumene
5438       return
5439       end
5440 #endif
5441 c------------------------------------------------------------------------------
5442       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5443 C
5444 C This procedure calculates two-body contact function g(rij) and its derivative:
5445 C
5446 C           eps0ij                                     !       x < -1
5447 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5448 C            0                                         !       x > 1
5449 C
5450 C where x=(rij-r0ij)/delta
5451 C
5452 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5453 C
5454       implicit none
5455       double precision rij,r0ij,eps0ij,fcont,fprimcont
5456       double precision x,x2,x4,delta
5457 c     delta=0.02D0*r0ij
5458 c      delta=0.2D0*r0ij
5459       x=(rij-r0ij)/delta
5460       if (x.lt.-1.0D0) then
5461         fcont=eps0ij
5462         fprimcont=0.0D0
5463       else if (x.le.1.0D0) then
5464         x2=x*x
5465         x4=x2*x2
5466         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5467         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5468       else
5469         fcont=0.0D0
5470         fprimcont=0.0D0
5471       endif
5472       return
5473       end
5474 c------------------------------------------------------------------------------
5475       subroutine splinthet(theti,delta,ss,ssder)
5476       implicit real*8 (a-h,o-z)
5477       include 'DIMENSIONS'
5478       include 'COMMON.VAR'
5479       include 'COMMON.GEO'
5480       thetup=pi-delta
5481       thetlow=delta
5482       if (theti.gt.pipol) then
5483         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5484       else
5485         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5486         ssder=-ssder
5487       endif
5488       return
5489       end
5490 c------------------------------------------------------------------------------
5491       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5492       implicit none
5493       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5494       double precision ksi,ksi2,ksi3,a1,a2,a3
5495       a1=fprim0*delta/(f1-f0)
5496       a2=3.0d0-2.0d0*a1
5497       a3=a1-2.0d0
5498       ksi=(x-x0)/delta
5499       ksi2=ksi*ksi
5500       ksi3=ksi2*ksi
5501       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5502       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5503       return
5504       end
5505 c------------------------------------------------------------------------------
5506       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5507       implicit none
5508       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5509       double precision ksi,ksi2,ksi3,a1,a2,a3
5510       ksi=(x-x0)/delta
5511       ksi2=ksi*ksi
5512       ksi3=ksi2*ksi
5513       a1=fprim0x*delta
5514       a2=3*(f1x-f0x)-2*fprim0x*delta
5515       a3=fprim0x*delta-2*(f1x-f0x)
5516       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5517       return
5518       end
5519 C-----------------------------------------------------------------------------
5520 #ifdef CRYST_TOR
5521 C-----------------------------------------------------------------------------
5522       subroutine etor(etors,edihcnstr)
5523       implicit real*8 (a-h,o-z)
5524       include 'DIMENSIONS'
5525       include 'COMMON.VAR'
5526       include 'COMMON.GEO'
5527       include 'COMMON.LOCAL'
5528       include 'COMMON.TORSION'
5529       include 'COMMON.INTERACT'
5530       include 'COMMON.DERIV'
5531       include 'COMMON.CHAIN'
5532       include 'COMMON.NAMES'
5533       include 'COMMON.IOUNITS'
5534       include 'COMMON.FFIELD'
5535       include 'COMMON.TORCNSTR'
5536       include 'COMMON.CONTROL'
5537       logical lprn
5538 C Set lprn=.true. for debugging
5539       lprn=.false.
5540 c      lprn=.true.
5541       etors=0.0D0
5542       do i=iphi_start,iphi_end
5543       etors_ii=0.0D0
5544         itori=itortyp(itype(i-2))
5545         itori1=itortyp(itype(i-1))
5546         phii=phi(i)
5547         gloci=0.0D0
5548 C Proline-Proline pair is a special case...
5549         if (itori.eq.3 .and. itori1.eq.3) then
5550           if (phii.gt.-dwapi3) then
5551             cosphi=dcos(3*phii)
5552             fac=1.0D0/(1.0D0-cosphi)
5553             etorsi=v1(1,3,3)*fac
5554             etorsi=etorsi+etorsi
5555             etors=etors+etorsi-v1(1,3,3)
5556             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5557             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5558           endif
5559           do j=1,3
5560             v1ij=v1(j+1,itori,itori1)
5561             v2ij=v2(j+1,itori,itori1)
5562             cosphi=dcos(j*phii)
5563             sinphi=dsin(j*phii)
5564             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5565             if (energy_dec) etors_ii=etors_ii+
5566      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5567             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5568           enddo
5569         else
5570           do j=1,nterm_old
5571             v1ij=v1(j,itori,itori1)
5572             v2ij=v2(j,itori,itori1)
5573             cosphi=dcos(j*phii)
5574             sinphi=dsin(j*phii)
5575             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5576             if (energy_dec) etors_ii=etors_ii+
5577      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5578             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5579           enddo
5580         endif
5581         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5582      &        'etor',i,etors_ii
5583         if (lprn)
5584      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5585      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5586      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5587         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5588 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5589       enddo
5590 ! 6/20/98 - dihedral angle constraints
5591       edihcnstr=0.0d0
5592       do i=1,ndih_constr
5593         itori=idih_constr(i)
5594         phii=phi(itori)
5595         difi=phii-phi0(i)
5596         if (difi.gt.drange(i)) then
5597           difi=difi-drange(i)
5598           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5599           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5600         else if (difi.lt.-drange(i)) then
5601           difi=difi+drange(i)
5602           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5603           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5604         endif
5605 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5606 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5607       enddo
5608 !      write (iout,*) 'edihcnstr',edihcnstr
5609       return
5610       end
5611 c------------------------------------------------------------------------------
5612       subroutine etor_d(etors_d)
5613       etors_d=0.0d0
5614       return
5615       end
5616 c----------------------------------------------------------------------------
5617 #else
5618       subroutine etor(etors,edihcnstr)
5619       implicit real*8 (a-h,o-z)
5620       include 'DIMENSIONS'
5621       include 'COMMON.VAR'
5622       include 'COMMON.GEO'
5623       include 'COMMON.LOCAL'
5624       include 'COMMON.TORSION'
5625       include 'COMMON.INTERACT'
5626       include 'COMMON.DERIV'
5627       include 'COMMON.CHAIN'
5628       include 'COMMON.NAMES'
5629       include 'COMMON.IOUNITS'
5630       include 'COMMON.FFIELD'
5631       include 'COMMON.TORCNSTR'
5632       include 'COMMON.CONTROL'
5633       logical lprn
5634 C Set lprn=.true. for debugging
5635       lprn=.false.
5636 c     lprn=.true.
5637       etors=0.0D0
5638       do i=iphi_start,iphi_end
5639       etors_ii=0.0D0
5640         itori=itortyp(itype(i-2))
5641         itori1=itortyp(itype(i-1))
5642         phii=phi(i)
5643         gloci=0.0D0
5644 C Regular cosine and sine terms
5645         do j=1,nterm(itori,itori1)
5646           v1ij=v1(j,itori,itori1)
5647           v2ij=v2(j,itori,itori1)
5648           cosphi=dcos(j*phii)
5649           sinphi=dsin(j*phii)
5650           etors=etors+v1ij*cosphi+v2ij*sinphi
5651           if (energy_dec) etors_ii=etors_ii+
5652      &                v1ij*cosphi+v2ij*sinphi
5653           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5654         enddo
5655 C Lorentz terms
5656 C                         v1
5657 C  E = SUM ----------------------------------- - v1
5658 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5659 C
5660         cosphi=dcos(0.5d0*phii)
5661         sinphi=dsin(0.5d0*phii)
5662         do j=1,nlor(itori,itori1)
5663           vl1ij=vlor1(j,itori,itori1)
5664           vl2ij=vlor2(j,itori,itori1)
5665           vl3ij=vlor3(j,itori,itori1)
5666           pom=vl2ij*cosphi+vl3ij*sinphi
5667           pom1=1.0d0/(pom*pom+1.0d0)
5668           etors=etors+vl1ij*pom1
5669           if (energy_dec) etors_ii=etors_ii+
5670      &                vl1ij*pom1
5671           pom=-pom*pom1*pom1
5672           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5673         enddo
5674 C Subtract the constant term
5675         etors=etors-v0(itori,itori1)
5676           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5677      &         'etor',i,etors_ii-v0(itori,itori1)
5678         if (lprn)
5679      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5680      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5681      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5682         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5683 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5684       enddo
5685 ! 6/20/98 - dihedral angle constraints
5686       edihcnstr=0.0d0
5687 c      do i=1,ndih_constr
5688       do i=idihconstr_start,idihconstr_end
5689         itori=idih_constr(i)
5690         phii=phi(itori)
5691         difi=pinorm(phii-phi0(i))
5692         if (difi.gt.drange(i)) then
5693           difi=difi-drange(i)
5694           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5695           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5696         else if (difi.lt.-drange(i)) then
5697           difi=difi+drange(i)
5698           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5699           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5700         else
5701           difi=0.0
5702         endif
5703 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5704 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5705 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5706       enddo
5707 cd       write (iout,*) 'edihcnstr',edihcnstr
5708       return
5709       end
5710 c----------------------------------------------------------------------------
5711       subroutine etor_d(etors_d)
5712 C 6/23/01 Compute double torsional energy
5713       implicit real*8 (a-h,o-z)
5714       include 'DIMENSIONS'
5715       include 'COMMON.VAR'
5716       include 'COMMON.GEO'
5717       include 'COMMON.LOCAL'
5718       include 'COMMON.TORSION'
5719       include 'COMMON.INTERACT'
5720       include 'COMMON.DERIV'
5721       include 'COMMON.CHAIN'
5722       include 'COMMON.NAMES'
5723       include 'COMMON.IOUNITS'
5724       include 'COMMON.FFIELD'
5725       include 'COMMON.TORCNSTR'
5726       logical lprn
5727 C Set lprn=.true. for debugging
5728       lprn=.false.
5729 c     lprn=.true.
5730       etors_d=0.0D0
5731       do i=iphid_start,iphid_end
5732         itori=itortyp(itype(i-2))
5733         itori1=itortyp(itype(i-1))
5734         itori2=itortyp(itype(i))
5735         phii=phi(i)
5736         phii1=phi(i+1)
5737         gloci1=0.0D0
5738         gloci2=0.0D0
5739 C Regular cosine and sine terms
5740         do j=1,ntermd_1(itori,itori1,itori2)
5741           v1cij=v1c(1,j,itori,itori1,itori2)
5742           v1sij=v1s(1,j,itori,itori1,itori2)
5743           v2cij=v1c(2,j,itori,itori1,itori2)
5744           v2sij=v1s(2,j,itori,itori1,itori2)
5745           cosphi1=dcos(j*phii)
5746           sinphi1=dsin(j*phii)
5747           cosphi2=dcos(j*phii1)
5748           sinphi2=dsin(j*phii1)
5749           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5750      &     v2cij*cosphi2+v2sij*sinphi2
5751           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5752           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5753         enddo
5754         do k=2,ntermd_2(itori,itori1,itori2)
5755           do l=1,k-1
5756             v1cdij = v2c(k,l,itori,itori1,itori2)
5757             v2cdij = v2c(l,k,itori,itori1,itori2)
5758             v1sdij = v2s(k,l,itori,itori1,itori2)
5759             v2sdij = v2s(l,k,itori,itori1,itori2)
5760             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5761             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5762             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5763             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5764             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5765      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5766             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5767      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5768             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5769      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5770           enddo
5771         enddo
5772         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5773         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5774       enddo
5775       return
5776       end
5777 #endif
5778 c------------------------------------------------------------------------------
5779       subroutine eback_sc_corr(esccor)
5780 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5781 c        conformational states; temporarily implemented as differences
5782 c        between UNRES torsional potentials (dependent on three types of
5783 c        residues) and the torsional potentials dependent on all 20 types
5784 c        of residues computed from AM1  energy surfaces of terminally-blocked
5785 c        amino-acid residues.
5786       implicit real*8 (a-h,o-z)
5787       include 'DIMENSIONS'
5788       include 'COMMON.VAR'
5789       include 'COMMON.GEO'
5790       include 'COMMON.LOCAL'
5791       include 'COMMON.TORSION'
5792       include 'COMMON.SCCOR'
5793       include 'COMMON.INTERACT'
5794       include 'COMMON.DERIV'
5795       include 'COMMON.CHAIN'
5796       include 'COMMON.NAMES'
5797       include 'COMMON.IOUNITS'
5798       include 'COMMON.FFIELD'
5799       include 'COMMON.CONTROL'
5800       logical lprn
5801 C Set lprn=.true. for debugging
5802       lprn=.false.
5803 c      lprn=.true.
5804 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
5805       esccor=0.0D0
5806       do i=iphi_start,iphi_end
5807         esccor_ii=0.0D0
5808         itori=itype(i-2)
5809         itori1=itype(i-1)
5810         phii=phi(i)
5811         gloci=0.0D0
5812         do j=1,nterm_sccor
5813           v1ij=v1sccor(j,itori,itori1)
5814           v2ij=v2sccor(j,itori,itori1)
5815           cosphi=dcos(j*phii)
5816           sinphi=dsin(j*phii)
5817           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5818           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5819         enddo
5820         if (lprn)
5821      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5822      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5823      &  (v1sccor(j,itori,itori1),j=1,6),(v2sccor(j,itori,itori1),j=1,6)
5824         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5825       enddo
5826       return
5827       end
5828 c----------------------------------------------------------------------------
5829       subroutine multibody(ecorr)
5830 C This subroutine calculates multi-body contributions to energy following
5831 C the idea of Skolnick et al. If side chains I and J make a contact and
5832 C at the same time side chains I+1 and J+1 make a contact, an extra
5833 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5834       implicit real*8 (a-h,o-z)
5835       include 'DIMENSIONS'
5836       include 'COMMON.IOUNITS'
5837       include 'COMMON.DERIV'
5838       include 'COMMON.INTERACT'
5839       include 'COMMON.CONTACTS'
5840       double precision gx(3),gx1(3)
5841       logical lprn
5842
5843 C Set lprn=.true. for debugging
5844       lprn=.false.
5845
5846       if (lprn) then
5847         write (iout,'(a)') 'Contact function values:'
5848         do i=nnt,nct-2
5849           write (iout,'(i2,20(1x,i2,f10.5))')
5850      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5851         enddo
5852       endif
5853       ecorr=0.0D0
5854       do i=nnt,nct
5855         do j=1,3
5856           gradcorr(j,i)=0.0D0
5857           gradxorr(j,i)=0.0D0
5858         enddo
5859       enddo
5860       do i=nnt,nct-2
5861
5862         DO ISHIFT = 3,4
5863
5864         i1=i+ishift
5865         num_conti=num_cont(i)
5866         num_conti1=num_cont(i1)
5867         do jj=1,num_conti
5868           j=jcont(jj,i)
5869           do kk=1,num_conti1
5870             j1=jcont(kk,i1)
5871             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5872 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5873 cd   &                   ' ishift=',ishift
5874 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5875 C The system gains extra energy.
5876               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5877             endif   ! j1==j+-ishift
5878           enddo     ! kk
5879         enddo       ! jj
5880
5881         ENDDO ! ISHIFT
5882
5883       enddo         ! i
5884       return
5885       end
5886 c------------------------------------------------------------------------------
5887       double precision function esccorr(i,j,k,l,jj,kk)
5888       implicit real*8 (a-h,o-z)
5889       include 'DIMENSIONS'
5890       include 'COMMON.IOUNITS'
5891       include 'COMMON.DERIV'
5892       include 'COMMON.INTERACT'
5893       include 'COMMON.CONTACTS'
5894       double precision gx(3),gx1(3)
5895       logical lprn
5896       lprn=.false.
5897       eij=facont(jj,i)
5898       ekl=facont(kk,k)
5899 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5900 C Calculate the multi-body contribution to energy.
5901 C Calculate multi-body contributions to the gradient.
5902 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5903 cd   & k,l,(gacont(m,kk,k),m=1,3)
5904       do m=1,3
5905         gx(m) =ekl*gacont(m,jj,i)
5906         gx1(m)=eij*gacont(m,kk,k)
5907         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5908         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5909         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5910         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5911       enddo
5912       do m=i,j-1
5913         do ll=1,3
5914           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5915         enddo
5916       enddo
5917       do m=k,l-1
5918         do ll=1,3
5919           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5920         enddo
5921       enddo
5922       esccorr=-eij*ekl
5923       return
5924       end
5925 c------------------------------------------------------------------------------
5926       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5927 C This subroutine calculates multi-body contributions to hydrogen-bonding
5928       implicit real*8 (a-h,o-z)
5929       include 'DIMENSIONS'
5930       include 'COMMON.IOUNITS'
5931 #ifdef MPI
5932       include "mpif.h"
5933       parameter (max_cont=maxconts)
5934       parameter (max_dim=26)
5935       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
5936       double precision zapas(max_dim,maxconts,max_fg_procs),
5937      &  zapas_recv(max_dim,maxconts,max_fg_procs)
5938       common /przechowalnia/ zapas
5939       integer status(MPI_STATUS_SIZE),req(maxconts*2),
5940      &  status_array(MPI_STATUS_SIZE,maxconts*2)
5941 #endif
5942       include 'COMMON.SETUP'
5943       include 'COMMON.FFIELD'
5944       include 'COMMON.DERIV'
5945       include 'COMMON.INTERACT'
5946       include 'COMMON.CONTACTS'
5947       include 'COMMON.CONTROL'
5948       include 'COMMON.LOCAL'
5949       double precision gx(3),gx1(3),time00
5950       logical lprn,ldone
5951
5952 C Set lprn=.true. for debugging
5953       lprn=.false.
5954 #ifdef MPI
5955       n_corr=0
5956       n_corr1=0
5957       if (nfgtasks.le.1) goto 30
5958       if (lprn) then
5959         write (iout,'(a)') 'Contact function values before RECEIVE:'
5960         do i=nnt,nct-2
5961           write (iout,'(2i3,50(1x,i2,f5.2))')
5962      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5963      &    j=1,num_cont_hb(i))
5964         enddo
5965       endif
5966       call flush(iout)
5967       do i=1,ntask_cont_from
5968         ncont_recv(i)=0
5969       enddo
5970       do i=1,ntask_cont_to
5971         ncont_sent(i)=0
5972       enddo
5973 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
5974 c     & ntask_cont_to
5975 C Make the list of contacts to send to send to other procesors
5976 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
5977 c      call flush(iout)
5978       do i=iturn3_start,iturn3_end
5979 c        write (iout,*) "make contact list turn3",i," num_cont",
5980 c     &    num_cont_hb(i)
5981         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
5982       enddo
5983       do i=iturn4_start,iturn4_end
5984 c        write (iout,*) "make contact list turn4",i," num_cont",
5985 c     &   num_cont_hb(i)
5986         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
5987       enddo
5988       do ii=1,nat_sent
5989         i=iat_sent(ii)
5990 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
5991 c     &    num_cont_hb(i)
5992         do j=1,num_cont_hb(i)
5993         do k=1,4
5994           jjc=jcont_hb(j,i)
5995           iproc=iint_sent_local(k,jjc,ii)
5996 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
5997           if (iproc.gt.0) then
5998             ncont_sent(iproc)=ncont_sent(iproc)+1
5999             nn=ncont_sent(iproc)
6000             zapas(1,nn,iproc)=i
6001             zapas(2,nn,iproc)=jjc
6002             zapas(3,nn,iproc)=facont_hb(j,i)
6003             zapas(4,nn,iproc)=ees0p(j,i)
6004             zapas(5,nn,iproc)=ees0m(j,i)
6005             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6006             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6007             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6008             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6009             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6010             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6011             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6012             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6013             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6014             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6015             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6016             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6017             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6018             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6019             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6020             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6021             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6022             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6023             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6024             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6025             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6026           endif
6027         enddo
6028         enddo
6029       enddo
6030       if (lprn) then
6031       write (iout,*)
6032      &  "Numbers of contacts to be sent to other processors",
6033      &  (ncont_sent(i),i=1,ntask_cont_to)
6034       write (iout,*) "Contacts sent"
6035       do ii=1,ntask_cont_to
6036         nn=ncont_sent(ii)
6037         iproc=itask_cont_to(ii)
6038         write (iout,*) nn," contacts to processor",iproc,
6039      &   " of CONT_TO_COMM group"
6040         do i=1,nn
6041           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6042         enddo
6043       enddo
6044       call flush(iout)
6045       endif
6046       CorrelType=477
6047       CorrelID=fg_rank+1
6048       CorrelType1=478
6049       CorrelID1=nfgtasks+fg_rank+1
6050       ireq=0
6051 C Receive the numbers of needed contacts from other processors
6052       do ii=1,ntask_cont_from
6053         iproc=itask_cont_from(ii)
6054         ireq=ireq+1
6055         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6056      &    FG_COMM,req(ireq),IERR)
6057       enddo
6058 c      write (iout,*) "IRECV ended"
6059 c      call flush(iout)
6060 C Send the number of contacts needed by other processors
6061       do ii=1,ntask_cont_to
6062         iproc=itask_cont_to(ii)
6063         ireq=ireq+1
6064         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6065      &    FG_COMM,req(ireq),IERR)
6066       enddo
6067 c      write (iout,*) "ISEND ended"
6068 c      write (iout,*) "number of requests (nn)",ireq
6069       call flush(iout)
6070       if (ireq.gt.0)
6071      &  call MPI_Waitall(ireq,req,status_array,ierr)
6072 c      write (iout,*)
6073 c     &  "Numbers of contacts to be received from other processors",
6074 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6075 c      call flush(iout)
6076 C Receive contacts
6077       ireq=0
6078       do ii=1,ntask_cont_from
6079         iproc=itask_cont_from(ii)
6080         nn=ncont_recv(ii)
6081 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6082 c     &   " of CONT_TO_COMM group"
6083         call flush(iout)
6084         if (nn.gt.0) then
6085           ireq=ireq+1
6086           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6087      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6088 c          write (iout,*) "ireq,req",ireq,req(ireq)
6089         endif
6090       enddo
6091 C Send the contacts to processors that need them
6092       do ii=1,ntask_cont_to
6093         iproc=itask_cont_to(ii)
6094         nn=ncont_sent(ii)
6095 c        write (iout,*) nn," contacts to processor",iproc,
6096 c     &   " of CONT_TO_COMM group"
6097         if (nn.gt.0) then
6098           ireq=ireq+1
6099           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6100      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6101 c          write (iout,*) "ireq,req",ireq,req(ireq)
6102 c          do i=1,nn
6103 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6104 c          enddo
6105         endif
6106       enddo
6107 c      write (iout,*) "number of requests (contacts)",ireq
6108 c      write (iout,*) "req",(req(i),i=1,4)
6109 c      call flush(iout)
6110       if (ireq.gt.0)
6111      & call MPI_Waitall(ireq,req,status_array,ierr)
6112       do iii=1,ntask_cont_from
6113         iproc=itask_cont_from(iii)
6114         nn=ncont_recv(iii)
6115         if (lprn) then
6116         write (iout,*) "Received",nn," contacts from processor",iproc,
6117      &   " of CONT_FROM_COMM group"
6118         call flush(iout)
6119         do i=1,nn
6120           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6121         enddo
6122         call flush(iout)
6123         endif
6124         do i=1,nn
6125           ii=zapas_recv(1,i,iii)
6126 c Flag the received contacts to prevent double-counting
6127           jj=-zapas_recv(2,i,iii)
6128 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6129 c          call flush(iout)
6130           nnn=num_cont_hb(ii)+1
6131           num_cont_hb(ii)=nnn
6132           jcont_hb(nnn,ii)=jj
6133           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6134           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6135           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6136           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6137           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6138           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6139           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6140           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6141           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6142           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6143           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6144           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6145           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6146           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6147           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6148           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6149           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6150           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6151           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6152           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6153           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6154           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6155           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6156           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6157         enddo
6158       enddo
6159       call flush(iout)
6160       if (lprn) then
6161         write (iout,'(a)') 'Contact function values after receive:'
6162         do i=nnt,nct-2
6163           write (iout,'(2i3,50(1x,i3,f5.2))')
6164      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6165      &    j=1,num_cont_hb(i))
6166         enddo
6167         call flush(iout)
6168       endif
6169    30 continue
6170 #endif
6171       if (lprn) then
6172         write (iout,'(a)') 'Contact function values:'
6173         do i=nnt,nct-2
6174           write (iout,'(2i3,50(1x,i3,f5.2))')
6175      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6176      &    j=1,num_cont_hb(i))
6177         enddo
6178       endif
6179       ecorr=0.0D0
6180 C Remove the loop below after debugging !!!
6181       do i=nnt,nct
6182         do j=1,3
6183           gradcorr(j,i)=0.0D0
6184           gradxorr(j,i)=0.0D0
6185         enddo
6186       enddo
6187 C Calculate the local-electrostatic correlation terms
6188       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6189         i1=i+1
6190         num_conti=num_cont_hb(i)
6191         num_conti1=num_cont_hb(i+1)
6192         do jj=1,num_conti
6193           j=jcont_hb(jj,i)
6194           jp=iabs(j)
6195           do kk=1,num_conti1
6196             j1=jcont_hb(kk,i1)
6197             jp1=iabs(j1)
6198 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6199 c     &         ' jj=',jj,' kk=',kk
6200             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6201      &          .or. j.lt.0 .and. j1.gt.0) .and.
6202      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6203 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6204 C The system gains extra energy.
6205               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6206               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6207      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6208               n_corr=n_corr+1
6209             else if (j1.eq.j) then
6210 C Contacts I-J and I-(J+1) occur simultaneously.
6211 C The system loses extra energy.
6212 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6213             endif
6214           enddo ! kk
6215           do kk=1,num_conti
6216             j1=jcont_hb(kk,i)
6217 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6218 c    &         ' jj=',jj,' kk=',kk
6219             if (j1.eq.j+1) then
6220 C Contacts I-J and (I+1)-J occur simultaneously.
6221 C The system loses extra energy.
6222 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6223             endif ! j1==j+1
6224           enddo ! kk
6225         enddo ! jj
6226       enddo ! i
6227       return
6228       end
6229 c------------------------------------------------------------------------------
6230       subroutine add_hb_contact(ii,jj,itask)
6231       implicit real*8 (a-h,o-z)
6232       include "DIMENSIONS"
6233       include "COMMON.IOUNITS"
6234       integer max_cont
6235       integer max_dim
6236       parameter (max_cont=maxconts)
6237       parameter (max_dim=26)
6238       include "COMMON.CONTACTS"
6239       double precision zapas(max_dim,maxconts,max_fg_procs),
6240      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6241       common /przechowalnia/ zapas
6242       integer i,j,ii,jj,iproc,itask(4),nn
6243 c      write (iout,*) "itask",itask
6244       do i=1,2
6245         iproc=itask(i)
6246         if (iproc.gt.0) then
6247           do j=1,num_cont_hb(ii)
6248             jjc=jcont_hb(j,ii)
6249 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6250             if (jjc.eq.jj) then
6251               ncont_sent(iproc)=ncont_sent(iproc)+1
6252               nn=ncont_sent(iproc)
6253               zapas(1,nn,iproc)=ii
6254               zapas(2,nn,iproc)=jjc
6255               zapas(3,nn,iproc)=facont_hb(j,ii)
6256               zapas(4,nn,iproc)=ees0p(j,ii)
6257               zapas(5,nn,iproc)=ees0m(j,ii)
6258               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6259               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6260               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6261               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6262               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6263               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6264               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6265               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6266               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6267               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6268               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6269               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6270               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6271               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6272               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6273               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6274               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6275               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6276               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6277               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6278               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6279               exit
6280             endif
6281           enddo
6282         endif
6283       enddo
6284       return
6285       end
6286 c------------------------------------------------------------------------------
6287       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6288      &  n_corr1)
6289 C This subroutine calculates multi-body contributions to hydrogen-bonding
6290       implicit real*8 (a-h,o-z)
6291       include 'DIMENSIONS'
6292       include 'COMMON.IOUNITS'
6293 #ifdef MPI
6294       include "mpif.h"
6295       parameter (max_cont=maxconts)
6296       parameter (max_dim=70)
6297       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6298       double precision zapas(max_dim,maxconts,max_fg_procs),
6299      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6300       common /przechowalnia/ zapas
6301       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6302      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6303 #endif
6304       include 'COMMON.SETUP'
6305       include 'COMMON.FFIELD'
6306       include 'COMMON.DERIV'
6307       include 'COMMON.LOCAL'
6308       include 'COMMON.INTERACT'
6309       include 'COMMON.CONTACTS'
6310       include 'COMMON.CHAIN'
6311       include 'COMMON.CONTROL'
6312       double precision gx(3),gx1(3)
6313       integer num_cont_hb_old(maxres)
6314       logical lprn,ldone
6315       double precision eello4,eello5,eelo6,eello_turn6
6316       external eello4,eello5,eello6,eello_turn6
6317 C Set lprn=.true. for debugging
6318       lprn=.false.
6319       eturn6=0.0d0
6320 #ifdef MPI
6321       do i=1,nres
6322         num_cont_hb_old(i)=num_cont_hb(i)
6323       enddo
6324       n_corr=0
6325       n_corr1=0
6326       if (nfgtasks.le.1) goto 30
6327       if (lprn) then
6328         write (iout,'(a)') 'Contact function values before RECEIVE:'
6329         do i=nnt,nct-2
6330           write (iout,'(2i3,50(1x,i2,f5.2))')
6331      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6332      &    j=1,num_cont_hb(i))
6333         enddo
6334       endif
6335       call flush(iout)
6336       do i=1,ntask_cont_from
6337         ncont_recv(i)=0
6338       enddo
6339       do i=1,ntask_cont_to
6340         ncont_sent(i)=0
6341       enddo
6342 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6343 c     & ntask_cont_to
6344 C Make the list of contacts to send to send to other procesors
6345       do i=iturn3_start,iturn3_end
6346 c        write (iout,*) "make contact list turn3",i," num_cont",
6347 c     &    num_cont_hb(i)
6348         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6349       enddo
6350       do i=iturn4_start,iturn4_end
6351 c        write (iout,*) "make contact list turn4",i," num_cont",
6352 c     &   num_cont_hb(i)
6353         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6354       enddo
6355       do ii=1,nat_sent
6356         i=iat_sent(ii)
6357 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6358 c     &    num_cont_hb(i)
6359         do j=1,num_cont_hb(i)
6360         do k=1,4
6361           jjc=jcont_hb(j,i)
6362           iproc=iint_sent_local(k,jjc,ii)
6363 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6364           if (iproc.ne.0) then
6365             ncont_sent(iproc)=ncont_sent(iproc)+1
6366             nn=ncont_sent(iproc)
6367             zapas(1,nn,iproc)=i
6368             zapas(2,nn,iproc)=jjc
6369             zapas(3,nn,iproc)=d_cont(j,i)
6370             ind=3
6371             do kk=1,3
6372               ind=ind+1
6373               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6374             enddo
6375             do kk=1,2
6376               do ll=1,2
6377                 ind=ind+1
6378                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6379               enddo
6380             enddo
6381             do jj=1,5
6382               do kk=1,3
6383                 do ll=1,2
6384                   do mm=1,2
6385                     ind=ind+1
6386                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6387                   enddo
6388                 enddo
6389               enddo
6390             enddo
6391           endif
6392         enddo
6393         enddo
6394       enddo
6395       if (lprn) then
6396       write (iout,*)
6397      &  "Numbers of contacts to be sent to other processors",
6398      &  (ncont_sent(i),i=1,ntask_cont_to)
6399       write (iout,*) "Contacts sent"
6400       do ii=1,ntask_cont_to
6401         nn=ncont_sent(ii)
6402         iproc=itask_cont_to(ii)
6403         write (iout,*) nn," contacts to processor",iproc,
6404      &   " of CONT_TO_COMM group"
6405         do i=1,nn
6406           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6407         enddo
6408       enddo
6409       call flush(iout)
6410       endif
6411       CorrelType=477
6412       CorrelID=fg_rank+1
6413       CorrelType1=478
6414       CorrelID1=nfgtasks+fg_rank+1
6415       ireq=0
6416 C Receive the numbers of needed contacts from other processors
6417       do ii=1,ntask_cont_from
6418         iproc=itask_cont_from(ii)
6419         ireq=ireq+1
6420         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6421      &    FG_COMM,req(ireq),IERR)
6422       enddo
6423 c      write (iout,*) "IRECV ended"
6424 c      call flush(iout)
6425 C Send the number of contacts needed by other processors
6426       do ii=1,ntask_cont_to
6427         iproc=itask_cont_to(ii)
6428         ireq=ireq+1
6429         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6430      &    FG_COMM,req(ireq),IERR)
6431       enddo
6432 c      write (iout,*) "ISEND ended"
6433 c      write (iout,*) "number of requests (nn)",ireq
6434       call flush(iout)
6435       if (ireq.gt.0)
6436      &  call MPI_Waitall(ireq,req,status_array,ierr)
6437 c      write (iout,*)
6438 c     &  "Numbers of contacts to be received from other processors",
6439 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6440 c      call flush(iout)
6441 C Receive contacts
6442       ireq=0
6443       do ii=1,ntask_cont_from
6444         iproc=itask_cont_from(ii)
6445         nn=ncont_recv(ii)
6446 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6447 c     &   " of CONT_TO_COMM group"
6448         call flush(iout)
6449         if (nn.gt.0) then
6450           ireq=ireq+1
6451           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6452      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6453 c          write (iout,*) "ireq,req",ireq,req(ireq)
6454         endif
6455       enddo
6456 C Send the contacts to processors that need them
6457       do ii=1,ntask_cont_to
6458         iproc=itask_cont_to(ii)
6459         nn=ncont_sent(ii)
6460 c        write (iout,*) nn," contacts to processor",iproc,
6461 c     &   " of CONT_TO_COMM group"
6462         if (nn.gt.0) then
6463           ireq=ireq+1
6464           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6465      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6466 c          write (iout,*) "ireq,req",ireq,req(ireq)
6467 c          do i=1,nn
6468 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6469 c          enddo
6470         endif
6471       enddo
6472 c      write (iout,*) "number of requests (contacts)",ireq
6473 c      write (iout,*) "req",(req(i),i=1,4)
6474 c      call flush(iout)
6475       if (ireq.gt.0)
6476      & call MPI_Waitall(ireq,req,status_array,ierr)
6477       do iii=1,ntask_cont_from
6478         iproc=itask_cont_from(iii)
6479         nn=ncont_recv(iii)
6480         if (lprn) then
6481         write (iout,*) "Received",nn," contacts from processor",iproc,
6482      &   " of CONT_FROM_COMM group"
6483         call flush(iout)
6484         do i=1,nn
6485           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6486         enddo
6487         call flush(iout)
6488         endif
6489         do i=1,nn
6490           ii=zapas_recv(1,i,iii)
6491 c Flag the received contacts to prevent double-counting
6492           jj=-zapas_recv(2,i,iii)
6493 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6494 c          call flush(iout)
6495           nnn=num_cont_hb(ii)+1
6496           num_cont_hb(ii)=nnn
6497           jcont_hb(nnn,ii)=jj
6498           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6499           ind=3
6500           do kk=1,3
6501             ind=ind+1
6502             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6503           enddo
6504           do kk=1,2
6505             do ll=1,2
6506               ind=ind+1
6507               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6508             enddo
6509           enddo
6510           do jj=1,5
6511             do kk=1,3
6512               do ll=1,2
6513                 do mm=1,2
6514                   ind=ind+1
6515                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6516                 enddo
6517               enddo
6518             enddo
6519           enddo
6520         enddo
6521       enddo
6522       call flush(iout)
6523       if (lprn) then
6524         write (iout,'(a)') 'Contact function values after receive:'
6525         do i=nnt,nct-2
6526           write (iout,'(2i3,50(1x,i3,5f6.3))')
6527      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6528      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6529         enddo
6530         call flush(iout)
6531       endif
6532    30 continue
6533 #endif
6534       if (lprn) then
6535         write (iout,'(a)') 'Contact function values:'
6536         do i=nnt,nct-2
6537           write (iout,'(2i3,50(1x,i2,5f6.3))')
6538      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6539      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6540         enddo
6541       endif
6542       ecorr=0.0D0
6543       ecorr5=0.0d0
6544       ecorr6=0.0d0
6545 C Remove the loop below after debugging !!!
6546       do i=nnt,nct
6547         do j=1,3
6548           gradcorr(j,i)=0.0D0
6549           gradxorr(j,i)=0.0D0
6550         enddo
6551       enddo
6552 C Calculate the dipole-dipole interaction energies
6553       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6554       do i=iatel_s,iatel_e+1
6555         num_conti=num_cont_hb(i)
6556         do jj=1,num_conti
6557           j=jcont_hb(jj,i)
6558 #ifdef MOMENT
6559           call dipole(i,j,jj)
6560 #endif
6561         enddo
6562       enddo
6563       endif
6564 C Calculate the local-electrostatic correlation terms
6565 c                write (iout,*) "gradcorr5 in eello5 before loop"
6566 c                do iii=1,nres
6567 c                  write (iout,'(i5,3f10.5)')
6568 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6569 c                enddo
6570       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6571 c        write (iout,*) "corr loop i",i
6572         i1=i+1
6573         num_conti=num_cont_hb(i)
6574         num_conti1=num_cont_hb(i+1)
6575         do jj=1,num_conti
6576           j=jcont_hb(jj,i)
6577           jp=iabs(j)
6578           do kk=1,num_conti1
6579             j1=jcont_hb(kk,i1)
6580             jp1=iabs(j1)
6581 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6582 c     &         ' jj=',jj,' kk=',kk
6583 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6584             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6585      &          .or. j.lt.0 .and. j1.gt.0) .and.
6586      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6587 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6588 C The system gains extra energy.
6589               n_corr=n_corr+1
6590               sqd1=dsqrt(d_cont(jj,i))
6591               sqd2=dsqrt(d_cont(kk,i1))
6592               sred_geom = sqd1*sqd2
6593               IF (sred_geom.lt.cutoff_corr) THEN
6594                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6595      &            ekont,fprimcont)
6596 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6597 cd     &         ' jj=',jj,' kk=',kk
6598                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6599                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6600                 do l=1,3
6601                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6602                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6603                 enddo
6604                 n_corr1=n_corr1+1
6605 cd               write (iout,*) 'sred_geom=',sred_geom,
6606 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6607 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6608 cd               write (iout,*) "g_contij",g_contij
6609 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6610 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6611                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6612                 if (wcorr4.gt.0.0d0)
6613      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6614                   if (energy_dec.and.wcorr4.gt.0.0d0)
6615      1                 write (iout,'(a6,4i5,0pf7.3)')
6616      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6617 c                write (iout,*) "gradcorr5 before eello5"
6618 c                do iii=1,nres
6619 c                  write (iout,'(i5,3f10.5)')
6620 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6621 c                enddo
6622                 if (wcorr5.gt.0.0d0)
6623      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6624 c                write (iout,*) "gradcorr5 after eello5"
6625 c                do iii=1,nres
6626 c                  write (iout,'(i5,3f10.5)')
6627 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6628 c                enddo
6629                   if (energy_dec.and.wcorr5.gt.0.0d0)
6630      1                 write (iout,'(a6,4i5,0pf7.3)')
6631      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6632 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6633 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6634                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6635      &               .or. wturn6.eq.0.0d0))then
6636 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6637                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6638                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6639      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6640 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6641 cd     &            'ecorr6=',ecorr6
6642 cd                write (iout,'(4e15.5)') sred_geom,
6643 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6644 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6645 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6646                 else if (wturn6.gt.0.0d0
6647      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6648 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6649                   eturn6=eturn6+eello_turn6(i,jj,kk)
6650                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6651      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6652 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6653                 endif
6654               ENDIF
6655 1111          continue
6656             endif
6657           enddo ! kk
6658         enddo ! jj
6659       enddo ! i
6660       do i=1,nres
6661         num_cont_hb(i)=num_cont_hb_old(i)
6662       enddo
6663 c                write (iout,*) "gradcorr5 in eello5"
6664 c                do iii=1,nres
6665 c                  write (iout,'(i5,3f10.5)')
6666 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6667 c                enddo
6668       return
6669       end
6670 c------------------------------------------------------------------------------
6671       subroutine add_hb_contact_eello(ii,jj,itask)
6672       implicit real*8 (a-h,o-z)
6673       include "DIMENSIONS"
6674       include "COMMON.IOUNITS"
6675       integer max_cont
6676       integer max_dim
6677       parameter (max_cont=maxconts)
6678       parameter (max_dim=70)
6679       include "COMMON.CONTACTS"
6680       double precision zapas(max_dim,maxconts,max_fg_procs),
6681      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6682       common /przechowalnia/ zapas
6683       integer i,j,ii,jj,iproc,itask(4),nn
6684 c      write (iout,*) "itask",itask
6685       do i=1,2
6686         iproc=itask(i)
6687         if (iproc.gt.0) then
6688           do j=1,num_cont_hb(ii)
6689             jjc=jcont_hb(j,ii)
6690 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6691             if (jjc.eq.jj) then
6692               ncont_sent(iproc)=ncont_sent(iproc)+1
6693               nn=ncont_sent(iproc)
6694               zapas(1,nn,iproc)=ii
6695               zapas(2,nn,iproc)=jjc
6696               zapas(3,nn,iproc)=d_cont(j,ii)
6697               ind=3
6698               do kk=1,3
6699                 ind=ind+1
6700                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6701               enddo
6702               do kk=1,2
6703                 do ll=1,2
6704                   ind=ind+1
6705                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6706                 enddo
6707               enddo
6708               do jj=1,5
6709                 do kk=1,3
6710                   do ll=1,2
6711                     do mm=1,2
6712                       ind=ind+1
6713                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6714                     enddo
6715                   enddo
6716                 enddo
6717               enddo
6718               exit
6719             endif
6720           enddo
6721         endif
6722       enddo
6723       return
6724       end
6725 c------------------------------------------------------------------------------
6726       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6727       implicit real*8 (a-h,o-z)
6728       include 'DIMENSIONS'
6729       include 'COMMON.IOUNITS'
6730       include 'COMMON.DERIV'
6731       include 'COMMON.INTERACT'
6732       include 'COMMON.CONTACTS'
6733       double precision gx(3),gx1(3)
6734       logical lprn
6735       lprn=.false.
6736       eij=facont_hb(jj,i)
6737       ekl=facont_hb(kk,k)
6738       ees0pij=ees0p(jj,i)
6739       ees0pkl=ees0p(kk,k)
6740       ees0mij=ees0m(jj,i)
6741       ees0mkl=ees0m(kk,k)
6742       ekont=eij*ekl
6743       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6744 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6745 C Following 4 lines for diagnostics.
6746 cd    ees0pkl=0.0D0
6747 cd    ees0pij=1.0D0
6748 cd    ees0mkl=0.0D0
6749 cd    ees0mij=1.0D0
6750 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6751 c     & 'Contacts ',i,j,
6752 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6753 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6754 c     & 'gradcorr_long'
6755 C Calculate the multi-body contribution to energy.
6756 c      ecorr=ecorr+ekont*ees
6757 C Calculate multi-body contributions to the gradient.
6758       coeffpees0pij=coeffp*ees0pij
6759       coeffmees0mij=coeffm*ees0mij
6760       coeffpees0pkl=coeffp*ees0pkl
6761       coeffmees0mkl=coeffm*ees0mkl
6762       do ll=1,3
6763 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6764         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6765      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6766      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6767         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6768      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6769      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6770 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6771         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6772      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6773      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6774         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6775      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6776      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6777         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6778      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6779      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6780         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6781         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6782         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6783      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6784      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6785         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6786         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6787 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6788       enddo
6789 c      write (iout,*)
6790 cgrad      do m=i+1,j-1
6791 cgrad        do ll=1,3
6792 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6793 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6794 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6795 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6796 cgrad        enddo
6797 cgrad      enddo
6798 cgrad      do m=k+1,l-1
6799 cgrad        do ll=1,3
6800 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6801 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6802 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6803 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6804 cgrad        enddo
6805 cgrad      enddo
6806 c      write (iout,*) "ehbcorr",ekont*ees
6807       ehbcorr=ekont*ees
6808       return
6809       end
6810 #ifdef MOMENT
6811 C---------------------------------------------------------------------------
6812       subroutine dipole(i,j,jj)
6813       implicit real*8 (a-h,o-z)
6814       include 'DIMENSIONS'
6815       include 'COMMON.IOUNITS'
6816       include 'COMMON.CHAIN'
6817       include 'COMMON.FFIELD'
6818       include 'COMMON.DERIV'
6819       include 'COMMON.INTERACT'
6820       include 'COMMON.CONTACTS'
6821       include 'COMMON.TORSION'
6822       include 'COMMON.VAR'
6823       include 'COMMON.GEO'
6824       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6825      &  auxmat(2,2)
6826       iti1 = itortyp(itype(i+1))
6827       if (j.lt.nres-1) then
6828         itj1 = itortyp(itype(j+1))
6829       else
6830         itj1=ntortyp+1
6831       endif
6832       do iii=1,2
6833         dipi(iii,1)=Ub2(iii,i)
6834         dipderi(iii)=Ub2der(iii,i)
6835         dipi(iii,2)=b1(iii,iti1)
6836         dipj(iii,1)=Ub2(iii,j)
6837         dipderj(iii)=Ub2der(iii,j)
6838         dipj(iii,2)=b1(iii,itj1)
6839       enddo
6840       kkk=0
6841       do iii=1,2
6842         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6843         do jjj=1,2
6844           kkk=kkk+1
6845           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6846         enddo
6847       enddo
6848       do kkk=1,5
6849         do lll=1,3
6850           mmm=0
6851           do iii=1,2
6852             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6853      &        auxvec(1))
6854             do jjj=1,2
6855               mmm=mmm+1
6856               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6857             enddo
6858           enddo
6859         enddo
6860       enddo
6861       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6862       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6863       do iii=1,2
6864         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6865       enddo
6866       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6867       do iii=1,2
6868         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6869       enddo
6870       return
6871       end
6872 #endif
6873 C---------------------------------------------------------------------------
6874       subroutine calc_eello(i,j,k,l,jj,kk)
6875 C
6876 C This subroutine computes matrices and vectors needed to calculate
6877 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6878 C
6879       implicit real*8 (a-h,o-z)
6880       include 'DIMENSIONS'
6881       include 'COMMON.IOUNITS'
6882       include 'COMMON.CHAIN'
6883       include 'COMMON.DERIV'
6884       include 'COMMON.INTERACT'
6885       include 'COMMON.CONTACTS'
6886       include 'COMMON.TORSION'
6887       include 'COMMON.VAR'
6888       include 'COMMON.GEO'
6889       include 'COMMON.FFIELD'
6890       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6891      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6892       logical lprn
6893       common /kutas/ lprn
6894 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6895 cd     & ' jj=',jj,' kk=',kk
6896 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6897 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
6898 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
6899       do iii=1,2
6900         do jjj=1,2
6901           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6902           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6903         enddo
6904       enddo
6905       call transpose2(aa1(1,1),aa1t(1,1))
6906       call transpose2(aa2(1,1),aa2t(1,1))
6907       do kkk=1,5
6908         do lll=1,3
6909           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6910      &      aa1tder(1,1,lll,kkk))
6911           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6912      &      aa2tder(1,1,lll,kkk))
6913         enddo
6914       enddo
6915       if (l.eq.j+1) then
6916 C parallel orientation of the two CA-CA-CA frames.
6917         if (i.gt.1) then
6918           iti=itortyp(itype(i))
6919         else
6920           iti=ntortyp+1
6921         endif
6922         itk1=itortyp(itype(k+1))
6923         itj=itortyp(itype(j))
6924         if (l.lt.nres-1) then
6925           itl1=itortyp(itype(l+1))
6926         else
6927           itl1=ntortyp+1
6928         endif
6929 C A1 kernel(j+1) A2T
6930 cd        do iii=1,2
6931 cd          write (iout,'(3f10.5,5x,3f10.5)')
6932 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6933 cd        enddo
6934         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6935      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6936      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6937 C Following matrices are needed only for 6-th order cumulants
6938         IF (wcorr6.gt.0.0d0) THEN
6939         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6940      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6941      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6942         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6943      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6944      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6945      &   ADtEAderx(1,1,1,1,1,1))
6946         lprn=.false.
6947         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6948      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6949      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6950      &   ADtEA1derx(1,1,1,1,1,1))
6951         ENDIF
6952 C End 6-th order cumulants
6953 cd        lprn=.false.
6954 cd        if (lprn) then
6955 cd        write (2,*) 'In calc_eello6'
6956 cd        do iii=1,2
6957 cd          write (2,*) 'iii=',iii
6958 cd          do kkk=1,5
6959 cd            write (2,*) 'kkk=',kkk
6960 cd            do jjj=1,2
6961 cd              write (2,'(3(2f10.5),5x)')
6962 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6963 cd            enddo
6964 cd          enddo
6965 cd        enddo
6966 cd        endif
6967         call transpose2(EUgder(1,1,k),auxmat(1,1))
6968         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6969         call transpose2(EUg(1,1,k),auxmat(1,1))
6970         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6971         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6972         do iii=1,2
6973           do kkk=1,5
6974             do lll=1,3
6975               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6976      &          EAEAderx(1,1,lll,kkk,iii,1))
6977             enddo
6978           enddo
6979         enddo
6980 C A1T kernel(i+1) A2
6981         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6982      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6983      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6984 C Following matrices are needed only for 6-th order cumulants
6985         IF (wcorr6.gt.0.0d0) THEN
6986         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6987      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6988      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6989         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6990      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6991      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6992      &   ADtEAderx(1,1,1,1,1,2))
6993         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6994      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6995      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6996      &   ADtEA1derx(1,1,1,1,1,2))
6997         ENDIF
6998 C End 6-th order cumulants
6999         call transpose2(EUgder(1,1,l),auxmat(1,1))
7000         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7001         call transpose2(EUg(1,1,l),auxmat(1,1))
7002         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7003         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7004         do iii=1,2
7005           do kkk=1,5
7006             do lll=1,3
7007               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7008      &          EAEAderx(1,1,lll,kkk,iii,2))
7009             enddo
7010           enddo
7011         enddo
7012 C AEAb1 and AEAb2
7013 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7014 C They are needed only when the fifth- or the sixth-order cumulants are
7015 C indluded.
7016         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7017         call transpose2(AEA(1,1,1),auxmat(1,1))
7018         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7019         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7020         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7021         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7022         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7023         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7024         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7025         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7026         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7027         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7028         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7029         call transpose2(AEA(1,1,2),auxmat(1,1))
7030         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7031         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7032         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7033         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7034         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7035         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7036         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7037         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7038         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7039         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7040         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7041 C Calculate the Cartesian derivatives of the vectors.
7042         do iii=1,2
7043           do kkk=1,5
7044             do lll=1,3
7045               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7046               call matvec2(auxmat(1,1),b1(1,iti),
7047      &          AEAb1derx(1,lll,kkk,iii,1,1))
7048               call matvec2(auxmat(1,1),Ub2(1,i),
7049      &          AEAb2derx(1,lll,kkk,iii,1,1))
7050               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7051      &          AEAb1derx(1,lll,kkk,iii,2,1))
7052               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7053      &          AEAb2derx(1,lll,kkk,iii,2,1))
7054               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7055               call matvec2(auxmat(1,1),b1(1,itj),
7056      &          AEAb1derx(1,lll,kkk,iii,1,2))
7057               call matvec2(auxmat(1,1),Ub2(1,j),
7058      &          AEAb2derx(1,lll,kkk,iii,1,2))
7059               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7060      &          AEAb1derx(1,lll,kkk,iii,2,2))
7061               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7062      &          AEAb2derx(1,lll,kkk,iii,2,2))
7063             enddo
7064           enddo
7065         enddo
7066         ENDIF
7067 C End vectors
7068       else
7069 C Antiparallel orientation of the two CA-CA-CA frames.
7070         if (i.gt.1) then
7071           iti=itortyp(itype(i))
7072         else
7073           iti=ntortyp+1
7074         endif
7075         itk1=itortyp(itype(k+1))
7076         itl=itortyp(itype(l))
7077         itj=itortyp(itype(j))
7078         if (j.lt.nres-1) then
7079           itj1=itortyp(itype(j+1))
7080         else
7081           itj1=ntortyp+1
7082         endif
7083 C A2 kernel(j-1)T A1T
7084         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7085      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7086      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7087 C Following matrices are needed only for 6-th order cumulants
7088         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7089      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7090         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7091      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7092      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7093         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7094      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7095      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7096      &   ADtEAderx(1,1,1,1,1,1))
7097         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7098      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7099      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7100      &   ADtEA1derx(1,1,1,1,1,1))
7101         ENDIF
7102 C End 6-th order cumulants
7103         call transpose2(EUgder(1,1,k),auxmat(1,1))
7104         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7105         call transpose2(EUg(1,1,k),auxmat(1,1))
7106         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7107         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7108         do iii=1,2
7109           do kkk=1,5
7110             do lll=1,3
7111               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7112      &          EAEAderx(1,1,lll,kkk,iii,1))
7113             enddo
7114           enddo
7115         enddo
7116 C A2T kernel(i+1)T A1
7117         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7118      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7119      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7120 C Following matrices are needed only for 6-th order cumulants
7121         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7122      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7123         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7124      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7125      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7126         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7127      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7128      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7129      &   ADtEAderx(1,1,1,1,1,2))
7130         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7131      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7132      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7133      &   ADtEA1derx(1,1,1,1,1,2))
7134         ENDIF
7135 C End 6-th order cumulants
7136         call transpose2(EUgder(1,1,j),auxmat(1,1))
7137         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7138         call transpose2(EUg(1,1,j),auxmat(1,1))
7139         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7140         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7141         do iii=1,2
7142           do kkk=1,5
7143             do lll=1,3
7144               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7145      &          EAEAderx(1,1,lll,kkk,iii,2))
7146             enddo
7147           enddo
7148         enddo
7149 C AEAb1 and AEAb2
7150 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7151 C They are needed only when the fifth- or the sixth-order cumulants are
7152 C indluded.
7153         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7154      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7155         call transpose2(AEA(1,1,1),auxmat(1,1))
7156         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7157         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7158         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7159         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7160         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7161         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7162         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7163         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7164         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7165         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7166         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7167         call transpose2(AEA(1,1,2),auxmat(1,1))
7168         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7169         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7170         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7171         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7172         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7173         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7174         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7175         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7176         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7177         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7178         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7179 C Calculate the Cartesian derivatives of the vectors.
7180         do iii=1,2
7181           do kkk=1,5
7182             do lll=1,3
7183               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7184               call matvec2(auxmat(1,1),b1(1,iti),
7185      &          AEAb1derx(1,lll,kkk,iii,1,1))
7186               call matvec2(auxmat(1,1),Ub2(1,i),
7187      &          AEAb2derx(1,lll,kkk,iii,1,1))
7188               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7189      &          AEAb1derx(1,lll,kkk,iii,2,1))
7190               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7191      &          AEAb2derx(1,lll,kkk,iii,2,1))
7192               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7193               call matvec2(auxmat(1,1),b1(1,itl),
7194      &          AEAb1derx(1,lll,kkk,iii,1,2))
7195               call matvec2(auxmat(1,1),Ub2(1,l),
7196      &          AEAb2derx(1,lll,kkk,iii,1,2))
7197               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7198      &          AEAb1derx(1,lll,kkk,iii,2,2))
7199               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7200      &          AEAb2derx(1,lll,kkk,iii,2,2))
7201             enddo
7202           enddo
7203         enddo
7204         ENDIF
7205 C End vectors
7206       endif
7207       return
7208       end
7209 C---------------------------------------------------------------------------
7210       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7211      &  KK,KKderg,AKA,AKAderg,AKAderx)
7212       implicit none
7213       integer nderg
7214       logical transp
7215       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7216      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7217      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7218       integer iii,kkk,lll
7219       integer jjj,mmm
7220       logical lprn
7221       common /kutas/ lprn
7222       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7223       do iii=1,nderg
7224         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7225      &    AKAderg(1,1,iii))
7226       enddo
7227 cd      if (lprn) write (2,*) 'In kernel'
7228       do kkk=1,5
7229 cd        if (lprn) write (2,*) 'kkk=',kkk
7230         do lll=1,3
7231           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7232      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7233 cd          if (lprn) then
7234 cd            write (2,*) 'lll=',lll
7235 cd            write (2,*) 'iii=1'
7236 cd            do jjj=1,2
7237 cd              write (2,'(3(2f10.5),5x)')
7238 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7239 cd            enddo
7240 cd          endif
7241           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7242      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7243 cd          if (lprn) then
7244 cd            write (2,*) 'lll=',lll
7245 cd            write (2,*) 'iii=2'
7246 cd            do jjj=1,2
7247 cd              write (2,'(3(2f10.5),5x)')
7248 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7249 cd            enddo
7250 cd          endif
7251         enddo
7252       enddo
7253       return
7254       end
7255 C---------------------------------------------------------------------------
7256       double precision function eello4(i,j,k,l,jj,kk)
7257       implicit real*8 (a-h,o-z)
7258       include 'DIMENSIONS'
7259       include 'COMMON.IOUNITS'
7260       include 'COMMON.CHAIN'
7261       include 'COMMON.DERIV'
7262       include 'COMMON.INTERACT'
7263       include 'COMMON.CONTACTS'
7264       include 'COMMON.TORSION'
7265       include 'COMMON.VAR'
7266       include 'COMMON.GEO'
7267       double precision pizda(2,2),ggg1(3),ggg2(3)
7268 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7269 cd        eello4=0.0d0
7270 cd        return
7271 cd      endif
7272 cd      print *,'eello4:',i,j,k,l,jj,kk
7273 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7274 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7275 cold      eij=facont_hb(jj,i)
7276 cold      ekl=facont_hb(kk,k)
7277 cold      ekont=eij*ekl
7278       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7279 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7280       gcorr_loc(k-1)=gcorr_loc(k-1)
7281      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7282       if (l.eq.j+1) then
7283         gcorr_loc(l-1)=gcorr_loc(l-1)
7284      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7285       else
7286         gcorr_loc(j-1)=gcorr_loc(j-1)
7287      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7288       endif
7289       do iii=1,2
7290         do kkk=1,5
7291           do lll=1,3
7292             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7293      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7294 cd            derx(lll,kkk,iii)=0.0d0
7295           enddo
7296         enddo
7297       enddo
7298 cd      gcorr_loc(l-1)=0.0d0
7299 cd      gcorr_loc(j-1)=0.0d0
7300 cd      gcorr_loc(k-1)=0.0d0
7301 cd      eel4=1.0d0
7302 cd      write (iout,*)'Contacts have occurred for peptide groups',
7303 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7304 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7305       if (j.lt.nres-1) then
7306         j1=j+1
7307         j2=j-1
7308       else
7309         j1=j-1
7310         j2=j-2
7311       endif
7312       if (l.lt.nres-1) then
7313         l1=l+1
7314         l2=l-1
7315       else
7316         l1=l-1
7317         l2=l-2
7318       endif
7319       do ll=1,3
7320 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7321 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7322         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7323         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7324 cgrad        ghalf=0.5d0*ggg1(ll)
7325         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7326         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7327         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7328         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7329         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7330         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7331 cgrad        ghalf=0.5d0*ggg2(ll)
7332         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7333         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7334         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7335         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7336         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7337         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7338       enddo
7339 cgrad      do m=i+1,j-1
7340 cgrad        do ll=1,3
7341 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7342 cgrad        enddo
7343 cgrad      enddo
7344 cgrad      do m=k+1,l-1
7345 cgrad        do ll=1,3
7346 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7347 cgrad        enddo
7348 cgrad      enddo
7349 cgrad      do m=i+2,j2
7350 cgrad        do ll=1,3
7351 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7352 cgrad        enddo
7353 cgrad      enddo
7354 cgrad      do m=k+2,l2
7355 cgrad        do ll=1,3
7356 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7357 cgrad        enddo
7358 cgrad      enddo
7359 cd      do iii=1,nres-3
7360 cd        write (2,*) iii,gcorr_loc(iii)
7361 cd      enddo
7362       eello4=ekont*eel4
7363 cd      write (2,*) 'ekont',ekont
7364 cd      write (iout,*) 'eello4',ekont*eel4
7365       return
7366       end
7367 C---------------------------------------------------------------------------
7368       double precision function eello5(i,j,k,l,jj,kk)
7369       implicit real*8 (a-h,o-z)
7370       include 'DIMENSIONS'
7371       include 'COMMON.IOUNITS'
7372       include 'COMMON.CHAIN'
7373       include 'COMMON.DERIV'
7374       include 'COMMON.INTERACT'
7375       include 'COMMON.CONTACTS'
7376       include 'COMMON.TORSION'
7377       include 'COMMON.VAR'
7378       include 'COMMON.GEO'
7379       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7380       double precision ggg1(3),ggg2(3)
7381 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7382 C                                                                              C
7383 C                            Parallel chains                                   C
7384 C                                                                              C
7385 C          o             o                   o             o                   C
7386 C         /l\           / \             \   / \           / \   /              C
7387 C        /   \         /   \             \ /   \         /   \ /               C
7388 C       j| o |l1       | o |              o| o |         | o |o                C
7389 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7390 C      \i/   \         /   \ /             /   \         /   \                 C
7391 C       o    k1             o                                                  C
7392 C         (I)          (II)                (III)          (IV)                 C
7393 C                                                                              C
7394 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7395 C                                                                              C
7396 C                            Antiparallel chains                               C
7397 C                                                                              C
7398 C          o             o                   o             o                   C
7399 C         /j\           / \             \   / \           / \   /              C
7400 C        /   \         /   \             \ /   \         /   \ /               C
7401 C      j1| o |l        | o |              o| o |         | o |o                C
7402 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7403 C      \i/   \         /   \ /             /   \         /   \                 C
7404 C       o     k1            o                                                  C
7405 C         (I)          (II)                (III)          (IV)                 C
7406 C                                                                              C
7407 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7408 C                                                                              C
7409 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7410 C                                                                              C
7411 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7412 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7413 cd        eello5=0.0d0
7414 cd        return
7415 cd      endif
7416 cd      write (iout,*)
7417 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7418 cd     &   ' and',k,l
7419       itk=itortyp(itype(k))
7420       itl=itortyp(itype(l))
7421       itj=itortyp(itype(j))
7422       eello5_1=0.0d0
7423       eello5_2=0.0d0
7424       eello5_3=0.0d0
7425       eello5_4=0.0d0
7426 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7427 cd     &   eel5_3_num,eel5_4_num)
7428       do iii=1,2
7429         do kkk=1,5
7430           do lll=1,3
7431             derx(lll,kkk,iii)=0.0d0
7432           enddo
7433         enddo
7434       enddo
7435 cd      eij=facont_hb(jj,i)
7436 cd      ekl=facont_hb(kk,k)
7437 cd      ekont=eij*ekl
7438 cd      write (iout,*)'Contacts have occurred for peptide groups',
7439 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7440 cd      goto 1111
7441 C Contribution from the graph I.
7442 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7443 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7444       call transpose2(EUg(1,1,k),auxmat(1,1))
7445       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7446       vv(1)=pizda(1,1)-pizda(2,2)
7447       vv(2)=pizda(1,2)+pizda(2,1)
7448       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7449      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7450 C Explicit gradient in virtual-dihedral angles.
7451       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7452      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7453      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7454       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7455       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7456       vv(1)=pizda(1,1)-pizda(2,2)
7457       vv(2)=pizda(1,2)+pizda(2,1)
7458       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7459      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7460      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7461       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7462       vv(1)=pizda(1,1)-pizda(2,2)
7463       vv(2)=pizda(1,2)+pizda(2,1)
7464       if (l.eq.j+1) then
7465         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7466      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7467      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7468       else
7469         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7470      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7471      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7472       endif
7473 C Cartesian gradient
7474       do iii=1,2
7475         do kkk=1,5
7476           do lll=1,3
7477             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7478      &        pizda(1,1))
7479             vv(1)=pizda(1,1)-pizda(2,2)
7480             vv(2)=pizda(1,2)+pizda(2,1)
7481             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7482      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7483      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7484           enddo
7485         enddo
7486       enddo
7487 c      goto 1112
7488 c1111  continue
7489 C Contribution from graph II
7490       call transpose2(EE(1,1,itk),auxmat(1,1))
7491       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7492       vv(1)=pizda(1,1)+pizda(2,2)
7493       vv(2)=pizda(2,1)-pizda(1,2)
7494       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7495      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7496 C Explicit gradient in virtual-dihedral angles.
7497       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7498      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7499       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7500       vv(1)=pizda(1,1)+pizda(2,2)
7501       vv(2)=pizda(2,1)-pizda(1,2)
7502       if (l.eq.j+1) then
7503         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7504      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7505      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7506       else
7507         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7508      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7509      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7510       endif
7511 C Cartesian gradient
7512       do iii=1,2
7513         do kkk=1,5
7514           do lll=1,3
7515             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7516      &        pizda(1,1))
7517             vv(1)=pizda(1,1)+pizda(2,2)
7518             vv(2)=pizda(2,1)-pizda(1,2)
7519             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7520      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7521      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7522           enddo
7523         enddo
7524       enddo
7525 cd      goto 1112
7526 cd1111  continue
7527       if (l.eq.j+1) then
7528 cd        goto 1110
7529 C Parallel orientation
7530 C Contribution from graph III
7531         call transpose2(EUg(1,1,l),auxmat(1,1))
7532         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7533         vv(1)=pizda(1,1)-pizda(2,2)
7534         vv(2)=pizda(1,2)+pizda(2,1)
7535         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7536      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7537 C Explicit gradient in virtual-dihedral angles.
7538         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7539      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7540      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7541         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7542         vv(1)=pizda(1,1)-pizda(2,2)
7543         vv(2)=pizda(1,2)+pizda(2,1)
7544         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7545      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7546      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7547         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7548         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7549         vv(1)=pizda(1,1)-pizda(2,2)
7550         vv(2)=pizda(1,2)+pizda(2,1)
7551         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7552      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7553      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7554 C Cartesian gradient
7555         do iii=1,2
7556           do kkk=1,5
7557             do lll=1,3
7558               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7559      &          pizda(1,1))
7560               vv(1)=pizda(1,1)-pizda(2,2)
7561               vv(2)=pizda(1,2)+pizda(2,1)
7562               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7563      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7564      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7565             enddo
7566           enddo
7567         enddo
7568 cd        goto 1112
7569 C Contribution from graph IV
7570 cd1110    continue
7571         call transpose2(EE(1,1,itl),auxmat(1,1))
7572         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7573         vv(1)=pizda(1,1)+pizda(2,2)
7574         vv(2)=pizda(2,1)-pizda(1,2)
7575         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7576      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7577 C Explicit gradient in virtual-dihedral angles.
7578         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7579      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7580         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7581         vv(1)=pizda(1,1)+pizda(2,2)
7582         vv(2)=pizda(2,1)-pizda(1,2)
7583         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7584      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7585      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7586 C Cartesian gradient
7587         do iii=1,2
7588           do kkk=1,5
7589             do lll=1,3
7590               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7591      &          pizda(1,1))
7592               vv(1)=pizda(1,1)+pizda(2,2)
7593               vv(2)=pizda(2,1)-pizda(1,2)
7594               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7595      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7596      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7597             enddo
7598           enddo
7599         enddo
7600       else
7601 C Antiparallel orientation
7602 C Contribution from graph III
7603 c        goto 1110
7604         call transpose2(EUg(1,1,j),auxmat(1,1))
7605         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7606         vv(1)=pizda(1,1)-pizda(2,2)
7607         vv(2)=pizda(1,2)+pizda(2,1)
7608         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7609      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7610 C Explicit gradient in virtual-dihedral angles.
7611         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7612      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7613      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7614         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7615         vv(1)=pizda(1,1)-pizda(2,2)
7616         vv(2)=pizda(1,2)+pizda(2,1)
7617         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7618      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7619      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7620         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7621         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7622         vv(1)=pizda(1,1)-pizda(2,2)
7623         vv(2)=pizda(1,2)+pizda(2,1)
7624         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7625      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7626      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7627 C Cartesian gradient
7628         do iii=1,2
7629           do kkk=1,5
7630             do lll=1,3
7631               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7632      &          pizda(1,1))
7633               vv(1)=pizda(1,1)-pizda(2,2)
7634               vv(2)=pizda(1,2)+pizda(2,1)
7635               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7636      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7637      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7638             enddo
7639           enddo
7640         enddo
7641 cd        goto 1112
7642 C Contribution from graph IV
7643 1110    continue
7644         call transpose2(EE(1,1,itj),auxmat(1,1))
7645         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7646         vv(1)=pizda(1,1)+pizda(2,2)
7647         vv(2)=pizda(2,1)-pizda(1,2)
7648         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7649      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7650 C Explicit gradient in virtual-dihedral angles.
7651         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7652      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7653         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7654         vv(1)=pizda(1,1)+pizda(2,2)
7655         vv(2)=pizda(2,1)-pizda(1,2)
7656         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7657      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7658      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7659 C Cartesian gradient
7660         do iii=1,2
7661           do kkk=1,5
7662             do lll=1,3
7663               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7664      &          pizda(1,1))
7665               vv(1)=pizda(1,1)+pizda(2,2)
7666               vv(2)=pizda(2,1)-pizda(1,2)
7667               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7668      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7669      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7670             enddo
7671           enddo
7672         enddo
7673       endif
7674 1112  continue
7675       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7676 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7677 cd        write (2,*) 'ijkl',i,j,k,l
7678 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7679 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7680 cd      endif
7681 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7682 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7683 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7684 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7685       if (j.lt.nres-1) then
7686         j1=j+1
7687         j2=j-1
7688       else
7689         j1=j-1
7690         j2=j-2
7691       endif
7692       if (l.lt.nres-1) then
7693         l1=l+1
7694         l2=l-1
7695       else
7696         l1=l-1
7697         l2=l-2
7698       endif
7699 cd      eij=1.0d0
7700 cd      ekl=1.0d0
7701 cd      ekont=1.0d0
7702 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7703 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7704 C        summed up outside the subrouine as for the other subroutines
7705 C        handling long-range interactions. The old code is commented out
7706 C        with "cgrad" to keep track of changes.
7707       do ll=1,3
7708 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7709 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7710         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7711         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7712 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7713 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7714 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7715 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7716 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7717 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7718 c     &   gradcorr5ij,
7719 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7720 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7721 cgrad        ghalf=0.5d0*ggg1(ll)
7722 cd        ghalf=0.0d0
7723         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7724         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7725         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7726         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7727         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7728         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7729 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7730 cgrad        ghalf=0.5d0*ggg2(ll)
7731 cd        ghalf=0.0d0
7732         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7733         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7734         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7735         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7736         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7737         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7738       enddo
7739 cd      goto 1112
7740 cgrad      do m=i+1,j-1
7741 cgrad        do ll=1,3
7742 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7743 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7744 cgrad        enddo
7745 cgrad      enddo
7746 cgrad      do m=k+1,l-1
7747 cgrad        do ll=1,3
7748 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7749 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7750 cgrad        enddo
7751 cgrad      enddo
7752 c1112  continue
7753 cgrad      do m=i+2,j2
7754 cgrad        do ll=1,3
7755 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7756 cgrad        enddo
7757 cgrad      enddo
7758 cgrad      do m=k+2,l2
7759 cgrad        do ll=1,3
7760 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7761 cgrad        enddo
7762 cgrad      enddo
7763 cd      do iii=1,nres-3
7764 cd        write (2,*) iii,g_corr5_loc(iii)
7765 cd      enddo
7766       eello5=ekont*eel5
7767 cd      write (2,*) 'ekont',ekont
7768 cd      write (iout,*) 'eello5',ekont*eel5
7769       return
7770       end
7771 c--------------------------------------------------------------------------
7772       double precision function eello6(i,j,k,l,jj,kk)
7773       implicit real*8 (a-h,o-z)
7774       include 'DIMENSIONS'
7775       include 'COMMON.IOUNITS'
7776       include 'COMMON.CHAIN'
7777       include 'COMMON.DERIV'
7778       include 'COMMON.INTERACT'
7779       include 'COMMON.CONTACTS'
7780       include 'COMMON.TORSION'
7781       include 'COMMON.VAR'
7782       include 'COMMON.GEO'
7783       include 'COMMON.FFIELD'
7784       double precision ggg1(3),ggg2(3)
7785 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7786 cd        eello6=0.0d0
7787 cd        return
7788 cd      endif
7789 cd      write (iout,*)
7790 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7791 cd     &   ' and',k,l
7792       eello6_1=0.0d0
7793       eello6_2=0.0d0
7794       eello6_3=0.0d0
7795       eello6_4=0.0d0
7796       eello6_5=0.0d0
7797       eello6_6=0.0d0
7798 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7799 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7800       do iii=1,2
7801         do kkk=1,5
7802           do lll=1,3
7803             derx(lll,kkk,iii)=0.0d0
7804           enddo
7805         enddo
7806       enddo
7807 cd      eij=facont_hb(jj,i)
7808 cd      ekl=facont_hb(kk,k)
7809 cd      ekont=eij*ekl
7810 cd      eij=1.0d0
7811 cd      ekl=1.0d0
7812 cd      ekont=1.0d0
7813       if (l.eq.j+1) then
7814         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7815         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7816         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7817         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7818         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7819         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7820       else
7821         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7822         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7823         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7824         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7825         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7826           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7827         else
7828           eello6_5=0.0d0
7829         endif
7830         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7831       endif
7832 C If turn contributions are considered, they will be handled separately.
7833       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7834 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
7835 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
7836 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
7837 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
7838 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
7839 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
7840 cd      goto 1112
7841       if (j.lt.nres-1) then
7842         j1=j+1
7843         j2=j-1
7844       else
7845         j1=j-1
7846         j2=j-2
7847       endif
7848       if (l.lt.nres-1) then
7849         l1=l+1
7850         l2=l-1
7851       else
7852         l1=l-1
7853         l2=l-2
7854       endif
7855       do ll=1,3
7856 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
7857 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
7858 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7859 cgrad        ghalf=0.5d0*ggg1(ll)
7860 cd        ghalf=0.0d0
7861         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
7862         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
7863         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
7864         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7865         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
7866         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7867         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
7868         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
7869 cgrad        ghalf=0.5d0*ggg2(ll)
7870 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7871 cd        ghalf=0.0d0
7872         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
7873         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7874         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
7875         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7876         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
7877         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
7878       enddo
7879 cd      goto 1112
7880 cgrad      do m=i+1,j-1
7881 cgrad        do ll=1,3
7882 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7883 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7884 cgrad        enddo
7885 cgrad      enddo
7886 cgrad      do m=k+1,l-1
7887 cgrad        do ll=1,3
7888 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7889 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7890 cgrad        enddo
7891 cgrad      enddo
7892 cgrad1112  continue
7893 cgrad      do m=i+2,j2
7894 cgrad        do ll=1,3
7895 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7896 cgrad        enddo
7897 cgrad      enddo
7898 cgrad      do m=k+2,l2
7899 cgrad        do ll=1,3
7900 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7901 cgrad        enddo
7902 cgrad      enddo
7903 cd      do iii=1,nres-3
7904 cd        write (2,*) iii,g_corr6_loc(iii)
7905 cd      enddo
7906       eello6=ekont*eel6
7907 cd      write (2,*) 'ekont',ekont
7908 cd      write (iout,*) 'eello6',ekont*eel6
7909       return
7910       end
7911 c--------------------------------------------------------------------------
7912       double precision function eello6_graph1(i,j,k,l,imat,swap)
7913       implicit real*8 (a-h,o-z)
7914       include 'DIMENSIONS'
7915       include 'COMMON.IOUNITS'
7916       include 'COMMON.CHAIN'
7917       include 'COMMON.DERIV'
7918       include 'COMMON.INTERACT'
7919       include 'COMMON.CONTACTS'
7920       include 'COMMON.TORSION'
7921       include 'COMMON.VAR'
7922       include 'COMMON.GEO'
7923       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7924       logical swap
7925       logical lprn
7926       common /kutas/ lprn
7927 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7928 C
7929 C      Parallel       Antiparallel
7930 C
7931 C          o             o
7932 C         /l\           /j\
7933 C        /   \         /   \
7934 C       /| o |         | o |\
7935 C     \ j|/k\|  /   \  |/k\|l /
7936 C      \ /   \ /     \ /   \ /
7937 C       o     o       o     o
7938 C       i             i
7939 C
7940 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7941       itk=itortyp(itype(k))
7942       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7943       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7944       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7945       call transpose2(EUgC(1,1,k),auxmat(1,1))
7946       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7947       vv1(1)=pizda1(1,1)-pizda1(2,2)
7948       vv1(2)=pizda1(1,2)+pizda1(2,1)
7949       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7950       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7951       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7952       s5=scalar2(vv(1),Dtobr2(1,i))
7953 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7954       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7955       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7956      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7957      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7958      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7959      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7960      & +scalar2(vv(1),Dtobr2der(1,i)))
7961       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7962       vv1(1)=pizda1(1,1)-pizda1(2,2)
7963       vv1(2)=pizda1(1,2)+pizda1(2,1)
7964       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7965       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7966       if (l.eq.j+1) then
7967         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7968      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7969      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7970      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7971      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7972       else
7973         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7974      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7975      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7976      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7977      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7978       endif
7979       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7980       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7981       vv1(1)=pizda1(1,1)-pizda1(2,2)
7982       vv1(2)=pizda1(1,2)+pizda1(2,1)
7983       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7984      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7985      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7986      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7987       do iii=1,2
7988         if (swap) then
7989           ind=3-iii
7990         else
7991           ind=iii
7992         endif
7993         do kkk=1,5
7994           do lll=1,3
7995             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7996             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7997             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7998             call transpose2(EUgC(1,1,k),auxmat(1,1))
7999             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8000      &        pizda1(1,1))
8001             vv1(1)=pizda1(1,1)-pizda1(2,2)
8002             vv1(2)=pizda1(1,2)+pizda1(2,1)
8003             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8004             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8005      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8006             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8007      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8008             s5=scalar2(vv(1),Dtobr2(1,i))
8009             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8010           enddo
8011         enddo
8012       enddo
8013       return
8014       end
8015 c----------------------------------------------------------------------------
8016       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8017       implicit real*8 (a-h,o-z)
8018       include 'DIMENSIONS'
8019       include 'COMMON.IOUNITS'
8020       include 'COMMON.CHAIN'
8021       include 'COMMON.DERIV'
8022       include 'COMMON.INTERACT'
8023       include 'COMMON.CONTACTS'
8024       include 'COMMON.TORSION'
8025       include 'COMMON.VAR'
8026       include 'COMMON.GEO'
8027       logical swap
8028       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8029      & auxvec1(2),auxvec2(1),auxmat1(2,2)
8030       logical lprn
8031       common /kutas/ lprn
8032 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8033 C
8034 C      Parallel       Antiparallel
8035 C
8036 C          o             o
8037 C     \   /l\           /j\   /
8038 C      \ /   \         /   \ /
8039 C       o| o |         | o |o
8040 C     \ j|/k\|      \  |/k\|l
8041 C      \ /   \       \ /   \
8042 C       o             o
8043 C       i             i
8044 C
8045 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8046 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8047 C AL 7/4/01 s1 would occur in the sixth-order moment,
8048 C           but not in a cluster cumulant
8049 #ifdef MOMENT
8050       s1=dip(1,jj,i)*dip(1,kk,k)
8051 #endif
8052       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8053       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8054       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8055       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8056       call transpose2(EUg(1,1,k),auxmat(1,1))
8057       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8058       vv(1)=pizda(1,1)-pizda(2,2)
8059       vv(2)=pizda(1,2)+pizda(2,1)
8060       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8061 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8062 #ifdef MOMENT
8063       eello6_graph2=-(s1+s2+s3+s4)
8064 #else
8065       eello6_graph2=-(s2+s3+s4)
8066 #endif
8067 c      eello6_graph2=-s3
8068 C Derivatives in gamma(i-1)
8069       if (i.gt.1) then
8070 #ifdef MOMENT
8071         s1=dipderg(1,jj,i)*dip(1,kk,k)
8072 #endif
8073         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8074         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8075         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8076         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8077 #ifdef MOMENT
8078         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8079 #else
8080         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8081 #endif
8082 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8083       endif
8084 C Derivatives in gamma(k-1)
8085 #ifdef MOMENT
8086       s1=dip(1,jj,i)*dipderg(1,kk,k)
8087 #endif
8088       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8089       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8090       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8091       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8092       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8093       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8094       vv(1)=pizda(1,1)-pizda(2,2)
8095       vv(2)=pizda(1,2)+pizda(2,1)
8096       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8097 #ifdef MOMENT
8098       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8099 #else
8100       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8101 #endif
8102 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8103 C Derivatives in gamma(j-1) or gamma(l-1)
8104       if (j.gt.1) then
8105 #ifdef MOMENT
8106         s1=dipderg(3,jj,i)*dip(1,kk,k)
8107 #endif
8108         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8109         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8110         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8111         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8112         vv(1)=pizda(1,1)-pizda(2,2)
8113         vv(2)=pizda(1,2)+pizda(2,1)
8114         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8115 #ifdef MOMENT
8116         if (swap) then
8117           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8118         else
8119           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8120         endif
8121 #endif
8122         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8123 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8124       endif
8125 C Derivatives in gamma(l-1) or gamma(j-1)
8126       if (l.gt.1) then
8127 #ifdef MOMENT
8128         s1=dip(1,jj,i)*dipderg(3,kk,k)
8129 #endif
8130         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8131         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8132         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8133         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8134         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8135         vv(1)=pizda(1,1)-pizda(2,2)
8136         vv(2)=pizda(1,2)+pizda(2,1)
8137         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8138 #ifdef MOMENT
8139         if (swap) then
8140           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8141         else
8142           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8143         endif
8144 #endif
8145         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8146 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8147       endif
8148 C Cartesian derivatives.
8149       if (lprn) then
8150         write (2,*) 'In eello6_graph2'
8151         do iii=1,2
8152           write (2,*) 'iii=',iii
8153           do kkk=1,5
8154             write (2,*) 'kkk=',kkk
8155             do jjj=1,2
8156               write (2,'(3(2f10.5),5x)')
8157      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8158             enddo
8159           enddo
8160         enddo
8161       endif
8162       do iii=1,2
8163         do kkk=1,5
8164           do lll=1,3
8165 #ifdef MOMENT
8166             if (iii.eq.1) then
8167               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8168             else
8169               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8170             endif
8171 #endif
8172             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8173      &        auxvec(1))
8174             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8175             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8176      &        auxvec(1))
8177             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8178             call transpose2(EUg(1,1,k),auxmat(1,1))
8179             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8180      &        pizda(1,1))
8181             vv(1)=pizda(1,1)-pizda(2,2)
8182             vv(2)=pizda(1,2)+pizda(2,1)
8183             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8184 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8185 #ifdef MOMENT
8186             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8187 #else
8188             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8189 #endif
8190             if (swap) then
8191               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8192             else
8193               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8194             endif
8195           enddo
8196         enddo
8197       enddo
8198       return
8199       end
8200 c----------------------------------------------------------------------------
8201       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8202       implicit real*8 (a-h,o-z)
8203       include 'DIMENSIONS'
8204       include 'COMMON.IOUNITS'
8205       include 'COMMON.CHAIN'
8206       include 'COMMON.DERIV'
8207       include 'COMMON.INTERACT'
8208       include 'COMMON.CONTACTS'
8209       include 'COMMON.TORSION'
8210       include 'COMMON.VAR'
8211       include 'COMMON.GEO'
8212       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8213       logical swap
8214 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8215 C
8216 C      Parallel       Antiparallel
8217 C
8218 C          o             o
8219 C         /l\   /   \   /j\
8220 C        /   \ /     \ /   \
8221 C       /| o |o       o| o |\
8222 C       j|/k\|  /      |/k\|l /
8223 C        /   \ /       /   \ /
8224 C       /     o       /     o
8225 C       i             i
8226 C
8227 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8228 C
8229 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8230 C           energy moment and not to the cluster cumulant.
8231       iti=itortyp(itype(i))
8232       if (j.lt.nres-1) then
8233         itj1=itortyp(itype(j+1))
8234       else
8235         itj1=ntortyp+1
8236       endif
8237       itk=itortyp(itype(k))
8238       itk1=itortyp(itype(k+1))
8239       if (l.lt.nres-1) then
8240         itl1=itortyp(itype(l+1))
8241       else
8242         itl1=ntortyp+1
8243       endif
8244 #ifdef MOMENT
8245       s1=dip(4,jj,i)*dip(4,kk,k)
8246 #endif
8247       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8248       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8249       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8250       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8251       call transpose2(EE(1,1,itk),auxmat(1,1))
8252       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8253       vv(1)=pizda(1,1)+pizda(2,2)
8254       vv(2)=pizda(2,1)-pizda(1,2)
8255       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8256 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8257 cd     & "sum",-(s2+s3+s4)
8258 #ifdef MOMENT
8259       eello6_graph3=-(s1+s2+s3+s4)
8260 #else
8261       eello6_graph3=-(s2+s3+s4)
8262 #endif
8263 c      eello6_graph3=-s4
8264 C Derivatives in gamma(k-1)
8265       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8266       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8267       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8268       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8269 C Derivatives in gamma(l-1)
8270       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8271       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8272       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8273       vv(1)=pizda(1,1)+pizda(2,2)
8274       vv(2)=pizda(2,1)-pizda(1,2)
8275       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8276       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8277 C Cartesian derivatives.
8278       do iii=1,2
8279         do kkk=1,5
8280           do lll=1,3
8281 #ifdef MOMENT
8282             if (iii.eq.1) then
8283               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8284             else
8285               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8286             endif
8287 #endif
8288             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8289      &        auxvec(1))
8290             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8291             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8292      &        auxvec(1))
8293             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8294             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8295      &        pizda(1,1))
8296             vv(1)=pizda(1,1)+pizda(2,2)
8297             vv(2)=pizda(2,1)-pizda(1,2)
8298             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8299 #ifdef MOMENT
8300             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8301 #else
8302             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8303 #endif
8304             if (swap) then
8305               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8306             else
8307               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8308             endif
8309 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8310           enddo
8311         enddo
8312       enddo
8313       return
8314       end
8315 c----------------------------------------------------------------------------
8316       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8317       implicit real*8 (a-h,o-z)
8318       include 'DIMENSIONS'
8319       include 'COMMON.IOUNITS'
8320       include 'COMMON.CHAIN'
8321       include 'COMMON.DERIV'
8322       include 'COMMON.INTERACT'
8323       include 'COMMON.CONTACTS'
8324       include 'COMMON.TORSION'
8325       include 'COMMON.VAR'
8326       include 'COMMON.GEO'
8327       include 'COMMON.FFIELD'
8328       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8329      & auxvec1(2),auxmat1(2,2)
8330       logical swap
8331 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8332 C
8333 C      Parallel       Antiparallel
8334 C
8335 C          o             o
8336 C         /l\   /   \   /j\
8337 C        /   \ /     \ /   \
8338 C       /| o |o       o| o |\
8339 C     \ j|/k\|      \  |/k\|l
8340 C      \ /   \       \ /   \
8341 C       o     \       o     \
8342 C       i             i
8343 C
8344 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8345 C
8346 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8347 C           energy moment and not to the cluster cumulant.
8348 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8349       iti=itortyp(itype(i))
8350       itj=itortyp(itype(j))
8351       if (j.lt.nres-1) then
8352         itj1=itortyp(itype(j+1))
8353       else
8354         itj1=ntortyp+1
8355       endif
8356       itk=itortyp(itype(k))
8357       if (k.lt.nres-1) then
8358         itk1=itortyp(itype(k+1))
8359       else
8360         itk1=ntortyp+1
8361       endif
8362       itl=itortyp(itype(l))
8363       if (l.lt.nres-1) then
8364         itl1=itortyp(itype(l+1))
8365       else
8366         itl1=ntortyp+1
8367       endif
8368 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8369 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8370 cd     & ' itl',itl,' itl1',itl1
8371 #ifdef MOMENT
8372       if (imat.eq.1) then
8373         s1=dip(3,jj,i)*dip(3,kk,k)
8374       else
8375         s1=dip(2,jj,j)*dip(2,kk,l)
8376       endif
8377 #endif
8378       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8379       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8380       if (j.eq.l+1) then
8381         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8382         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8383       else
8384         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8385         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8386       endif
8387       call transpose2(EUg(1,1,k),auxmat(1,1))
8388       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8389       vv(1)=pizda(1,1)-pizda(2,2)
8390       vv(2)=pizda(2,1)+pizda(1,2)
8391       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8392 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8393 #ifdef MOMENT
8394       eello6_graph4=-(s1+s2+s3+s4)
8395 #else
8396       eello6_graph4=-(s2+s3+s4)
8397 #endif
8398 C Derivatives in gamma(i-1)
8399       if (i.gt.1) then
8400 #ifdef MOMENT
8401         if (imat.eq.1) then
8402           s1=dipderg(2,jj,i)*dip(3,kk,k)
8403         else
8404           s1=dipderg(4,jj,j)*dip(2,kk,l)
8405         endif
8406 #endif
8407         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8408         if (j.eq.l+1) then
8409           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8410           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8411         else
8412           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8413           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8414         endif
8415         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8416         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8417 cd          write (2,*) 'turn6 derivatives'
8418 #ifdef MOMENT
8419           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8420 #else
8421           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8422 #endif
8423         else
8424 #ifdef MOMENT
8425           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8426 #else
8427           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8428 #endif
8429         endif
8430       endif
8431 C Derivatives in gamma(k-1)
8432 #ifdef MOMENT
8433       if (imat.eq.1) then
8434         s1=dip(3,jj,i)*dipderg(2,kk,k)
8435       else
8436         s1=dip(2,jj,j)*dipderg(4,kk,l)
8437       endif
8438 #endif
8439       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8440       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8441       if (j.eq.l+1) then
8442         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8443         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8444       else
8445         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8446         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8447       endif
8448       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8449       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8450       vv(1)=pizda(1,1)-pizda(2,2)
8451       vv(2)=pizda(2,1)+pizda(1,2)
8452       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8453       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8454 #ifdef MOMENT
8455         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8456 #else
8457         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8458 #endif
8459       else
8460 #ifdef MOMENT
8461         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8462 #else
8463         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8464 #endif
8465       endif
8466 C Derivatives in gamma(j-1) or gamma(l-1)
8467       if (l.eq.j+1 .and. l.gt.1) then
8468         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8469         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8470         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8471         vv(1)=pizda(1,1)-pizda(2,2)
8472         vv(2)=pizda(2,1)+pizda(1,2)
8473         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8474         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8475       else if (j.gt.1) then
8476         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8477         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8478         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8479         vv(1)=pizda(1,1)-pizda(2,2)
8480         vv(2)=pizda(2,1)+pizda(1,2)
8481         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8482         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8483           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8484         else
8485           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8486         endif
8487       endif
8488 C Cartesian derivatives.
8489       do iii=1,2
8490         do kkk=1,5
8491           do lll=1,3
8492 #ifdef MOMENT
8493             if (iii.eq.1) then
8494               if (imat.eq.1) then
8495                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8496               else
8497                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8498               endif
8499             else
8500               if (imat.eq.1) then
8501                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8502               else
8503                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8504               endif
8505             endif
8506 #endif
8507             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8508      &        auxvec(1))
8509             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8510             if (j.eq.l+1) then
8511               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8512      &          b1(1,itj1),auxvec(1))
8513               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8514             else
8515               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8516      &          b1(1,itl1),auxvec(1))
8517               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8518             endif
8519             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8520      &        pizda(1,1))
8521             vv(1)=pizda(1,1)-pizda(2,2)
8522             vv(2)=pizda(2,1)+pizda(1,2)
8523             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8524             if (swap) then
8525               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8526 #ifdef MOMENT
8527                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8528      &             -(s1+s2+s4)
8529 #else
8530                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8531      &             -(s2+s4)
8532 #endif
8533                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8534               else
8535 #ifdef MOMENT
8536                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8537 #else
8538                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8539 #endif
8540                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8541               endif
8542             else
8543 #ifdef MOMENT
8544               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8545 #else
8546               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8547 #endif
8548               if (l.eq.j+1) then
8549                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8550               else
8551                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8552               endif
8553             endif
8554           enddo
8555         enddo
8556       enddo
8557       return
8558       end
8559 c----------------------------------------------------------------------------
8560       double precision function eello_turn6(i,jj,kk)
8561       implicit real*8 (a-h,o-z)
8562       include 'DIMENSIONS'
8563       include 'COMMON.IOUNITS'
8564       include 'COMMON.CHAIN'
8565       include 'COMMON.DERIV'
8566       include 'COMMON.INTERACT'
8567       include 'COMMON.CONTACTS'
8568       include 'COMMON.TORSION'
8569       include 'COMMON.VAR'
8570       include 'COMMON.GEO'
8571       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8572      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8573      &  ggg1(3),ggg2(3)
8574       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8575      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8576 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8577 C           the respective energy moment and not to the cluster cumulant.
8578       s1=0.0d0
8579       s8=0.0d0
8580       s13=0.0d0
8581 c
8582       eello_turn6=0.0d0
8583       j=i+4
8584       k=i+1
8585       l=i+3
8586       iti=itortyp(itype(i))
8587       itk=itortyp(itype(k))
8588       itk1=itortyp(itype(k+1))
8589       itl=itortyp(itype(l))
8590       itj=itortyp(itype(j))
8591 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8592 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8593 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8594 cd        eello6=0.0d0
8595 cd        return
8596 cd      endif
8597 cd      write (iout,*)
8598 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8599 cd     &   ' and',k,l
8600 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8601       do iii=1,2
8602         do kkk=1,5
8603           do lll=1,3
8604             derx_turn(lll,kkk,iii)=0.0d0
8605           enddo
8606         enddo
8607       enddo
8608 cd      eij=1.0d0
8609 cd      ekl=1.0d0
8610 cd      ekont=1.0d0
8611       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8612 cd      eello6_5=0.0d0
8613 cd      write (2,*) 'eello6_5',eello6_5
8614 #ifdef MOMENT
8615       call transpose2(AEA(1,1,1),auxmat(1,1))
8616       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8617       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8618       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8619 #endif
8620       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8621       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8622       s2 = scalar2(b1(1,itk),vtemp1(1))
8623 #ifdef MOMENT
8624       call transpose2(AEA(1,1,2),atemp(1,1))
8625       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8626       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8627       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8628 #endif
8629       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8630       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8631       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8632 #ifdef MOMENT
8633       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8634       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8635       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8636       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8637       ss13 = scalar2(b1(1,itk),vtemp4(1))
8638       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8639 #endif
8640 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8641 c      s1=0.0d0
8642 c      s2=0.0d0
8643 c      s8=0.0d0
8644 c      s12=0.0d0
8645 c      s13=0.0d0
8646       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8647 C Derivatives in gamma(i+2)
8648       s1d =0.0d0
8649       s8d =0.0d0
8650 #ifdef MOMENT
8651       call transpose2(AEA(1,1,1),auxmatd(1,1))
8652       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8653       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8654       call transpose2(AEAderg(1,1,2),atempd(1,1))
8655       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8656       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8657 #endif
8658       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8659       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8660       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8661 c      s1d=0.0d0
8662 c      s2d=0.0d0
8663 c      s8d=0.0d0
8664 c      s12d=0.0d0
8665 c      s13d=0.0d0
8666       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8667 C Derivatives in gamma(i+3)
8668 #ifdef MOMENT
8669       call transpose2(AEA(1,1,1),auxmatd(1,1))
8670       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8671       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8672       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8673 #endif
8674       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8675       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8676       s2d = scalar2(b1(1,itk),vtemp1d(1))
8677 #ifdef MOMENT
8678       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8679       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8680 #endif
8681       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8682 #ifdef MOMENT
8683       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8684       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8685       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8686 #endif
8687 c      s1d=0.0d0
8688 c      s2d=0.0d0
8689 c      s8d=0.0d0
8690 c      s12d=0.0d0
8691 c      s13d=0.0d0
8692 #ifdef MOMENT
8693       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8694      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8695 #else
8696       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8697      &               -0.5d0*ekont*(s2d+s12d)
8698 #endif
8699 C Derivatives in gamma(i+4)
8700       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8701       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8702       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8703 #ifdef MOMENT
8704       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8705       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8706       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8707 #endif
8708 c      s1d=0.0d0
8709 c      s2d=0.0d0
8710 c      s8d=0.0d0
8711 C      s12d=0.0d0
8712 c      s13d=0.0d0
8713 #ifdef MOMENT
8714       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8715 #else
8716       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8717 #endif
8718 C Derivatives in gamma(i+5)
8719 #ifdef MOMENT
8720       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8721       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8722       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8723 #endif
8724       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8725       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8726       s2d = scalar2(b1(1,itk),vtemp1d(1))
8727 #ifdef MOMENT
8728       call transpose2(AEA(1,1,2),atempd(1,1))
8729       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8730       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8731 #endif
8732       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8733       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8734 #ifdef MOMENT
8735       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8736       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8737       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8738 #endif
8739 c      s1d=0.0d0
8740 c      s2d=0.0d0
8741 c      s8d=0.0d0
8742 c      s12d=0.0d0
8743 c      s13d=0.0d0
8744 #ifdef MOMENT
8745       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8746      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8747 #else
8748       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8749      &               -0.5d0*ekont*(s2d+s12d)
8750 #endif
8751 C Cartesian derivatives
8752       do iii=1,2
8753         do kkk=1,5
8754           do lll=1,3
8755 #ifdef MOMENT
8756             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8757             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8758             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8759 #endif
8760             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8761             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8762      &          vtemp1d(1))
8763             s2d = scalar2(b1(1,itk),vtemp1d(1))
8764 #ifdef MOMENT
8765             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8766             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8767             s8d = -(atempd(1,1)+atempd(2,2))*
8768      &           scalar2(cc(1,1,itl),vtemp2(1))
8769 #endif
8770             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8771      &           auxmatd(1,1))
8772             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8773             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8774 c      s1d=0.0d0
8775 c      s2d=0.0d0
8776 c      s8d=0.0d0
8777 c      s12d=0.0d0
8778 c      s13d=0.0d0
8779 #ifdef MOMENT
8780             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8781      &        - 0.5d0*(s1d+s2d)
8782 #else
8783             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8784      &        - 0.5d0*s2d
8785 #endif
8786 #ifdef MOMENT
8787             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8788      &        - 0.5d0*(s8d+s12d)
8789 #else
8790             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8791      &        - 0.5d0*s12d
8792 #endif
8793           enddo
8794         enddo
8795       enddo
8796 #ifdef MOMENT
8797       do kkk=1,5
8798         do lll=1,3
8799           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8800      &      achuj_tempd(1,1))
8801           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8802           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8803           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8804           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8805           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8806      &      vtemp4d(1))
8807           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8808           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8809           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8810         enddo
8811       enddo
8812 #endif
8813 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8814 cd     &  16*eel_turn6_num
8815 cd      goto 1112
8816       if (j.lt.nres-1) then
8817         j1=j+1
8818         j2=j-1
8819       else
8820         j1=j-1
8821         j2=j-2
8822       endif
8823       if (l.lt.nres-1) then
8824         l1=l+1
8825         l2=l-1
8826       else
8827         l1=l-1
8828         l2=l-2
8829       endif
8830       do ll=1,3
8831 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
8832 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
8833 cgrad        ghalf=0.5d0*ggg1(ll)
8834 cd        ghalf=0.0d0
8835         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
8836         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
8837         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
8838      &    +ekont*derx_turn(ll,2,1)
8839         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8840         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
8841      &    +ekont*derx_turn(ll,4,1)
8842         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8843         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
8844         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
8845 cgrad        ghalf=0.5d0*ggg2(ll)
8846 cd        ghalf=0.0d0
8847         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
8848      &    +ekont*derx_turn(ll,2,2)
8849         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8850         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
8851      &    +ekont*derx_turn(ll,4,2)
8852         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8853         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
8854         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
8855       enddo
8856 cd      goto 1112
8857 cgrad      do m=i+1,j-1
8858 cgrad        do ll=1,3
8859 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8860 cgrad        enddo
8861 cgrad      enddo
8862 cgrad      do m=k+1,l-1
8863 cgrad        do ll=1,3
8864 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8865 cgrad        enddo
8866 cgrad      enddo
8867 cgrad1112  continue
8868 cgrad      do m=i+2,j2
8869 cgrad        do ll=1,3
8870 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8871 cgrad        enddo
8872 cgrad      enddo
8873 cgrad      do m=k+2,l2
8874 cgrad        do ll=1,3
8875 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8876 cgrad        enddo
8877 cgrad      enddo
8878 cd      do iii=1,nres-3
8879 cd        write (2,*) iii,g_corr6_loc(iii)
8880 cd      enddo
8881       eello_turn6=ekont*eel_turn6
8882 cd      write (2,*) 'ekont',ekont
8883 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8884       return
8885       end
8886
8887 C-----------------------------------------------------------------------------
8888       double precision function scalar(u,v)
8889 !DIR$ INLINEALWAYS scalar
8890 #ifndef OSF
8891 cDEC$ ATTRIBUTES FORCEINLINE::scalar
8892 #endif
8893       implicit none
8894       double precision u(3),v(3)
8895 cd      double precision sc
8896 cd      integer i
8897 cd      sc=0.0d0
8898 cd      do i=1,3
8899 cd        sc=sc+u(i)*v(i)
8900 cd      enddo
8901 cd      scalar=sc
8902
8903       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
8904       return
8905       end
8906 crc-------------------------------------------------
8907       SUBROUTINE MATVEC2(A1,V1,V2)
8908 !DIR$ INLINEALWAYS MATVEC2
8909 #ifndef OSF
8910 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
8911 #endif
8912       implicit real*8 (a-h,o-z)
8913       include 'DIMENSIONS'
8914       DIMENSION A1(2,2),V1(2),V2(2)
8915 c      DO 1 I=1,2
8916 c        VI=0.0
8917 c        DO 3 K=1,2
8918 c    3     VI=VI+A1(I,K)*V1(K)
8919 c        Vaux(I)=VI
8920 c    1 CONTINUE
8921
8922       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8923       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8924
8925       v2(1)=vaux1
8926       v2(2)=vaux2
8927       END
8928 C---------------------------------------
8929       SUBROUTINE MATMAT2(A1,A2,A3)
8930 #ifndef OSF
8931 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
8932 #endif
8933       implicit real*8 (a-h,o-z)
8934       include 'DIMENSIONS'
8935       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8936 c      DIMENSION AI3(2,2)
8937 c        DO  J=1,2
8938 c          A3IJ=0.0
8939 c          DO K=1,2
8940 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8941 c          enddo
8942 c          A3(I,J)=A3IJ
8943 c       enddo
8944 c      enddo
8945
8946       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8947       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8948       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8949       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8950
8951       A3(1,1)=AI3_11
8952       A3(2,1)=AI3_21
8953       A3(1,2)=AI3_12
8954       A3(2,2)=AI3_22
8955       END
8956
8957 c-------------------------------------------------------------------------
8958       double precision function scalar2(u,v)
8959 !DIR$ INLINEALWAYS scalar2
8960       implicit none
8961       double precision u(2),v(2)
8962       double precision sc
8963       integer i
8964       scalar2=u(1)*v(1)+u(2)*v(2)
8965       return
8966       end
8967
8968 C-----------------------------------------------------------------------------
8969
8970       subroutine transpose2(a,at)
8971 !DIR$ INLINEALWAYS transpose2
8972 #ifndef OSF
8973 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
8974 #endif
8975       implicit none
8976       double precision a(2,2),at(2,2)
8977       at(1,1)=a(1,1)
8978       at(1,2)=a(2,1)
8979       at(2,1)=a(1,2)
8980       at(2,2)=a(2,2)
8981       return
8982       end
8983 c--------------------------------------------------------------------------
8984       subroutine transpose(n,a,at)
8985       implicit none
8986       integer n,i,j
8987       double precision a(n,n),at(n,n)
8988       do i=1,n
8989         do j=1,n
8990           at(j,i)=a(i,j)
8991         enddo
8992       enddo
8993       return
8994       end
8995 C---------------------------------------------------------------------------
8996       subroutine prodmat3(a1,a2,kk,transp,prod)
8997 !DIR$ INLINEALWAYS prodmat3
8998 #ifndef OSF
8999 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9000 #endif
9001       implicit none
9002       integer i,j
9003       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9004       logical transp
9005 crc      double precision auxmat(2,2),prod_(2,2)
9006
9007       if (transp) then
9008 crc        call transpose2(kk(1,1),auxmat(1,1))
9009 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9010 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9011
9012            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9013      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9014            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9015      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9016            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9017      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9018            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9019      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9020
9021       else
9022 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9023 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9024
9025            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9026      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9027            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9028      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9029            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9030      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9031            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9032      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9033
9034       endif
9035 c      call transpose2(a2(1,1),a2t(1,1))
9036
9037 crc      print *,transp
9038 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9039 crc      print *,((prod(i,j),i=1,2),j=1,2)
9040
9041       return
9042       end
9043