source/unres/src_MD/energy_p_new_barrier.F

   1       subroutine etotal(energia)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4 #ifndef ISNAN
   5       external proc_proc
   6 #ifdef WINPGI
   7 cMS$ATTRIBUTES C ::  proc_proc
   8 #endif
   9 #endif
  10 #ifdef MPI
  11       include "mpif.h"
  12       double precision weights_(n_ene)
  13 #endif
  14       include 'COMMON.SETUP'
  15       include 'COMMON.IOUNITS'
  16       double precision energia(0:n_ene)
  17       include 'COMMON.LOCAL'
  18       include 'COMMON.FFIELD'
  19       include 'COMMON.DERIV'
  20       include 'COMMON.INTERACT'
  21       include 'COMMON.SBRIDGE'
  22       include 'COMMON.CHAIN'
  23       include 'COMMON.VAR'
  24       include 'COMMON.MD'
  25       include 'COMMON.CONTROL'
  26       include 'COMMON.TIME1'
  27 #ifdef MPI
  28 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  29 c     & " nfgtasks",nfgtasks
  30       if (nfgtasks.gt.1) then
  31 #ifdef MPI
  32         time00=MPI_Wtime()
  33 #else
  34         time00=tcpu()
  35 #endif
  36 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  37         if (fg_rank.eq.0) then
  38           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  39 c          print *,"Processor",myrank," BROADCAST iorder"
  40 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  41 C FG slaves as WEIGHTS array.
  42           weights_(1)=wsc
  43           weights_(2)=wscp
  44           weights_(3)=welec
  45           weights_(4)=wcorr
  46           weights_(5)=wcorr5
  47           weights_(6)=wcorr6
  48           weights_(7)=wel_loc
  49           weights_(8)=wturn3
  50           weights_(9)=wturn4
  51           weights_(10)=wturn6
  52           weights_(11)=wang
  53           weights_(12)=wscloc
  54           weights_(13)=wtor
  55           weights_(14)=wtor_d
  56           weights_(15)=wstrain
  57           weights_(16)=wvdwpp
  58           weights_(17)=wbond
  59           weights_(18)=scal14
  60           weights_(21)=wsccor
  61           weights_(22)=wsct
  62 C FG Master broadcasts the WEIGHTS_ array
  63           call MPI_Bcast(weights_(1),n_ene,
  64      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  65         else
  66 C FG slaves receive the WEIGHTS array
  67           call MPI_Bcast(weights(1),n_ene,
  68      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  69           wsc=weights(1)
  70           wscp=weights(2)
  71           welec=weights(3)
  72           wcorr=weights(4)
  73           wcorr5=weights(5)
  74           wcorr6=weights(6)
  75           wel_loc=weights(7)
  76           wturn3=weights(8)
  77           wturn4=weights(9)
  78           wturn6=weights(10)
  79           wang=weights(11)
  80           wscloc=weights(12)
  81           wtor=weights(13)
  82           wtor_d=weights(14)
  83           wstrain=weights(15)
  84           wvdwpp=weights(16)
  85           wbond=weights(17)
  86           scal14=weights(18)
  87           wsccor=weights(21)
  88           wsct=weights(22)
  89         endif
  90         time_Bcast=time_Bcast+MPI_Wtime()-time00
  91         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  92 c        call chainbuild_cart
  93       endif
  94 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
  95 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  96 #else
  97 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  98 c        call int_from_cart1(.false.)
  99 c      endif
 100 #endif
 101 #ifdef TIMING
 102 #ifdef MPI
 103       time00=MPI_Wtime()
 104 #else
 105       time00=tcpu()
 106 #endif
 107 #endif
 108 C
 109 C Compute the side-chain and electrostatic interaction energy
 110 C
 111       goto (101,102,103,104,105,106) ipot
 112 C Lennard-Jones potential.
 113   101 call elj(evdw,evdw_p,evdw_m)
 114 cd    print '(a)','Exit ELJ'
 115       goto 107
 116 C Lennard-Jones-Kihara potential (shifted).
 117   102 call eljk(evdw,evdw_p,evdw_m)
 118       goto 107
 119 C Berne-Pechukas potential (dilated LJ, angular dependence).
 120   103 call ebp(evdw,evdw_p,evdw_m)
 121       goto 107
 122 C Gay-Berne potential (shifted LJ, angular dependence).
 123   104 call egb(evdw,evdw_p,evdw_m)
 124       goto 107
 125 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 126   105 call egbv(evdw,evdw_p,evdw_m)
 127       goto 107
 128 C Soft-sphere potential
 129   106 call e_softsphere(evdw)
 130 C
 131 C Calculate electrostatic (H-bonding) energy of the main chain.
 132 C
 133   107 continue
 134 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),gloc_scbuf(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       include 'COMMON.SCCOR'
 487 #ifdef TIMING
 488 #ifdef MPI
 489       time01=MPI_Wtime()
 490 #else
 491       time01=tcpu()
 492 #endif
 493 #endif
 494 #ifdef DEBUG
 495       write (iout,*) "sum_gradient gvdwc, gvdwx"
 496       do i=1,nres
 497         write (iout,'(i3,3f10.5,5x,3f10.5,5x,3f10.5,5x,3f10.5)')
 498      &   i,(gvdwx(j,i),j=1,3),(gvdwcT(j,i),j=1,3),(gvdwc(j,i),j=1,3),
 499      &   (gvdwcT(j,i),j=1,3)
 500       enddo
 501       call flush(iout)
 502 #endif
 503 #ifdef MPI
 504 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 505         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 506      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 507 #endif
 508 C
 509 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 510 C            in virtual-bond-vector coordinates
 511 C
 512 #ifdef DEBUG
 513 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 514 c      do i=1,nres-1
 515 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 516 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 517 c      enddo
 518 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 519 c      do i=1,nres-1
 520 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 521 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 522 c      enddo
 523       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 524       do i=1,nres
 525         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 526      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 527      &   g_corr5_loc(i)
 528       enddo
 529       call flush(iout)
 530 #endif
 531 #ifdef SPLITELE
 532 #ifdef TSCSC
 533       do i=1,nct
 534         do j=1,3
 535           gradbufc(j,i)=wsc*gvdwc(j,i)+wsc*wscT*gvdwcT(j,i)+
 536      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 537      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 538      &                wel_loc*gel_loc_long(j,i)+
 539      &                wcorr*gradcorr_long(j,i)+
 540      &                wcorr5*gradcorr5_long(j,i)+
 541      &                wcorr6*gradcorr6_long(j,i)+
 542      &                wturn6*gcorr6_turn_long(j,i)+
 543      &                wstrain*ghpbc(j,i)
 544         enddo
 545       enddo
 546 #else
 547       do i=1,nct
 548         do j=1,3
 549           gradbufc(j,i)=wsc*gvdwc(j,i)+
 550      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 551      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 552      &                wel_loc*gel_loc_long(j,i)+
 553      &                wcorr*gradcorr_long(j,i)+
 554      &                wcorr5*gradcorr5_long(j,i)+
 555      &                wcorr6*gradcorr6_long(j,i)+
 556      &                wturn6*gcorr6_turn_long(j,i)+
 557      &                wstrain*ghpbc(j,i)
 558         enddo
 559       enddo
 560 #endif
 561 #else
 562       do i=1,nct
 563         do j=1,3
 564           gradbufc(j,i)=wsc*gvdwc(j,i)+
 565      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 566      &                welec*gelc_long(j,i)+
 567      &                wbond*gradb(j,i)+
 568      &                wel_loc*gel_loc_long(j,i)+
 569      &                wcorr*gradcorr_long(j,i)+
 570      &                wcorr5*gradcorr5_long(j,i)+
 571      &                wcorr6*gradcorr6_long(j,i)+
 572      &                wturn6*gcorr6_turn_long(j,i)+
 573      &                wstrain*ghpbc(j,i)
 574         enddo
 575       enddo
 576 #endif
 577 #ifdef MPI
 578       if (nfgtasks.gt.1) then
 579       time00=MPI_Wtime()
 580 #ifdef DEBUG
 581       write (iout,*) "gradbufc before allreduce"
 582       do i=1,nres
 583         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 584       enddo
 585       call flush(iout)
 586 #endif
 587       do i=1,nres
 588         do j=1,3
 589           gradbufc_sum(j,i)=gradbufc(j,i)
 590         enddo
 591       enddo
 592 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 593 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 594 c      time_reduce=time_reduce+MPI_Wtime()-time00
 595 #ifdef DEBUG
 596 c      write (iout,*) "gradbufc_sum after allreduce"
 597 c      do i=1,nres
 598 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 599 c      enddo
 600 c      call flush(iout)
 601 #endif
 602 #ifdef TIMING
 603 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 604 #endif
 605       do i=nnt,nres
 606         do k=1,3
 607           gradbufc(k,i)=0.0d0
 608         enddo
 609       enddo
 610 #ifdef DEBUG
 611       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 612       write (iout,*) (i," jgrad_start",jgrad_start(i),
 613      &                  " jgrad_end  ",jgrad_end(i),
 614      &                  i=igrad_start,igrad_end)
 615 #endif
 616 c
 617 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 618 c do not parallelize this part.
 619 c
 620 c      do i=igrad_start,igrad_end
 621 c        do j=jgrad_start(i),jgrad_end(i)
 622 c          do k=1,3
 623 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 624 c          enddo
 625 c        enddo
 626 c      enddo
 627       do j=1,3
 628         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 629       enddo
 630       do i=nres-2,nnt,-1
 631         do j=1,3
 632           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 633         enddo
 634       enddo
 635 #ifdef DEBUG
 636       write (iout,*) "gradbufc after summing"
 637       do i=1,nres
 638         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 639       enddo
 640       call flush(iout)
 641 #endif
 642       else
 643 #endif
 644 #ifdef DEBUG
 645       write (iout,*) "gradbufc"
 646       do i=1,nres
 647         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 648       enddo
 649       call flush(iout)
 650 #endif
 651       do i=1,nres
 652         do j=1,3
 653           gradbufc_sum(j,i)=gradbufc(j,i)
 654           gradbufc(j,i)=0.0d0
 655         enddo
 656       enddo
 657       do j=1,3
 658         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 659       enddo
 660       do i=nres-2,nnt,-1
 661         do j=1,3
 662           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 663         enddo
 664       enddo
 665 c      do i=nnt,nres-1
 666 c        do k=1,3
 667 c          gradbufc(k,i)=0.0d0
 668 c        enddo
 669 c        do j=i+1,nres
 670 c          do k=1,3
 671 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 672 c          enddo
 673 c        enddo
 674 c      enddo
 675 #ifdef DEBUG
 676       write (iout,*) "gradbufc after summing"
 677       do i=1,nres
 678         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 679       enddo
 680       call flush(iout)
 681 #endif
 682 #ifdef MPI
 683       endif
 684 #endif
 685       do k=1,3
 686         gradbufc(k,nres)=0.0d0
 687       enddo
 688       do i=1,nct
 689         do j=1,3
 690 #ifdef SPLITELE
 691           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 692      &                wel_loc*gel_loc(j,i)+
 693      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 694      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 695      &                wel_loc*gel_loc_long(j,i)+
 696      &                wcorr*gradcorr_long(j,i)+
 697      &                wcorr5*gradcorr5_long(j,i)+
 698      &                wcorr6*gradcorr6_long(j,i)+
 699      &                wturn6*gcorr6_turn_long(j,i))+
 700      &                wbond*gradb(j,i)+
 701      &                wcorr*gradcorr(j,i)+
 702      &                wturn3*gcorr3_turn(j,i)+
 703      &                wturn4*gcorr4_turn(j,i)+
 704      &                wcorr5*gradcorr5(j,i)+
 705      &                wcorr6*gradcorr6(j,i)+
 706      &                wturn6*gcorr6_turn(j,i)+
 707      &                wsccor*gsccorc(j,i)
 708      &               +wscloc*gscloc(j,i)
 709 #else
 710           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 711      &                wel_loc*gel_loc(j,i)+
 712      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 713      &                welec*gelc_long(j,i)+
 714      &                wel_loc*gel_loc_long(j,i)+
 715      &                wcorr*gcorr_long(j,i)+
 716      &                wcorr5*gradcorr5_long(j,i)+
 717      &                wcorr6*gradcorr6_long(j,i)+
 718      &                wturn6*gcorr6_turn_long(j,i))+
 719      &                wbond*gradb(j,i)+
 720      &                wcorr*gradcorr(j,i)+
 721      &                wturn3*gcorr3_turn(j,i)+
 722      &                wturn4*gcorr4_turn(j,i)+
 723      &                wcorr5*gradcorr5(j,i)+
 724      &                wcorr6*gradcorr6(j,i)+
 725      &                wturn6*gcorr6_turn(j,i)+
 726      &                wsccor*gsccorc(j,i)
 727      &               +wscloc*gscloc(j,i)
 728 #endif
 729 #ifdef TSCSC
 730           gradx(j,i,icg)=wsc*gvdwx(j,i)+wsc*wscT*gvdwxT(j,i)+
 731      &                  wscp*gradx_scp(j,i)+
 732      &                  wbond*gradbx(j,i)+
 733      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 734      &                  wsccor*gsccorx(j,i)
 735      &                 +wscloc*gsclocx(j,i)
 736 #else
 737           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 738      &                  wbond*gradbx(j,i)+
 739      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 740      &                  wsccor*gsccorx(j,i)
 741      &                 +wscloc*gsclocx(j,i)
 742 #endif
 743         enddo
 744       enddo
 745 #ifdef DEBUG
 746       write (iout,*) "gloc before adding corr"
 747       do i=1,4*nres
 748         write (iout,*) i,gloc(i,icg)
 749       enddo
 750 #endif
 751       do i=1,nres-3
 752         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 753      &   +wcorr5*g_corr5_loc(i)
 754      &   +wcorr6*g_corr6_loc(i)
 755      &   +wturn4*gel_loc_turn4(i)
 756      &   +wturn3*gel_loc_turn3(i)
 757      &   +wturn6*gel_loc_turn6(i)
 758      &   +wel_loc*gel_loc_loc(i)
 759       enddo
 760 #ifdef DEBUG
 761       write (iout,*) "gloc after adding corr"
 762       do i=1,4*nres
 763         write (iout,*) i,gloc(i,icg)
 764       enddo
 765 #endif
 766 #ifdef MPI
 767       if (nfgtasks.gt.1) then
 768         do j=1,3
 769           do i=1,nres
 770             gradbufc(j,i)=gradc(j,i,icg)
 771             gradbufx(j,i)=gradx(j,i,icg)
 772           enddo
 773         enddo
 774         do i=1,4*nres
 775           glocbuf(i)=gloc(i,icg)
 776         enddo
 777 #define DEBUG
 778 #ifdef DEBUG
 779       write (iout,*) "gloc_sc before reduce"
 780       do i=1,nres
 781        do j=1,3
 782         write (iout,*) i,j,gloc_sc(j,i,icg)
 783        enddo
 784       enddo
 785 #endif
 786 #undef DEBUG
 787         do i=1,nres
 788          do j=1,3
 789           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 790          enddo
 791         enddo
 792         time00=MPI_Wtime()
 793         call MPI_Barrier(FG_COMM,IERR)
 794         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 795         time00=MPI_Wtime()
 796         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 797      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 798         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 799      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 800         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 801      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 802         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 803      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 804         time_reduce=time_reduce+MPI_Wtime()-time00
 805 #define DEBUG
 806 #ifdef DEBUG
 807       write (iout,*) "gloc_sc after reduce"
 808       do i=1,nres
 809        do j=1,3
 810         write (iout,*) i,j,gloc_sc(j,i,icg)
 811        enddo
 812       enddo
 813 #endif
 814 #undef DEBUG
 815 #ifdef DEBUG
 816       write (iout,*) "gloc after reduce"
 817       do i=1,4*nres
 818         write (iout,*) i,gloc(i,icg)
 819       enddo
 820 #endif
 821       endif
 822 #endif
 823       if (gnorm_check) then
 824 c
 825 c Compute the maximum elements of the gradient
 826 c
 827       gvdwc_max=0.0d0
 828       gvdwc_scp_max=0.0d0
 829       gelc_max=0.0d0
 830       gvdwpp_max=0.0d0
 831       gradb_max=0.0d0
 832       ghpbc_max=0.0d0
 833       gradcorr_max=0.0d0
 834       gel_loc_max=0.0d0
 835       gcorr3_turn_max=0.0d0
 836       gcorr4_turn_max=0.0d0
 837       gradcorr5_max=0.0d0
 838       gradcorr6_max=0.0d0
 839       gcorr6_turn_max=0.0d0
 840       gsccorc_max=0.0d0
 841       gscloc_max=0.0d0
 842       gvdwx_max=0.0d0
 843       gradx_scp_max=0.0d0
 844       ghpbx_max=0.0d0
 845       gradxorr_max=0.0d0
 846       gsccorx_max=0.0d0
 847       gsclocx_max=0.0d0
 848       do i=1,nct
 849         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 850         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 851 #ifdef TSCSC
 852         gvdwc_norm=dsqrt(scalar(gvdwcT(1,i),gvdwcT(1,i)))
 853         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 854 #endif
 855         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 856         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 857      &   gvdwc_scp_max=gvdwc_scp_norm
 858         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 859         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 860         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 861         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 862         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 863         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 864         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 865         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 866         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 867         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 868         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 869         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 870         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 871      &    gcorr3_turn(1,i)))
 872         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 873      &    gcorr3_turn_max=gcorr3_turn_norm
 874         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 875      &    gcorr4_turn(1,i)))
 876         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 877      &    gcorr4_turn_max=gcorr4_turn_norm
 878         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 879         if (gradcorr5_norm.gt.gradcorr5_max)
 880      &    gradcorr5_max=gradcorr5_norm
 881         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 882         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 883         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 884      &    gcorr6_turn(1,i)))
 885         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 886      &    gcorr6_turn_max=gcorr6_turn_norm
 887         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 888         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 889         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 890         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 891         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 892         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 893 #ifdef TSCSC
 894         gvdwx_norm=dsqrt(scalar(gvdwxT(1,i),gvdwxT(1,i)))
 895         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 896 #endif
 897         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 898         if (gradx_scp_norm.gt.gradx_scp_max)
 899      &    gradx_scp_max=gradx_scp_norm
 900         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 901         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 902         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 903         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 904         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 905         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 906         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 907         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 908       enddo
 909       if (gradout) then
 910 #ifdef AIX
 911         open(istat,file=statname,position="append")
 912 #else
 913         open(istat,file=statname,access="append")
 914 #endif
 915         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 916      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 917      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 918      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 919      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 920      &     gsccorx_max,gsclocx_max
 921         close(istat)
 922         if (gvdwc_max.gt.1.0d4) then
 923           write (iout,*) "gvdwc gvdwx gradb gradbx"
 924           do i=nnt,nct
 925             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 926      &        gradb(j,i),gradbx(j,i),j=1,3)
 927           enddo
 928           call pdbout(0.0d0,'cipiszcze',iout)
 929           call flush(iout)
 930         endif
 931       endif
 932       endif
 933 #ifdef DEBUG
 934       write (iout,*) "gradc gradx gloc"
 935       do i=1,nres
 936         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 937      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 938       enddo
 939 #endif
 940 #ifdef TIMING
 941 #ifdef MPI
 942       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 943 #else
 944       time_sumgradient=time_sumgradient+tcpu()-time01
 945 #endif
 946 #endif
 947       return
 948       end
 949 c-------------------------------------------------------------------------------
 950       subroutine rescale_weights(t_bath)
 951       implicit real*8 (a-h,o-z)
 952       include 'DIMENSIONS'
 953       include 'COMMON.IOUNITS'
 954       include 'COMMON.FFIELD'
 955       include 'COMMON.SBRIDGE'
 956       double precision kfac /2.4d0/
 957       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 958 c      facT=temp0/t_bath
 959 c      facT=2*temp0/(t_bath+temp0)
 960       if (rescale_mode.eq.0) then
 961         facT=1.0d0
 962         facT2=1.0d0
 963         facT3=1.0d0
 964         facT4=1.0d0
 965         facT5=1.0d0
 966       else if (rescale_mode.eq.1) then
 967         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 968         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 969         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 970         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 971         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 972       else if (rescale_mode.eq.2) then
 973         x=t_bath/temp0
 974         x2=x*x
 975         x3=x2*x
 976         x4=x3*x
 977         x5=x4*x
 978         facT=licznik/dlog(dexp(x)+dexp(-x))
 979         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 980         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 981         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 982         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 983       else
 984         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 985         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 986 #ifdef MPI
 987        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 988 #endif
 989        stop 555
 990       endif
 991       welec=weights(3)*fact
 992       wcorr=weights(4)*fact3
 993       wcorr5=weights(5)*fact4
 994       wcorr6=weights(6)*fact5
 995       wel_loc=weights(7)*fact2
 996       wturn3=weights(8)*fact2
 997       wturn4=weights(9)*fact3
 998       wturn6=weights(10)*fact5
 999       wtor=weights(13)*fact
1000       wtor_d=weights(14)*fact2
1001       wsccor=weights(21)*fact
1002 #ifdef TSCSC
1003 c      wsct=t_bath/temp0
1004       wsct=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
1005 #endif
1006       return
1007       end
1008 C------------------------------------------------------------------------
1009       subroutine enerprint(energia)
1010       implicit real*8 (a-h,o-z)
1011       include 'DIMENSIONS'
1012       include 'COMMON.IOUNITS'
1013       include 'COMMON.FFIELD'
1014       include 'COMMON.SBRIDGE'
1015       include 'COMMON.MD'
1016       double precision energia(0:n_ene)
1017       etot=energia(0)
1018 #ifdef TSCSC
1019       evdw=energia(22)+wsct*energia(23)
1020 #else
1021       evdw=energia(1)
1022 #endif
1023       evdw2=energia(2)
1024 #ifdef SCP14
1025       evdw2=energia(2)+energia(18)
1026 #else
1027       evdw2=energia(2)
1028 #endif
1029       ees=energia(3)
1030 #ifdef SPLITELE
1031       evdw1=energia(16)
1032 #endif
1033       ecorr=energia(4)
1034       ecorr5=energia(5)
1035       ecorr6=energia(6)
1036       eel_loc=energia(7)
1037       eello_turn3=energia(8)
1038       eello_turn4=energia(9)
1039       eello_turn6=energia(10)
1040       ebe=energia(11)
1041       escloc=energia(12)
1042       etors=energia(13)
1043       etors_d=energia(14)
1044       ehpb=energia(15)
1045       edihcnstr=energia(19)
1046       estr=energia(17)
1047       Uconst=energia(20)
1048       esccor=energia(21)
1049 #ifdef SPLITELE
1050       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1051      &  estr,wbond,ebe,wang,
1052      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1053      &  ecorr,wcorr,
1054      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1055      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
1056      &  edihcnstr,ebr*nss,
1057      &  Uconst,etot
1058    10 format (/'Virtual-chain energies:'//
1059      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1060      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1061      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1062      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
1063      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1064      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1065      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1066      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1067      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1068      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1069      & ' (SS bridges & dist. cnstr.)'/
1070      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1071      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1072      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1073      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1074      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1075      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1076      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1077      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1078      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1079      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1080      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1081      & 'ETOT=  ',1pE16.6,' (total)')
1082 #else
1083       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1084      &  estr,wbond,ebe,wang,
1085      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1086      &  ecorr,wcorr,
1087      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1088      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1089      &  ebr*nss,Uconst,etot
1090    10 format (/'Virtual-chain energies:'//
1091      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1092      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1093      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1094      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1095      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1096      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1097      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1098      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1099      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1100      & ' (SS bridges & dist. cnstr.)'/
1101      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1102      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1103      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1104      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1105      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1106      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1107      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1108      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1109      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1110      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1111      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1112      & 'ETOT=  ',1pE16.6,' (total)')
1113 #endif
1114       return
1115       end
1116 C-----------------------------------------------------------------------
1117       subroutine elj(evdw,evdw_p,evdw_m)
1118 C
1119 C This subroutine calculates the interaction energy of nonbonded side chains
1120 C assuming the LJ potential of interaction.
1121 C
1122       implicit real*8 (a-h,o-z)
1123       include 'DIMENSIONS'
1124       parameter (accur=1.0d-10)
1125       include 'COMMON.GEO'
1126       include 'COMMON.VAR'
1127       include 'COMMON.LOCAL'
1128       include 'COMMON.CHAIN'
1129       include 'COMMON.DERIV'
1130       include 'COMMON.INTERACT'
1131       include 'COMMON.TORSION'
1132       include 'COMMON.SBRIDGE'
1133       include 'COMMON.NAMES'
1134       include 'COMMON.IOUNITS'
1135       include 'COMMON.CONTACTS'
1136       dimension gg(3)
1137 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1138       evdw=0.0D0
1139       do i=iatsc_s,iatsc_e
1140         itypi=itype(i)
1141         itypi1=itype(i+1)
1142         xi=c(1,nres+i)
1143         yi=c(2,nres+i)
1144         zi=c(3,nres+i)
1145 C Change 12/1/95
1146         num_conti=0
1147 C
1148 C Calculate SC interaction energy.
1149 C
1150         do iint=1,nint_gr(i)
1151 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1152 cd   &                  'iend=',iend(i,iint)
1153           do j=istart(i,iint),iend(i,iint)
1154             itypj=itype(j)
1155             xj=c(1,nres+j)-xi
1156             yj=c(2,nres+j)-yi
1157             zj=c(3,nres+j)-zi
1158 C Change 12/1/95 to calculate four-body interactions
1159             rij=xj*xj+yj*yj+zj*zj
1160             rrij=1.0D0/rij
1161 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1162             eps0ij=eps(itypi,itypj)
1163             fac=rrij**expon2
1164             e1=fac*fac*aa(itypi,itypj)
1165             e2=fac*bb(itypi,itypj)
1166             evdwij=e1+e2
1167 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1168 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1169 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1170 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1171 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1172 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1173 #ifdef TSCSC
1174             if (bb(itypi,itypj).gt.0) then
1175                evdw_p=evdw_p+evdwij
1176             else
1177                evdw_m=evdw_m+evdwij
1178             endif
1179 #else
1180             evdw=evdw+evdwij
1181 #endif
1182 C
1183 C Calculate the components of the gradient in DC and X
1184 C
1185             fac=-rrij*(e1+evdwij)
1186             gg(1)=xj*fac
1187             gg(2)=yj*fac
1188             gg(3)=zj*fac
1189 #ifdef TSCSC
1190             if (bb(itypi,itypj).gt.0.0d0) then
1191               do k=1,3
1192                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1193                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1194                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1195                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1196               enddo
1197             else
1198               do k=1,3
1199                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1200                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1201                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1202                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1203               enddo
1204             endif
1205 #else
1206             do k=1,3
1207               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1208               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1209               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1210               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1211             enddo
1212 #endif
1213 cgrad            do k=i,j-1
1214 cgrad              do l=1,3
1215 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1216 cgrad              enddo
1217 cgrad            enddo
1218 C
1219 C 12/1/95, revised on 5/20/97
1220 C
1221 C Calculate the contact function. The ith column of the array JCONT will
1222 C contain the numbers of atoms that make contacts with the atom I (of numbers
1223 C greater than I). The arrays FACONT and GACONT will contain the values of
1224 C the contact function and its derivative.
1225 C
1226 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1227 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1228 C Uncomment next line, if the correlation interactions are contact function only
1229             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1230               rij=dsqrt(rij)
1231               sigij=sigma(itypi,itypj)
1232               r0ij=rs0(itypi,itypj)
1233 C
1234 C Check whether the SC's are not too far to make a contact.
1235 C
1236               rcut=1.5d0*r0ij
1237               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1238 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1239 C
1240               if (fcont.gt.0.0D0) then
1241 C If the SC-SC distance if close to sigma, apply spline.
1242 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1243 cAdam &             fcont1,fprimcont1)
1244 cAdam           fcont1=1.0d0-fcont1
1245 cAdam           if (fcont1.gt.0.0d0) then
1246 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1247 cAdam             fcont=fcont*fcont1
1248 cAdam           endif
1249 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1250 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1251 cga             do k=1,3
1252 cga               gg(k)=gg(k)*eps0ij
1253 cga             enddo
1254 cga             eps0ij=-evdwij*eps0ij
1255 C Uncomment for AL's type of SC correlation interactions.
1256 cadam           eps0ij=-evdwij
1257                 num_conti=num_conti+1
1258                 jcont(num_conti,i)=j
1259                 facont(num_conti,i)=fcont*eps0ij
1260                 fprimcont=eps0ij*fprimcont/rij
1261                 fcont=expon*fcont
1262 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1263 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1264 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1265 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1266                 gacont(1,num_conti,i)=-fprimcont*xj
1267                 gacont(2,num_conti,i)=-fprimcont*yj
1268                 gacont(3,num_conti,i)=-fprimcont*zj
1269 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1270 cd              write (iout,'(2i3,3f10.5)')
1271 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1272               endif
1273             endif
1274           enddo      ! j
1275         enddo        ! iint
1276 C Change 12/1/95
1277         num_cont(i)=num_conti
1278       enddo          ! i
1279       do i=1,nct
1280         do j=1,3
1281           gvdwc(j,i)=expon*gvdwc(j,i)
1282           gvdwx(j,i)=expon*gvdwx(j,i)
1283         enddo
1284       enddo
1285 C******************************************************************************
1286 C
1287 C                              N O T E !!!
1288 C
1289 C To save time, the factor of EXPON has been extracted from ALL components
1290 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1291 C use!
1292 C
1293 C******************************************************************************
1294       return
1295       end
1296 C-----------------------------------------------------------------------------
1297       subroutine eljk(evdw,evdw_p,evdw_m)
1298 C
1299 C This subroutine calculates the interaction energy of nonbonded side chains
1300 C assuming the LJK potential of interaction.
1301 C
1302       implicit real*8 (a-h,o-z)
1303       include 'DIMENSIONS'
1304       include 'COMMON.GEO'
1305       include 'COMMON.VAR'
1306       include 'COMMON.LOCAL'
1307       include 'COMMON.CHAIN'
1308       include 'COMMON.DERIV'
1309       include 'COMMON.INTERACT'
1310       include 'COMMON.IOUNITS'
1311       include 'COMMON.NAMES'
1312       dimension gg(3)
1313       logical scheck
1314 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1315       evdw=0.0D0
1316       do i=iatsc_s,iatsc_e
1317         itypi=itype(i)
1318         itypi1=itype(i+1)
1319         xi=c(1,nres+i)
1320         yi=c(2,nres+i)
1321         zi=c(3,nres+i)
1322 C
1323 C Calculate SC interaction energy.
1324 C
1325         do iint=1,nint_gr(i)
1326           do j=istart(i,iint),iend(i,iint)
1327             itypj=itype(j)
1328             xj=c(1,nres+j)-xi
1329             yj=c(2,nres+j)-yi
1330             zj=c(3,nres+j)-zi
1331             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1332             fac_augm=rrij**expon
1333             e_augm=augm(itypi,itypj)*fac_augm
1334             r_inv_ij=dsqrt(rrij)
1335             rij=1.0D0/r_inv_ij
1336             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1337             fac=r_shift_inv**expon
1338             e1=fac*fac*aa(itypi,itypj)
1339             e2=fac*bb(itypi,itypj)
1340             evdwij=e_augm+e1+e2
1341 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1342 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1343 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1344 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1345 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1346 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1347 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1348 #ifdef TSCSC
1349             if (bb(itypi,itypj).gt.0) then
1350                evdw_p=evdw_p+evdwij
1351             else
1352                evdw_m=evdw_m+evdwij
1353             endif
1354 #else
1355             evdw=evdw+evdwij
1356 #endif
1357 C
1358 C Calculate the components of the gradient in DC and X
1359 C
1360             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1361             gg(1)=xj*fac
1362             gg(2)=yj*fac
1363             gg(3)=zj*fac
1364 #ifdef TSCSC
1365             if (bb(itypi,itypj).gt.0.0d0) then
1366               do k=1,3
1367                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1368                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1369                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1370                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1371               enddo
1372             else
1373               do k=1,3
1374                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1375                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1376                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1377                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1378               enddo
1379             endif
1380 #else
1381             do k=1,3
1382               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1383               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1384               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1385               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1386             enddo
1387 #endif
1388 cgrad            do k=i,j-1
1389 cgrad              do l=1,3
1390 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1391 cgrad              enddo
1392 cgrad            enddo
1393           enddo      ! j
1394         enddo        ! iint
1395       enddo          ! i
1396       do i=1,nct
1397         do j=1,3
1398           gvdwc(j,i)=expon*gvdwc(j,i)
1399           gvdwx(j,i)=expon*gvdwx(j,i)
1400         enddo
1401       enddo
1402       return
1403       end
1404 C-----------------------------------------------------------------------------
1405       subroutine ebp(evdw,evdw_p,evdw_m)
1406 C
1407 C This subroutine calculates the interaction energy of nonbonded side chains
1408 C assuming the Berne-Pechukas potential of interaction.
1409 C
1410       implicit real*8 (a-h,o-z)
1411       include 'DIMENSIONS'
1412       include 'COMMON.GEO'
1413       include 'COMMON.VAR'
1414       include 'COMMON.LOCAL'
1415       include 'COMMON.CHAIN'
1416       include 'COMMON.DERIV'
1417       include 'COMMON.NAMES'
1418       include 'COMMON.INTERACT'
1419       include 'COMMON.IOUNITS'
1420       include 'COMMON.CALC'
1421       common /srutu/ icall
1422 c     double precision rrsave(maxdim)
1423       logical lprn
1424       evdw=0.0D0
1425 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1426       evdw=0.0D0
1427 c     if (icall.eq.0) then
1428 c       lprn=.true.
1429 c     else
1430         lprn=.false.
1431 c     endif
1432       ind=0
1433       do i=iatsc_s,iatsc_e
1434         itypi=itype(i)
1435         itypi1=itype(i+1)
1436         xi=c(1,nres+i)
1437         yi=c(2,nres+i)
1438         zi=c(3,nres+i)
1439         dxi=dc_norm(1,nres+i)
1440         dyi=dc_norm(2,nres+i)
1441         dzi=dc_norm(3,nres+i)
1442 c        dsci_inv=dsc_inv(itypi)
1443         dsci_inv=vbld_inv(i+nres)
1444 C
1445 C Calculate SC interaction energy.
1446 C
1447         do iint=1,nint_gr(i)
1448           do j=istart(i,iint),iend(i,iint)
1449             ind=ind+1
1450             itypj=itype(j)
1451 c            dscj_inv=dsc_inv(itypj)
1452             dscj_inv=vbld_inv(j+nres)
1453             chi1=chi(itypi,itypj)
1454             chi2=chi(itypj,itypi)
1455             chi12=chi1*chi2
1456             chip1=chip(itypi)
1457             chip2=chip(itypj)
1458             chip12=chip1*chip2
1459             alf1=alp(itypi)
1460             alf2=alp(itypj)
1461             alf12=0.5D0*(alf1+alf2)
1462 C For diagnostics only!!!
1463 c           chi1=0.0D0
1464 c           chi2=0.0D0
1465 c           chi12=0.0D0
1466 c           chip1=0.0D0
1467 c           chip2=0.0D0
1468 c           chip12=0.0D0
1469 c           alf1=0.0D0
1470 c           alf2=0.0D0
1471 c           alf12=0.0D0
1472             xj=c(1,nres+j)-xi
1473             yj=c(2,nres+j)-yi
1474             zj=c(3,nres+j)-zi
1475             dxj=dc_norm(1,nres+j)
1476             dyj=dc_norm(2,nres+j)
1477             dzj=dc_norm(3,nres+j)
1478             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1479 cd          if (icall.eq.0) then
1480 cd            rrsave(ind)=rrij
1481 cd          else
1482 cd            rrij=rrsave(ind)
1483 cd          endif
1484             rij=dsqrt(rrij)
1485 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1486             call sc_angular
1487 C Calculate whole angle-dependent part of epsilon and contributions
1488 C to its derivatives
1489             fac=(rrij*sigsq)**expon2
1490             e1=fac*fac*aa(itypi,itypj)
1491             e2=fac*bb(itypi,itypj)
1492             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1493             eps2der=evdwij*eps3rt
1494             eps3der=evdwij*eps2rt
1495             evdwij=evdwij*eps2rt*eps3rt
1496 #ifdef TSCSC
1497             if (bb(itypi,itypj).gt.0) then
1498                evdw_p=evdw_p+evdwij
1499             else
1500                evdw_m=evdw_m+evdwij
1501             endif
1502 #else
1503             evdw=evdw+evdwij
1504 #endif
1505             if (lprn) then
1506             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1507             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1508 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1509 cd     &        restyp(itypi),i,restyp(itypj),j,
1510 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1511 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1512 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1513 cd     &        evdwij
1514             endif
1515 C Calculate gradient components.
1516             e1=e1*eps1*eps2rt**2*eps3rt**2
1517             fac=-expon*(e1+evdwij)
1518             sigder=fac/sigsq
1519             fac=rrij*fac
1520 C Calculate radial part of the gradient
1521             gg(1)=xj*fac
1522             gg(2)=yj*fac
1523             gg(3)=zj*fac
1524 C Calculate the angular part of the gradient and sum add the contributions
1525 C to the appropriate components of the Cartesian gradient.
1526 #ifdef TSCSC
1527             if (bb(itypi,itypj).gt.0) then
1528                call sc_grad
1529             else
1530                call sc_grad_T
1531             endif
1532 #else
1533             call sc_grad
1534 #endif
1535           enddo      ! j
1536         enddo        ! iint
1537       enddo          ! i
1538 c     stop
1539       return
1540       end
1541 C-----------------------------------------------------------------------------
1542       subroutine egb(evdw,evdw_p,evdw_m)
1543 C
1544 C This subroutine calculates the interaction energy of nonbonded side chains
1545 C assuming the Gay-Berne potential of interaction.
1546 C
1547       implicit real*8 (a-h,o-z)
1548       include 'DIMENSIONS'
1549       include 'COMMON.GEO'
1550       include 'COMMON.VAR'
1551       include 'COMMON.LOCAL'
1552       include 'COMMON.CHAIN'
1553       include 'COMMON.DERIV'
1554       include 'COMMON.NAMES'
1555       include 'COMMON.INTERACT'
1556       include 'COMMON.IOUNITS'
1557       include 'COMMON.CALC'
1558       include 'COMMON.CONTROL'
1559       logical lprn
1560       evdw=0.0D0
1561 ccccc      energy_dec=.false.
1562 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1563       evdw=0.0D0
1564       evdw_p=0.0D0
1565       evdw_m=0.0D0
1566       lprn=.false.
1567 c     if (icall.eq.0) lprn=.false.
1568       ind=0
1569       do i=iatsc_s,iatsc_e
1570         itypi=itype(i)
1571         itypi1=itype(i+1)
1572         xi=c(1,nres+i)
1573         yi=c(2,nres+i)
1574         zi=c(3,nres+i)
1575         dxi=dc_norm(1,nres+i)
1576         dyi=dc_norm(2,nres+i)
1577         dzi=dc_norm(3,nres+i)
1578 c        dsci_inv=dsc_inv(itypi)
1579         dsci_inv=vbld_inv(i+nres)
1580 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1581 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1582 C
1583 C Calculate SC interaction energy.
1584 C
1585         do iint=1,nint_gr(i)
1586           do j=istart(i,iint),iend(i,iint)
1587             ind=ind+1
1588             itypj=itype(j)
1589 c            dscj_inv=dsc_inv(itypj)
1590             dscj_inv=vbld_inv(j+nres)
1591 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1592 c     &       1.0d0/vbld(j+nres)
1593 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1594             sig0ij=sigma(itypi,itypj)
1595             chi1=chi(itypi,itypj)
1596             chi2=chi(itypj,itypi)
1597             chi12=chi1*chi2
1598             chip1=chip(itypi)
1599             chip2=chip(itypj)
1600             chip12=chip1*chip2
1601             alf1=alp(itypi)
1602             alf2=alp(itypj)
1603             alf12=0.5D0*(alf1+alf2)
1604 C For diagnostics only!!!
1605 c           chi1=0.0D0
1606 c           chi2=0.0D0
1607 c           chi12=0.0D0
1608 c           chip1=0.0D0
1609 c           chip2=0.0D0
1610 c           chip12=0.0D0
1611 c           alf1=0.0D0
1612 c           alf2=0.0D0
1613 c           alf12=0.0D0
1614             xj=c(1,nres+j)-xi
1615             yj=c(2,nres+j)-yi
1616             zj=c(3,nres+j)-zi
1617             dxj=dc_norm(1,nres+j)
1618             dyj=dc_norm(2,nres+j)
1619             dzj=dc_norm(3,nres+j)
1620 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1621 c            write (iout,*) "j",j," dc_norm",
1622 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1623             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1624             rij=dsqrt(rrij)
1625 C Calculate angle-dependent terms of energy and contributions to their
1626 C derivatives.
1627             call sc_angular
1628             sigsq=1.0D0/sigsq
1629             sig=sig0ij*dsqrt(sigsq)
1630             rij_shift=1.0D0/rij-sig+sig0ij
1631 c for diagnostics; uncomment
1632 c            rij_shift=1.2*sig0ij
1633 C I hate to put IF's in the loops, but here don't have another choice!!!!
1634             if (rij_shift.le.0.0D0) then
1635               evdw=1.0D20
1636 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1637 cd     &        restyp(itypi),i,restyp(itypj),j,
1638 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1639               return
1640             endif
1641             sigder=-sig*sigsq
1642 c---------------------------------------------------------------
1643             rij_shift=1.0D0/rij_shift
1644             fac=rij_shift**expon
1645             e1=fac*fac*aa(itypi,itypj)
1646             e2=fac*bb(itypi,itypj)
1647             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1648             eps2der=evdwij*eps3rt
1649             eps3der=evdwij*eps2rt
1650 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1651 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1652             evdwij=evdwij*eps2rt*eps3rt
1653 #ifdef TSCSC
1654             if (bb(itypi,itypj).gt.0) then
1655                evdw_p=evdw_p+evdwij
1656             else
1657                evdw_m=evdw_m+evdwij
1658             endif
1659 #else
1660             evdw=evdw+evdwij
1661 #endif
1662             if (lprn) then
1663             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1664             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1665             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1666      &        restyp(itypi),i,restyp(itypj),j,
1667      &        epsi,sigm,chi1,chi2,chip1,chip2,
1668      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1669      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1670      &        evdwij
1671             endif
1672
1673             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1674      &                        'evdw',i,j,evdwij
1675
1676 C Calculate gradient components.
1677             e1=e1*eps1*eps2rt**2*eps3rt**2
1678             fac=-expon*(e1+evdwij)*rij_shift
1679             sigder=fac*sigder
1680             fac=rij*fac
1681 c            fac=0.0d0
1682 C Calculate the radial part of the gradient
1683             gg(1)=xj*fac
1684             gg(2)=yj*fac
1685             gg(3)=zj*fac
1686 C Calculate angular part of the gradient.
1687 #ifdef TSCSC
1688             if (bb(itypi,itypj).gt.0) then
1689                call sc_grad
1690             else
1691                call sc_grad_T
1692             endif
1693 #else
1694             call sc_grad
1695 #endif
1696           enddo      ! j
1697         enddo        ! iint
1698       enddo          ! i
1699 c      write (iout,*) "Number of loop steps in EGB:",ind
1700 cccc      energy_dec=.false.
1701       return
1702       end
1703 C-----------------------------------------------------------------------------
1704       subroutine egbv(evdw,evdw_p,evdw_m)
1705 C
1706 C This subroutine calculates the interaction energy of nonbonded side chains
1707 C assuming the Gay-Berne-Vorobjev potential of interaction.
1708 C
1709       implicit real*8 (a-h,o-z)
1710       include 'DIMENSIONS'
1711       include 'COMMON.GEO'
1712       include 'COMMON.VAR'
1713       include 'COMMON.LOCAL'
1714       include 'COMMON.CHAIN'
1715       include 'COMMON.DERIV'
1716       include 'COMMON.NAMES'
1717       include 'COMMON.INTERACT'
1718       include 'COMMON.IOUNITS'
1719       include 'COMMON.CALC'
1720       common /srutu/ icall
1721       logical lprn
1722       evdw=0.0D0
1723 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1724       evdw=0.0D0
1725       lprn=.false.
1726 c     if (icall.eq.0) lprn=.true.
1727       ind=0
1728       do i=iatsc_s,iatsc_e
1729         itypi=itype(i)
1730         itypi1=itype(i+1)
1731         xi=c(1,nres+i)
1732         yi=c(2,nres+i)
1733         zi=c(3,nres+i)
1734         dxi=dc_norm(1,nres+i)
1735         dyi=dc_norm(2,nres+i)
1736         dzi=dc_norm(3,nres+i)
1737 c        dsci_inv=dsc_inv(itypi)
1738         dsci_inv=vbld_inv(i+nres)
1739 C
1740 C Calculate SC interaction energy.
1741 C
1742         do iint=1,nint_gr(i)
1743           do j=istart(i,iint),iend(i,iint)
1744             ind=ind+1
1745             itypj=itype(j)
1746 c            dscj_inv=dsc_inv(itypj)
1747             dscj_inv=vbld_inv(j+nres)
1748             sig0ij=sigma(itypi,itypj)
1749             r0ij=r0(itypi,itypj)
1750             chi1=chi(itypi,itypj)
1751             chi2=chi(itypj,itypi)
1752             chi12=chi1*chi2
1753             chip1=chip(itypi)
1754             chip2=chip(itypj)
1755             chip12=chip1*chip2
1756             alf1=alp(itypi)
1757             alf2=alp(itypj)
1758             alf12=0.5D0*(alf1+alf2)
1759 C For diagnostics only!!!
1760 c           chi1=0.0D0
1761 c           chi2=0.0D0
1762 c           chi12=0.0D0
1763 c           chip1=0.0D0
1764 c           chip2=0.0D0
1765 c           chip12=0.0D0
1766 c           alf1=0.0D0
1767 c           alf2=0.0D0
1768 c           alf12=0.0D0
1769             xj=c(1,nres+j)-xi
1770             yj=c(2,nres+j)-yi
1771             zj=c(3,nres+j)-zi
1772             dxj=dc_norm(1,nres+j)
1773             dyj=dc_norm(2,nres+j)
1774             dzj=dc_norm(3,nres+j)
1775             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1776             rij=dsqrt(rrij)
1777 C Calculate angle-dependent terms of energy and contributions to their
1778 C derivatives.
1779             call sc_angular
1780             sigsq=1.0D0/sigsq
1781             sig=sig0ij*dsqrt(sigsq)
1782             rij_shift=1.0D0/rij-sig+r0ij
1783 C I hate to put IF's in the loops, but here don't have another choice!!!!
1784             if (rij_shift.le.0.0D0) then
1785               evdw=1.0D20
1786               return
1787             endif
1788             sigder=-sig*sigsq
1789 c---------------------------------------------------------------
1790             rij_shift=1.0D0/rij_shift
1791             fac=rij_shift**expon
1792             e1=fac*fac*aa(itypi,itypj)
1793             e2=fac*bb(itypi,itypj)
1794             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1795             eps2der=evdwij*eps3rt
1796             eps3der=evdwij*eps2rt
1797             fac_augm=rrij**expon
1798             e_augm=augm(itypi,itypj)*fac_augm
1799             evdwij=evdwij*eps2rt*eps3rt
1800 #ifdef TSCSC
1801             if (bb(itypi,itypj).gt.0) then
1802                evdw_p=evdw_p+evdwij+e_augm
1803             else
1804                evdw_m=evdw_m+evdwij+e_augm
1805             endif
1806 #else
1807             evdw=evdw+evdwij+e_augm
1808 #endif
1809             if (lprn) then
1810             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1811             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1812             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1813      &        restyp(itypi),i,restyp(itypj),j,
1814      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1815      &        chi1,chi2,chip1,chip2,
1816      &        eps1,eps2rt**2,eps3rt**2,
1817      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1818      &        evdwij+e_augm
1819             endif
1820 C Calculate gradient components.
1821             e1=e1*eps1*eps2rt**2*eps3rt**2
1822             fac=-expon*(e1+evdwij)*rij_shift
1823             sigder=fac*sigder
1824             fac=rij*fac-2*expon*rrij*e_augm
1825 C Calculate the radial part of the gradient
1826             gg(1)=xj*fac
1827             gg(2)=yj*fac
1828             gg(3)=zj*fac
1829 C Calculate angular part of the gradient.
1830 #ifdef TSCSC
1831             if (bb(itypi,itypj).gt.0) then
1832                call sc_grad
1833             else
1834                call sc_grad_T
1835             endif
1836 #else
1837             call sc_grad
1838 #endif
1839           enddo      ! j
1840         enddo        ! iint
1841       enddo          ! i
1842       end
1843 C-----------------------------------------------------------------------------
1844       subroutine sc_angular
1845 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1846 C om12. Called by ebp, egb, and egbv.
1847       implicit none
1848       include 'COMMON.CALC'
1849       include 'COMMON.IOUNITS'
1850       erij(1)=xj*rij
1851       erij(2)=yj*rij
1852       erij(3)=zj*rij
1853       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1854       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1855       om12=dxi*dxj+dyi*dyj+dzi*dzj
1856       chiom12=chi12*om12
1857 C Calculate eps1(om12) and its derivative in om12
1858       faceps1=1.0D0-om12*chiom12
1859       faceps1_inv=1.0D0/faceps1
1860       eps1=dsqrt(faceps1_inv)
1861 C Following variable is eps1*deps1/dom12
1862       eps1_om12=faceps1_inv*chiom12
1863 c diagnostics only
1864 c      faceps1_inv=om12
1865 c      eps1=om12
1866 c      eps1_om12=1.0d0
1867 c      write (iout,*) "om12",om12," eps1",eps1
1868 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1869 C and om12.
1870       om1om2=om1*om2
1871       chiom1=chi1*om1
1872       chiom2=chi2*om2
1873       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1874       sigsq=1.0D0-facsig*faceps1_inv
1875       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1876       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1877       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1878 c diagnostics only
1879 c      sigsq=1.0d0
1880 c      sigsq_om1=0.0d0
1881 c      sigsq_om2=0.0d0
1882 c      sigsq_om12=0.0d0
1883 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1884 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1885 c     &    " eps1",eps1
1886 C Calculate eps2 and its derivatives in om1, om2, and om12.
1887       chipom1=chip1*om1
1888       chipom2=chip2*om2
1889       chipom12=chip12*om12
1890       facp=1.0D0-om12*chipom12
1891       facp_inv=1.0D0/facp
1892       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1893 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1894 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1895 C Following variable is the square root of eps2
1896       eps2rt=1.0D0-facp1*facp_inv
1897 C Following three variables are the derivatives of the square root of eps
1898 C in om1, om2, and om12.
1899       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1900       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1901       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1902 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1903       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1904 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1905 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1906 c     &  " eps2rt_om12",eps2rt_om12
1907 C Calculate whole angle-dependent part of epsilon and contributions
1908 C to its derivatives
1909       return
1910       end
1911
1912 C----------------------------------------------------------------------------
1913       subroutine sc_grad_T
1914       implicit real*8 (a-h,o-z)
1915       include 'DIMENSIONS'
1916       include 'COMMON.CHAIN'
1917       include 'COMMON.DERIV'
1918       include 'COMMON.CALC'
1919       include 'COMMON.IOUNITS'
1920       double precision dcosom1(3),dcosom2(3)
1921       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1922       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1923       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1924      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1925 c diagnostics only
1926 c      eom1=0.0d0
1927 c      eom2=0.0d0
1928 c      eom12=evdwij*eps1_om12
1929 c end diagnostics
1930 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1931 c     &  " sigder",sigder
1932 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1933 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1934       do k=1,3
1935         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1936         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1937       enddo
1938       do k=1,3
1939         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1940       enddo
1941 c      write (iout,*) "gg",(gg(k),k=1,3)
1942       do k=1,3
1943         gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1944      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1945      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1946         gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1947      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1948      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1949 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1950 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1951 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1952 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1953       enddo
1954 C
1955 C Calculate the components of the gradient in DC and X
1956 C
1957 cgrad      do k=i,j-1
1958 cgrad        do l=1,3
1959 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1960 cgrad        enddo
1961 cgrad      enddo
1962       do l=1,3
1963         gvdwcT(l,i)=gvdwcT(l,i)-gg(l)
1964         gvdwcT(l,j)=gvdwcT(l,j)+gg(l)
1965       enddo
1966       return
1967       end
1968
1969 C----------------------------------------------------------------------------
1970       subroutine sc_grad
1971       implicit real*8 (a-h,o-z)
1972       include 'DIMENSIONS'
1973       include 'COMMON.CHAIN'
1974       include 'COMMON.DERIV'
1975       include 'COMMON.CALC'
1976       include 'COMMON.IOUNITS'
1977       double precision dcosom1(3),dcosom2(3)
1978       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1979       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1980       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1981      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1982 c diagnostics only
1983 c      eom1=0.0d0
1984 c      eom2=0.0d0
1985 c      eom12=evdwij*eps1_om12
1986 c end diagnostics
1987 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1988 c     &  " sigder",sigder
1989 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1990 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1991       do k=1,3
1992         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1993         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1994       enddo
1995       do k=1,3
1996         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1997       enddo
1998 c      write (iout,*) "gg",(gg(k),k=1,3)
1999       do k=1,3
2000         gvdwx(k,i)=gvdwx(k,i)-gg(k)
2001      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2002      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2003         gvdwx(k,j)=gvdwx(k,j)+gg(k)
2004      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2005      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2006 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2007 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2008 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2009 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2010       enddo
2011 C
2012 C Calculate the components of the gradient in DC and X
2013 C
2014 cgrad      do k=i,j-1
2015 cgrad        do l=1,3
2016 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2017 cgrad        enddo
2018 cgrad      enddo
2019       do l=1,3
2020         gvdwc(l,i)=gvdwc(l,i)-gg(l)
2021         gvdwc(l,j)=gvdwc(l,j)+gg(l)
2022       enddo
2023       return
2024       end
2025 C-----------------------------------------------------------------------
2026       subroutine e_softsphere(evdw)
2027 C
2028 C This subroutine calculates the interaction energy of nonbonded side chains
2029 C assuming the LJ potential of interaction.
2030 C
2031       implicit real*8 (a-h,o-z)
2032       include 'DIMENSIONS'
2033       parameter (accur=1.0d-10)
2034       include 'COMMON.GEO'
2035       include 'COMMON.VAR'
2036       include 'COMMON.LOCAL'
2037       include 'COMMON.CHAIN'
2038       include 'COMMON.DERIV'
2039       include 'COMMON.INTERACT'
2040       include 'COMMON.TORSION'
2041       include 'COMMON.SBRIDGE'
2042       include 'COMMON.NAMES'
2043       include 'COMMON.IOUNITS'
2044       include 'COMMON.CONTACTS'
2045       dimension gg(3)
2046 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2047       evdw=0.0D0
2048       do i=iatsc_s,iatsc_e
2049         itypi=itype(i)
2050         itypi1=itype(i+1)
2051         xi=c(1,nres+i)
2052         yi=c(2,nres+i)
2053         zi=c(3,nres+i)
2054 C
2055 C Calculate SC interaction energy.
2056 C
2057         do iint=1,nint_gr(i)
2058 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2059 cd   &                  'iend=',iend(i,iint)
2060           do j=istart(i,iint),iend(i,iint)
2061             itypj=itype(j)
2062             xj=c(1,nres+j)-xi
2063             yj=c(2,nres+j)-yi
2064             zj=c(3,nres+j)-zi
2065             rij=xj*xj+yj*yj+zj*zj
2066 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2067             r0ij=r0(itypi,itypj)
2068             r0ijsq=r0ij*r0ij
2069 c            print *,i,j,r0ij,dsqrt(rij)
2070             if (rij.lt.r0ijsq) then
2071               evdwij=0.25d0*(rij-r0ijsq)**2
2072               fac=rij-r0ijsq
2073             else
2074               evdwij=0.0d0
2075               fac=0.0d0
2076             endif
2077             evdw=evdw+evdwij
2078 C
2079 C Calculate the components of the gradient in DC and X
2080 C
2081             gg(1)=xj*fac
2082             gg(2)=yj*fac
2083             gg(3)=zj*fac
2084             do k=1,3
2085               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2086               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2087               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2088               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2089             enddo
2090 cgrad            do k=i,j-1
2091 cgrad              do l=1,3
2092 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2093 cgrad              enddo
2094 cgrad            enddo
2095           enddo ! j
2096         enddo ! iint
2097       enddo ! i
2098       return
2099       end
2100 C--------------------------------------------------------------------------
2101       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2102      &              eello_turn4)
2103 C
2104 C Soft-sphere potential of p-p interaction
2105 C
2106       implicit real*8 (a-h,o-z)
2107       include 'DIMENSIONS'
2108       include 'COMMON.CONTROL'
2109       include 'COMMON.IOUNITS'
2110       include 'COMMON.GEO'
2111       include 'COMMON.VAR'
2112       include 'COMMON.LOCAL'
2113       include 'COMMON.CHAIN'
2114       include 'COMMON.DERIV'
2115       include 'COMMON.INTERACT'
2116       include 'COMMON.CONTACTS'
2117       include 'COMMON.TORSION'
2118       include 'COMMON.VECTORS'
2119       include 'COMMON.FFIELD'
2120       dimension ggg(3)
2121 cd      write(iout,*) 'In EELEC_soft_sphere'
2122       ees=0.0D0
2123       evdw1=0.0D0
2124       eel_loc=0.0d0
2125       eello_turn3=0.0d0
2126       eello_turn4=0.0d0
2127       ind=0
2128       do i=iatel_s,iatel_e
2129         dxi=dc(1,i)
2130         dyi=dc(2,i)
2131         dzi=dc(3,i)
2132         xmedi=c(1,i)+0.5d0*dxi
2133         ymedi=c(2,i)+0.5d0*dyi
2134         zmedi=c(3,i)+0.5d0*dzi
2135         num_conti=0
2136 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2137         do j=ielstart(i),ielend(i)
2138           ind=ind+1
2139           iteli=itel(i)
2140           itelj=itel(j)
2141           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2142           r0ij=rpp(iteli,itelj)
2143           r0ijsq=r0ij*r0ij
2144           dxj=dc(1,j)
2145           dyj=dc(2,j)
2146           dzj=dc(3,j)
2147           xj=c(1,j)+0.5D0*dxj-xmedi
2148           yj=c(2,j)+0.5D0*dyj-ymedi
2149           zj=c(3,j)+0.5D0*dzj-zmedi
2150           rij=xj*xj+yj*yj+zj*zj
2151           if (rij.lt.r0ijsq) then
2152             evdw1ij=0.25d0*(rij-r0ijsq)**2
2153             fac=rij-r0ijsq
2154           else
2155             evdw1ij=0.0d0
2156             fac=0.0d0
2157           endif
2158           evdw1=evdw1+evdw1ij
2159 C
2160 C Calculate contributions to the Cartesian gradient.
2161 C
2162           ggg(1)=fac*xj
2163           ggg(2)=fac*yj
2164           ggg(3)=fac*zj
2165           do k=1,3
2166             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2167             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2168           enddo
2169 *
2170 * Loop over residues i+1 thru j-1.
2171 *
2172 cgrad          do k=i+1,j-1
2173 cgrad            do l=1,3
2174 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2175 cgrad            enddo
2176 cgrad          enddo
2177         enddo ! j
2178       enddo   ! i
2179 cgrad      do i=nnt,nct-1
2180 cgrad        do k=1,3
2181 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2182 cgrad        enddo
2183 cgrad        do j=i+1,nct-1
2184 cgrad          do k=1,3
2185 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2186 cgrad          enddo
2187 cgrad        enddo
2188 cgrad      enddo
2189       return
2190       end
2191 c------------------------------------------------------------------------------
2192       subroutine vec_and_deriv
2193       implicit real*8 (a-h,o-z)
2194       include 'DIMENSIONS'
2195 #ifdef MPI
2196       include 'mpif.h'
2197 #endif
2198       include 'COMMON.IOUNITS'
2199       include 'COMMON.GEO'
2200       include 'COMMON.VAR'
2201       include 'COMMON.LOCAL'
2202       include 'COMMON.CHAIN'
2203       include 'COMMON.VECTORS'
2204       include 'COMMON.SETUP'
2205       include 'COMMON.TIME1'
2206       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2207 C Compute the local reference systems. For reference system (i), the
2208 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2209 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2210 #ifdef PARVEC
2211       do i=ivec_start,ivec_end
2212 #else
2213       do i=1,nres-1
2214 #endif
2215           if (i.eq.nres-1) then
2216 C Case of the last full residue
2217 C Compute the Z-axis
2218             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2219             costh=dcos(pi-theta(nres))
2220             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2221             do k=1,3
2222               uz(k,i)=fac*uz(k,i)
2223             enddo
2224 C Compute the derivatives of uz
2225             uzder(1,1,1)= 0.0d0
2226             uzder(2,1,1)=-dc_norm(3,i-1)
2227             uzder(3,1,1)= dc_norm(2,i-1)
2228             uzder(1,2,1)= dc_norm(3,i-1)
2229             uzder(2,2,1)= 0.0d0
2230             uzder(3,2,1)=-dc_norm(1,i-1)
2231             uzder(1,3,1)=-dc_norm(2,i-1)
2232             uzder(2,3,1)= dc_norm(1,i-1)
2233             uzder(3,3,1)= 0.0d0
2234             uzder(1,1,2)= 0.0d0
2235             uzder(2,1,2)= dc_norm(3,i)
2236             uzder(3,1,2)=-dc_norm(2,i)
2237             uzder(1,2,2)=-dc_norm(3,i)
2238             uzder(2,2,2)= 0.0d0
2239             uzder(3,2,2)= dc_norm(1,i)
2240             uzder(1,3,2)= dc_norm(2,i)
2241             uzder(2,3,2)=-dc_norm(1,i)
2242             uzder(3,3,2)= 0.0d0
2243 C Compute the Y-axis
2244             facy=fac
2245             do k=1,3
2246               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2247             enddo
2248 C Compute the derivatives of uy
2249             do j=1,3
2250               do k=1,3
2251                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2252      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2253                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2254               enddo
2255               uyder(j,j,1)=uyder(j,j,1)-costh
2256               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2257             enddo
2258             do j=1,2
2259               do k=1,3
2260                 do l=1,3
2261                   uygrad(l,k,j,i)=uyder(l,k,j)
2262                   uzgrad(l,k,j,i)=uzder(l,k,j)
2263                 enddo
2264               enddo
2265             enddo
2266             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2267             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2268             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2269             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2270           else
2271 C Other residues
2272 C Compute the Z-axis
2273             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2274             costh=dcos(pi-theta(i+2))
2275             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2276             do k=1,3
2277               uz(k,i)=fac*uz(k,i)
2278             enddo
2279 C Compute the derivatives of uz
2280             uzder(1,1,1)= 0.0d0
2281             uzder(2,1,1)=-dc_norm(3,i+1)
2282             uzder(3,1,1)= dc_norm(2,i+1)
2283             uzder(1,2,1)= dc_norm(3,i+1)
2284             uzder(2,2,1)= 0.0d0
2285             uzder(3,2,1)=-dc_norm(1,i+1)
2286             uzder(1,3,1)=-dc_norm(2,i+1)
2287             uzder(2,3,1)= dc_norm(1,i+1)
2288             uzder(3,3,1)= 0.0d0
2289             uzder(1,1,2)= 0.0d0
2290             uzder(2,1,2)= dc_norm(3,i)
2291             uzder(3,1,2)=-dc_norm(2,i)
2292             uzder(1,2,2)=-dc_norm(3,i)
2293             uzder(2,2,2)= 0.0d0
2294             uzder(3,2,2)= dc_norm(1,i)
2295             uzder(1,3,2)= dc_norm(2,i)
2296             uzder(2,3,2)=-dc_norm(1,i)
2297             uzder(3,3,2)= 0.0d0
2298 C Compute the Y-axis
2299             facy=fac
2300             do k=1,3
2301               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2302             enddo
2303 C Compute the derivatives of uy
2304             do j=1,3
2305               do k=1,3
2306                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2307      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2308                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2309               enddo
2310               uyder(j,j,1)=uyder(j,j,1)-costh
2311               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2312             enddo
2313             do j=1,2
2314               do k=1,3
2315                 do l=1,3
2316                   uygrad(l,k,j,i)=uyder(l,k,j)
2317                   uzgrad(l,k,j,i)=uzder(l,k,j)
2318                 enddo
2319               enddo
2320             enddo
2321             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2322             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2323             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2324             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2325           endif
2326       enddo
2327       do i=1,nres-1
2328         vbld_inv_temp(1)=vbld_inv(i+1)
2329         if (i.lt.nres-1) then
2330           vbld_inv_temp(2)=vbld_inv(i+2)
2331           else
2332           vbld_inv_temp(2)=vbld_inv(i)
2333           endif
2334         do j=1,2
2335           do k=1,3
2336             do l=1,3
2337               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2338               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2339             enddo
2340           enddo
2341         enddo
2342       enddo
2343 #if defined(PARVEC) && defined(MPI)
2344       if (nfgtasks1.gt.1) then
2345         time00=MPI_Wtime()
2346 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2347 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2348 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2349         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2350      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2351      &   FG_COMM1,IERR)
2352         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2353      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2354      &   FG_COMM1,IERR)
2355         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2356      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2357      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2358         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2359      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2360      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2361         time_gather=time_gather+MPI_Wtime()-time00
2362       endif
2363 c      if (fg_rank.eq.0) then
2364 c        write (iout,*) "Arrays UY and UZ"
2365 c        do i=1,nres-1
2366 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2367 c     &     (uz(k,i),k=1,3)
2368 c        enddo
2369 c      endif
2370 #endif
2371       return
2372       end
2373 C-----------------------------------------------------------------------------
2374       subroutine check_vecgrad
2375       implicit real*8 (a-h,o-z)
2376       include 'DIMENSIONS'
2377       include 'COMMON.IOUNITS'
2378       include 'COMMON.GEO'
2379       include 'COMMON.VAR'
2380       include 'COMMON.LOCAL'
2381       include 'COMMON.CHAIN'
2382       include 'COMMON.VECTORS'
2383       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2384       dimension uyt(3,maxres),uzt(3,maxres)
2385       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2386       double precision delta /1.0d-7/
2387       call vec_and_deriv
2388 cd      do i=1,nres
2389 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2390 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2391 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2392 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2393 cd     &     (dc_norm(if90,i),if90=1,3)
2394 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2395 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2396 cd          write(iout,'(a)')
2397 cd      enddo
2398       do i=1,nres
2399         do j=1,2
2400           do k=1,3
2401             do l=1,3
2402               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2403               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2404             enddo
2405           enddo
2406         enddo
2407       enddo
2408       call vec_and_deriv
2409       do i=1,nres
2410         do j=1,3
2411           uyt(j,i)=uy(j,i)
2412           uzt(j,i)=uz(j,i)
2413         enddo
2414       enddo
2415       do i=1,nres
2416 cd        write (iout,*) 'i=',i
2417         do k=1,3
2418           erij(k)=dc_norm(k,i)
2419         enddo
2420         do j=1,3
2421           do k=1,3
2422             dc_norm(k,i)=erij(k)
2423           enddo
2424           dc_norm(j,i)=dc_norm(j,i)+delta
2425 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2426 c          do k=1,3
2427 c            dc_norm(k,i)=dc_norm(k,i)/fac
2428 c          enddo
2429 c          write (iout,*) (dc_norm(k,i),k=1,3)
2430 c          write (iout,*) (erij(k),k=1,3)
2431           call vec_and_deriv
2432           do k=1,3
2433             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2434             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2435             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2436             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2437           enddo
2438 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2439 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2440 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2441         enddo
2442         do k=1,3
2443           dc_norm(k,i)=erij(k)
2444         enddo
2445 cd        do k=1,3
2446 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2447 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2448 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2449 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2450 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2451 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2452 cd          write (iout,'(a)')
2453 cd        enddo
2454       enddo
2455       return
2456       end
2457 C--------------------------------------------------------------------------
2458       subroutine set_matrices
2459       implicit real*8 (a-h,o-z)
2460       include 'DIMENSIONS'
2461 #ifdef MPI
2462       include "mpif.h"
2463       include "COMMON.SETUP"
2464       integer IERR
2465       integer status(MPI_STATUS_SIZE)
2466 #endif
2467       include 'COMMON.IOUNITS'
2468       include 'COMMON.GEO'
2469       include 'COMMON.VAR'
2470       include 'COMMON.LOCAL'
2471       include 'COMMON.CHAIN'
2472       include 'COMMON.DERIV'
2473       include 'COMMON.INTERACT'
2474       include 'COMMON.CONTACTS'
2475       include 'COMMON.TORSION'
2476       include 'COMMON.VECTORS'
2477       include 'COMMON.FFIELD'
2478       double precision auxvec(2),auxmat(2,2)
2479 C
2480 C Compute the virtual-bond-torsional-angle dependent quantities needed
2481 C to calculate the el-loc multibody terms of various order.
2482 C
2483 #ifdef PARMAT
2484       do i=ivec_start+2,ivec_end+2
2485 #else
2486       do i=3,nres+1
2487 #endif
2488         if (i .lt. nres+1) then
2489           sin1=dsin(phi(i))
2490           cos1=dcos(phi(i))
2491           sintab(i-2)=sin1
2492           costab(i-2)=cos1
2493           obrot(1,i-2)=cos1
2494           obrot(2,i-2)=sin1
2495           sin2=dsin(2*phi(i))
2496           cos2=dcos(2*phi(i))
2497           sintab2(i-2)=sin2
2498           costab2(i-2)=cos2
2499           obrot2(1,i-2)=cos2
2500           obrot2(2,i-2)=sin2
2501           Ug(1,1,i-2)=-cos1
2502           Ug(1,2,i-2)=-sin1
2503           Ug(2,1,i-2)=-sin1
2504           Ug(2,2,i-2)= cos1
2505           Ug2(1,1,i-2)=-cos2
2506           Ug2(1,2,i-2)=-sin2
2507           Ug2(2,1,i-2)=-sin2
2508           Ug2(2,2,i-2)= cos2
2509         else
2510           costab(i-2)=1.0d0
2511           sintab(i-2)=0.0d0
2512           obrot(1,i-2)=1.0d0
2513           obrot(2,i-2)=0.0d0
2514           obrot2(1,i-2)=0.0d0
2515           obrot2(2,i-2)=0.0d0
2516           Ug(1,1,i-2)=1.0d0
2517           Ug(1,2,i-2)=0.0d0
2518           Ug(2,1,i-2)=0.0d0
2519           Ug(2,2,i-2)=1.0d0
2520           Ug2(1,1,i-2)=0.0d0
2521           Ug2(1,2,i-2)=0.0d0
2522           Ug2(2,1,i-2)=0.0d0
2523           Ug2(2,2,i-2)=0.0d0
2524         endif
2525         if (i .gt. 3 .and. i .lt. nres+1) then
2526           obrot_der(1,i-2)=-sin1
2527           obrot_der(2,i-2)= cos1
2528           Ugder(1,1,i-2)= sin1
2529           Ugder(1,2,i-2)=-cos1
2530           Ugder(2,1,i-2)=-cos1
2531           Ugder(2,2,i-2)=-sin1
2532           dwacos2=cos2+cos2
2533           dwasin2=sin2+sin2
2534           obrot2_der(1,i-2)=-dwasin2
2535           obrot2_der(2,i-2)= dwacos2
2536           Ug2der(1,1,i-2)= dwasin2
2537           Ug2der(1,2,i-2)=-dwacos2
2538           Ug2der(2,1,i-2)=-dwacos2
2539           Ug2der(2,2,i-2)=-dwasin2
2540         else
2541           obrot_der(1,i-2)=0.0d0
2542           obrot_der(2,i-2)=0.0d0
2543           Ugder(1,1,i-2)=0.0d0
2544           Ugder(1,2,i-2)=0.0d0
2545           Ugder(2,1,i-2)=0.0d0
2546           Ugder(2,2,i-2)=0.0d0
2547           obrot2_der(1,i-2)=0.0d0
2548           obrot2_der(2,i-2)=0.0d0
2549           Ug2der(1,1,i-2)=0.0d0
2550           Ug2der(1,2,i-2)=0.0d0
2551           Ug2der(2,1,i-2)=0.0d0
2552           Ug2der(2,2,i-2)=0.0d0
2553         endif
2554 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2555         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2556           iti = itortyp(itype(i-2))
2557         else
2558           iti=ntortyp+1
2559         endif
2560 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2561         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2562           iti1 = itortyp(itype(i-1))
2563         else
2564           iti1=ntortyp+1
2565         endif
2566 cd        write (iout,*) '*******i',i,' iti1',iti
2567 cd        write (iout,*) 'b1',b1(:,iti)
2568 cd        write (iout,*) 'b2',b2(:,iti)
2569 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2570 c        if (i .gt. iatel_s+2) then
2571         if (i .gt. nnt+2) then
2572           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2573           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2574           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2575      &    then
2576           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2577           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2578           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2579           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2580           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2581           endif
2582         else
2583           do k=1,2
2584             Ub2(k,i-2)=0.0d0
2585             Ctobr(k,i-2)=0.0d0
2586             Dtobr2(k,i-2)=0.0d0
2587             do l=1,2
2588               EUg(l,k,i-2)=0.0d0
2589               CUg(l,k,i-2)=0.0d0
2590               DUg(l,k,i-2)=0.0d0
2591               DtUg2(l,k,i-2)=0.0d0
2592             enddo
2593           enddo
2594         endif
2595         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2596         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2597         do k=1,2
2598           muder(k,i-2)=Ub2der(k,i-2)
2599         enddo
2600 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2601         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2602           iti1 = itortyp(itype(i-1))
2603         else
2604           iti1=ntortyp+1
2605         endif
2606         do k=1,2
2607           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2608         enddo
2609 cd        write (iout,*) 'mu ',mu(:,i-2)
2610 cd        write (iout,*) 'mu1',mu1(:,i-2)
2611 cd        write (iout,*) 'mu2',mu2(:,i-2)
2612         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2613      &  then
2614         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2615         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2616         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2617         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2618         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2619 C Vectors and matrices dependent on a single virtual-bond dihedral.
2620         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2621         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2622         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2623         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2624         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2625         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2626         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2627         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2628         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2629         endif
2630       enddo
2631 C Matrices dependent on two consecutive virtual-bond dihedrals.
2632 C The order of matrices is from left to right.
2633       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2634      &then
2635 c      do i=max0(ivec_start,2),ivec_end
2636       do i=2,nres-1
2637         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2638         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2639         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2640         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2641         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2642         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2643         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2644         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2645       enddo
2646       endif
2647 #if defined(MPI) && defined(PARMAT)
2648 #ifdef DEBUG
2649 c      if (fg_rank.eq.0) then
2650         write (iout,*) "Arrays UG and UGDER before GATHER"
2651         do i=1,nres-1
2652           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2653      &     ((ug(l,k,i),l=1,2),k=1,2),
2654      &     ((ugder(l,k,i),l=1,2),k=1,2)
2655         enddo
2656         write (iout,*) "Arrays UG2 and UG2DER"
2657         do i=1,nres-1
2658           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2659      &     ((ug2(l,k,i),l=1,2),k=1,2),
2660      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2661         enddo
2662         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2663         do i=1,nres-1
2664           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2665      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2666      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2667         enddo
2668         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2669         do i=1,nres-1
2670           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2671      &     costab(i),sintab(i),costab2(i),sintab2(i)
2672         enddo
2673         write (iout,*) "Array MUDER"
2674         do i=1,nres-1
2675           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2676         enddo
2677 c      endif
2678 #endif
2679       if (nfgtasks.gt.1) then
2680         time00=MPI_Wtime()
2681 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2682 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2683 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2684 #ifdef MATGATHER
2685         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2686      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2687      &   FG_COMM1,IERR)
2688         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2689      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2690      &   FG_COMM1,IERR)
2691         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2692      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2693      &   FG_COMM1,IERR)
2694         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2695      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2696      &   FG_COMM1,IERR)
2697         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2698      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2699      &   FG_COMM1,IERR)
2700         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2701      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2702      &   FG_COMM1,IERR)
2703         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2704      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2705      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2706         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2707      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2708      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2709         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2710      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2711      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2712         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2713      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2714      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2715         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2716      &  then
2717         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2718      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2719      &   FG_COMM1,IERR)
2720         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2721      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2722      &   FG_COMM1,IERR)
2723         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2724      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2725      &   FG_COMM1,IERR)
2726        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2727      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2728      &   FG_COMM1,IERR)
2729         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2730      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2731      &   FG_COMM1,IERR)
2732         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2733      &   ivec_count(fg_rank1),
2734      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2735      &   FG_COMM1,IERR)
2736         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2737      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2738      &   FG_COMM1,IERR)
2739         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2740      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2741      &   FG_COMM1,IERR)
2742         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2743      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2744      &   FG_COMM1,IERR)
2745         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2746      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2747      &   FG_COMM1,IERR)
2748         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2749      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2750      &   FG_COMM1,IERR)
2751         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2752      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2753      &   FG_COMM1,IERR)
2754         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2755      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2756      &   FG_COMM1,IERR)
2757         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2758      &   ivec_count(fg_rank1),
2759      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2760      &   FG_COMM1,IERR)
2761         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2762      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2763      &   FG_COMM1,IERR)
2764        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2765      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2766      &   FG_COMM1,IERR)
2767         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2768      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2769      &   FG_COMM1,IERR)
2770        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2771      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2772      &   FG_COMM1,IERR)
2773         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2774      &   ivec_count(fg_rank1),
2775      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2776      &   FG_COMM1,IERR)
2777         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2778      &   ivec_count(fg_rank1),
2779      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2780      &   FG_COMM1,IERR)
2781         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2782      &   ivec_count(fg_rank1),
2783      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2784      &   MPI_MAT2,FG_COMM1,IERR)
2785         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2786      &   ivec_count(fg_rank1),
2787      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2788      &   MPI_MAT2,FG_COMM1,IERR)
2789         endif
2790 #else
2791 c Passes matrix info through the ring
2792       isend=fg_rank1
2793       irecv=fg_rank1-1
2794       if (irecv.lt.0) irecv=nfgtasks1-1
2795       iprev=irecv
2796       inext=fg_rank1+1
2797       if (inext.ge.nfgtasks1) inext=0
2798       do i=1,nfgtasks1-1
2799 c        write (iout,*) "isend",isend," irecv",irecv
2800 c        call flush(iout)
2801         lensend=lentyp(isend)
2802         lenrecv=lentyp(irecv)
2803 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2804 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2805 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2806 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2807 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2808 c        write (iout,*) "Gather ROTAT1"
2809 c        call flush(iout)
2810 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2811 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2812 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2813 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2814 c        write (iout,*) "Gather ROTAT2"
2815 c        call flush(iout)
2816         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2817      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2818      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2819      &   iprev,4400+irecv,FG_COMM,status,IERR)
2820 c        write (iout,*) "Gather ROTAT_OLD"
2821 c        call flush(iout)
2822         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2823      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2824      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2825      &   iprev,5500+irecv,FG_COMM,status,IERR)
2826 c        write (iout,*) "Gather PRECOMP11"
2827 c        call flush(iout)
2828         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2829      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2830      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2831      &   iprev,6600+irecv,FG_COMM,status,IERR)
2832 c        write (iout,*) "Gather PRECOMP12"
2833 c        call flush(iout)
2834         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2835      &  then
2836         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2837      &   MPI_ROTAT2(lensend),inext,7700+isend,
2838      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2839      &   iprev,7700+irecv,FG_COMM,status,IERR)
2840 c        write (iout,*) "Gather PRECOMP21"
2841 c        call flush(iout)
2842         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2843      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2844      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2845      &   iprev,8800+irecv,FG_COMM,status,IERR)
2846 c        write (iout,*) "Gather PRECOMP22"
2847 c        call flush(iout)
2848         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2849      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2850      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2851      &   MPI_PRECOMP23(lenrecv),
2852      &   iprev,9900+irecv,FG_COMM,status,IERR)
2853 c        write (iout,*) "Gather PRECOMP23"
2854 c        call flush(iout)
2855         endif
2856         isend=irecv
2857         irecv=irecv-1
2858         if (irecv.lt.0) irecv=nfgtasks1-1
2859       enddo
2860 #endif
2861         time_gather=time_gather+MPI_Wtime()-time00
2862       endif
2863 #ifdef DEBUG
2864 c      if (fg_rank.eq.0) then
2865         write (iout,*) "Arrays UG and UGDER"
2866         do i=1,nres-1
2867           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2868      &     ((ug(l,k,i),l=1,2),k=1,2),
2869      &     ((ugder(l,k,i),l=1,2),k=1,2)
2870         enddo
2871         write (iout,*) "Arrays UG2 and UG2DER"
2872         do i=1,nres-1
2873           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2874      &     ((ug2(l,k,i),l=1,2),k=1,2),
2875      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2876         enddo
2877         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2878         do i=1,nres-1
2879           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2880      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2881      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2882         enddo
2883         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2884         do i=1,nres-1
2885           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2886      &     costab(i),sintab(i),costab2(i),sintab2(i)
2887         enddo
2888         write (iout,*) "Array MUDER"
2889         do i=1,nres-1
2890           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2891         enddo
2892 c      endif
2893 #endif
2894 #endif
2895 cd      do i=1,nres
2896 cd        iti = itortyp(itype(i))
2897 cd        write (iout,*) i
2898 cd        do j=1,2
2899 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2900 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2901 cd        enddo
2902 cd      enddo
2903       return
2904       end
2905 C--------------------------------------------------------------------------
2906       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2907 C
2908 C This subroutine calculates the average interaction energy and its gradient
2909 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2910 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2911 C The potential depends both on the distance of peptide-group centers and on
2912 C the orientation of the CA-CA virtual bonds.
2913 C
2914       implicit real*8 (a-h,o-z)
2915 #ifdef MPI
2916       include 'mpif.h'
2917 #endif
2918       include 'DIMENSIONS'
2919       include 'COMMON.CONTROL'
2920       include 'COMMON.SETUP'
2921       include 'COMMON.IOUNITS'
2922       include 'COMMON.GEO'
2923       include 'COMMON.VAR'
2924       include 'COMMON.LOCAL'
2925       include 'COMMON.CHAIN'
2926       include 'COMMON.DERIV'
2927       include 'COMMON.INTERACT'
2928       include 'COMMON.CONTACTS'
2929       include 'COMMON.TORSION'
2930       include 'COMMON.VECTORS'
2931       include 'COMMON.FFIELD'
2932       include 'COMMON.TIME1'
2933       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2934      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2935       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2936      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2937       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2938      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2939      &    num_conti,j1,j2
2940 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2941 #ifdef MOMENT
2942       double precision scal_el /1.0d0/
2943 #else
2944       double precision scal_el /0.5d0/
2945 #endif
2946 C 12/13/98
2947 C 13-go grudnia roku pamietnego...
2948       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2949      &                   0.0d0,1.0d0,0.0d0,
2950      &                   0.0d0,0.0d0,1.0d0/
2951 cd      write(iout,*) 'In EELEC'
2952 cd      do i=1,nloctyp
2953 cd        write(iout,*) 'Type',i
2954 cd        write(iout,*) 'B1',B1(:,i)
2955 cd        write(iout,*) 'B2',B2(:,i)
2956 cd        write(iout,*) 'CC',CC(:,:,i)
2957 cd        write(iout,*) 'DD',DD(:,:,i)
2958 cd        write(iout,*) 'EE',EE(:,:,i)
2959 cd      enddo
2960 cd      call check_vecgrad
2961 cd      stop
2962       if (icheckgrad.eq.1) then
2963         do i=1,nres-1
2964           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2965           do k=1,3
2966             dc_norm(k,i)=dc(k,i)*fac
2967           enddo
2968 c          write (iout,*) 'i',i,' fac',fac
2969         enddo
2970       endif
2971       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2972      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2973      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2974 c        call vec_and_deriv
2975 #ifdef TIMING
2976         time01=MPI_Wtime()
2977 #endif
2978         call set_matrices
2979 #ifdef TIMING
2980         time_mat=time_mat+MPI_Wtime()-time01
2981 #endif
2982       endif
2983 cd      do i=1,nres-1
2984 cd        write (iout,*) 'i=',i
2985 cd        do k=1,3
2986 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2987 cd        enddo
2988 cd        do k=1,3
2989 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2990 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2991 cd        enddo
2992 cd      enddo
2993       t_eelecij=0.0d0
2994       ees=0.0D0
2995       evdw1=0.0D0
2996       eel_loc=0.0d0
2997       eello_turn3=0.0d0
2998       eello_turn4=0.0d0
2999       ind=0
3000       do i=1,nres
3001         num_cont_hb(i)=0
3002       enddo
3003 cd      print '(a)','Enter EELEC'
3004 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3005       do i=1,nres
3006         gel_loc_loc(i)=0.0d0
3007         gcorr_loc(i)=0.0d0
3008       enddo
3009 c
3010 c
3011 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3012 C
3013 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3014 C
3015       do i=iturn3_start,iturn3_end
3016         dxi=dc(1,i)
3017         dyi=dc(2,i)
3018         dzi=dc(3,i)
3019         dx_normi=dc_norm(1,i)
3020         dy_normi=dc_norm(2,i)
3021         dz_normi=dc_norm(3,i)
3022         xmedi=c(1,i)+0.5d0*dxi
3023         ymedi=c(2,i)+0.5d0*dyi
3024         zmedi=c(3,i)+0.5d0*dzi
3025         num_conti=0
3026         call eelecij(i,i+2,ees,evdw1,eel_loc)
3027         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3028         num_cont_hb(i)=num_conti
3029       enddo
3030       do i=iturn4_start,iturn4_end
3031         dxi=dc(1,i)
3032         dyi=dc(2,i)
3033         dzi=dc(3,i)
3034         dx_normi=dc_norm(1,i)
3035         dy_normi=dc_norm(2,i)
3036         dz_normi=dc_norm(3,i)
3037         xmedi=c(1,i)+0.5d0*dxi
3038         ymedi=c(2,i)+0.5d0*dyi
3039         zmedi=c(3,i)+0.5d0*dzi
3040         num_conti=num_cont_hb(i)
3041         call eelecij(i,i+3,ees,evdw1,eel_loc)
3042         if (wturn4.gt.0.0d0) call eturn4(i,eello_turn4)
3043         num_cont_hb(i)=num_conti
3044       enddo   ! i
3045 c
3046 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3047 c
3048       do i=iatel_s,iatel_e
3049         dxi=dc(1,i)
3050         dyi=dc(2,i)
3051         dzi=dc(3,i)
3052         dx_normi=dc_norm(1,i)
3053         dy_normi=dc_norm(2,i)
3054         dz_normi=dc_norm(3,i)
3055         xmedi=c(1,i)+0.5d0*dxi
3056         ymedi=c(2,i)+0.5d0*dyi
3057         zmedi=c(3,i)+0.5d0*dzi
3058 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3059         num_conti=num_cont_hb(i)
3060         do j=ielstart(i),ielend(i)
3061           call eelecij(i,j,ees,evdw1,eel_loc)
3062         enddo ! j
3063         num_cont_hb(i)=num_conti
3064       enddo   ! i
3065 c      write (iout,*) "Number of loop steps in EELEC:",ind
3066 cd      do i=1,nres
3067 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3068 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3069 cd      enddo
3070 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3071 ccc      eel_loc=eel_loc+eello_turn3
3072 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3073       return
3074       end
3075 C-------------------------------------------------------------------------------
3076       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3077       implicit real*8 (a-h,o-z)
3078       include 'DIMENSIONS'
3079 #ifdef MPI
3080       include "mpif.h"
3081 #endif
3082       include 'COMMON.CONTROL'
3083       include 'COMMON.IOUNITS'
3084       include 'COMMON.GEO'
3085       include 'COMMON.VAR'
3086       include 'COMMON.LOCAL'
3087       include 'COMMON.CHAIN'
3088       include 'COMMON.DERIV'
3089       include 'COMMON.INTERACT'
3090       include 'COMMON.CONTACTS'
3091       include 'COMMON.TORSION'
3092       include 'COMMON.VECTORS'
3093       include 'COMMON.FFIELD'
3094       include 'COMMON.TIME1'
3095       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3096      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3097       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3098      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3099       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3100      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3101      &    num_conti,j1,j2
3102 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3103 #ifdef MOMENT
3104       double precision scal_el /1.0d0/
3105 #else
3106       double precision scal_el /0.5d0/
3107 #endif
3108 C 12/13/98
3109 C 13-go grudnia roku pamietnego...
3110       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3111      &                   0.0d0,1.0d0,0.0d0,
3112      &                   0.0d0,0.0d0,1.0d0/
3113 c          time00=MPI_Wtime()
3114 cd      write (iout,*) "eelecij",i,j
3115 c          ind=ind+1
3116           iteli=itel(i)
3117           itelj=itel(j)
3118           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3119           aaa=app(iteli,itelj)
3120           bbb=bpp(iteli,itelj)
3121           ael6i=ael6(iteli,itelj)
3122           ael3i=ael3(iteli,itelj)
3123           dxj=dc(1,j)
3124           dyj=dc(2,j)
3125           dzj=dc(3,j)
3126           dx_normj=dc_norm(1,j)
3127           dy_normj=dc_norm(2,j)
3128           dz_normj=dc_norm(3,j)
3129           xj=c(1,j)+0.5D0*dxj-xmedi
3130           yj=c(2,j)+0.5D0*dyj-ymedi
3131           zj=c(3,j)+0.5D0*dzj-zmedi
3132           rij=xj*xj+yj*yj+zj*zj
3133           rrmij=1.0D0/rij
3134           rij=dsqrt(rij)
3135           rmij=1.0D0/rij
3136           r3ij=rrmij*rmij
3137           r6ij=r3ij*r3ij
3138           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3139           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3140           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3141           fac=cosa-3.0D0*cosb*cosg
3142           ev1=aaa*r6ij*r6ij
3143 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3144           if (j.eq.i+2) ev1=scal_el*ev1
3145           ev2=bbb*r6ij
3146           fac3=ael6i*r6ij
3147           fac4=ael3i*r3ij
3148           evdwij=ev1+ev2
3149           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3150           el2=fac4*fac
3151           eesij=el1+el2
3152 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3153           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3154           ees=ees+eesij
3155           evdw1=evdw1+evdwij
3156 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3157 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3158 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3159 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3160
3161           if (energy_dec) then
3162               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3163               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3164           endif
3165
3166 C
3167 C Calculate contributions to the Cartesian gradient.
3168 C
3169 #ifdef SPLITELE
3170           facvdw=-6*rrmij*(ev1+evdwij)
3171           facel=-3*rrmij*(el1+eesij)
3172           fac1=fac
3173           erij(1)=xj*rmij
3174           erij(2)=yj*rmij
3175           erij(3)=zj*rmij
3176 *
3177 * Radial derivatives. First process both termini of the fragment (i,j)
3178 *
3179           ggg(1)=facel*xj
3180           ggg(2)=facel*yj
3181           ggg(3)=facel*zj
3182 c          do k=1,3
3183 c            ghalf=0.5D0*ggg(k)
3184 c            gelc(k,i)=gelc(k,i)+ghalf
3185 c            gelc(k,j)=gelc(k,j)+ghalf
3186 c          enddo
3187 c 9/28/08 AL Gradient compotents will be summed only at the end
3188           do k=1,3
3189             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3190             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3191           enddo
3192 *
3193 * Loop over residues i+1 thru j-1.
3194 *
3195 cgrad          do k=i+1,j-1
3196 cgrad            do l=1,3
3197 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3198 cgrad            enddo
3199 cgrad          enddo
3200           ggg(1)=facvdw*xj
3201           ggg(2)=facvdw*yj
3202           ggg(3)=facvdw*zj
3203 c          do k=1,3
3204 c            ghalf=0.5D0*ggg(k)
3205 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3206 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3207 c          enddo
3208 c 9/28/08 AL Gradient compotents will be summed only at the end
3209           do k=1,3
3210             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3211             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3212           enddo
3213 *
3214 * Loop over residues i+1 thru j-1.
3215 *
3216 cgrad          do k=i+1,j-1
3217 cgrad            do l=1,3
3218 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3219 cgrad            enddo
3220 cgrad          enddo
3221 #else
3222           facvdw=ev1+evdwij
3223           facel=el1+eesij
3224           fac1=fac
3225           fac=-3*rrmij*(facvdw+facvdw+facel)
3226           erij(1)=xj*rmij
3227           erij(2)=yj*rmij
3228           erij(3)=zj*rmij
3229 *
3230 * Radial derivatives. First process both termini of the fragment (i,j)
3231 *
3232           ggg(1)=fac*xj
3233           ggg(2)=fac*yj
3234           ggg(3)=fac*zj
3235 c          do k=1,3
3236 c            ghalf=0.5D0*ggg(k)
3237 c            gelc(k,i)=gelc(k,i)+ghalf
3238 c            gelc(k,j)=gelc(k,j)+ghalf
3239 c          enddo
3240 c 9/28/08 AL Gradient compotents will be summed only at the end
3241           do k=1,3
3242             gelc_long(k,j)=gelc(k,j)+ggg(k)
3243             gelc_long(k,i)=gelc(k,i)-ggg(k)
3244           enddo
3245 *
3246 * Loop over residues i+1 thru j-1.
3247 *
3248 cgrad          do k=i+1,j-1
3249 cgrad            do l=1,3
3250 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3251 cgrad            enddo
3252 cgrad          enddo
3253 c 9/28/08 AL Gradient compotents will be summed only at the end
3254           ggg(1)=facvdw*xj
3255           ggg(2)=facvdw*yj
3256           ggg(3)=facvdw*zj
3257           do k=1,3
3258             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3259             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3260           enddo
3261 #endif
3262 *
3263 * Angular part
3264 *
3265           ecosa=2.0D0*fac3*fac1+fac4
3266           fac4=-3.0D0*fac4
3267           fac3=-6.0D0*fac3
3268           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3269           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3270           do k=1,3
3271             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3272             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3273           enddo
3274 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3275 cd   &          (dcosg(k),k=1,3)
3276           do k=1,3
3277             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3278           enddo
3279 c          do k=1,3
3280 c            ghalf=0.5D0*ggg(k)
3281 c            gelc(k,i)=gelc(k,i)+ghalf
3282 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3283 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3284 c            gelc(k,j)=gelc(k,j)+ghalf
3285 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3286 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3287 c          enddo
3288 cgrad          do k=i+1,j-1
3289 cgrad            do l=1,3
3290 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3291 cgrad            enddo
3292 cgrad          enddo
3293           do k=1,3
3294             gelc(k,i)=gelc(k,i)
3295      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3296      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3297             gelc(k,j)=gelc(k,j)
3298      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3299      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3300             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3301             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3302           enddo
3303           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3304      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3305      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3306 C
3307 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3308 C   energy of a peptide unit is assumed in the form of a second-order
3309 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3310 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3311 C   are computed for EVERY pair of non-contiguous peptide groups.
3312 C
3313           if (j.lt.nres-1) then
3314             j1=j+1
3315             j2=j-1
3316           else
3317             j1=j-1
3318             j2=j-2
3319           endif
3320           kkk=0
3321           do k=1,2
3322             do l=1,2
3323               kkk=kkk+1
3324               muij(kkk)=mu(k,i)*mu(l,j)
3325             enddo
3326           enddo
3327 cd         write (iout,*) 'EELEC: i',i,' j',j
3328 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3329 cd          write(iout,*) 'muij',muij
3330           ury=scalar(uy(1,i),erij)
3331           urz=scalar(uz(1,i),erij)
3332           vry=scalar(uy(1,j),erij)
3333           vrz=scalar(uz(1,j),erij)
3334           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3335           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3336           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3337           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3338           fac=dsqrt(-ael6i)*r3ij
3339           a22=a22*fac
3340           a23=a23*fac
3341           a32=a32*fac
3342           a33=a33*fac
3343 cd          write (iout,'(4i5,4f10.5)')
3344 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3345 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3346 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3347 cd     &      uy(:,j),uz(:,j)
3348 cd          write (iout,'(4f10.5)')
3349 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3350 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3351 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3352 cd           write (iout,'(9f10.5/)')
3353 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3354 C Derivatives of the elements of A in virtual-bond vectors
3355           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3356           do k=1,3
3357             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3358             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3359             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3360             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3361             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3362             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3363             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3364             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3365             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3366             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3367             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3368             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3369           enddo
3370 C Compute radial contributions to the gradient
3371           facr=-3.0d0*rrmij
3372           a22der=a22*facr
3373           a23der=a23*facr
3374           a32der=a32*facr
3375           a33der=a33*facr
3376           agg(1,1)=a22der*xj
3377           agg(2,1)=a22der*yj
3378           agg(3,1)=a22der*zj
3379           agg(1,2)=a23der*xj
3380           agg(2,2)=a23der*yj
3381           agg(3,2)=a23der*zj
3382           agg(1,3)=a32der*xj
3383           agg(2,3)=a32der*yj
3384           agg(3,3)=a32der*zj
3385           agg(1,4)=a33der*xj
3386           agg(2,4)=a33der*yj
3387           agg(3,4)=a33der*zj
3388 C Add the contributions coming from er
3389           fac3=-3.0d0*fac
3390           do k=1,3
3391             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3392             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3393             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3394             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3395           enddo
3396           do k=1,3
3397 C Derivatives in DC(i)
3398 cgrad            ghalf1=0.5d0*agg(k,1)
3399 cgrad            ghalf2=0.5d0*agg(k,2)
3400 cgrad            ghalf3=0.5d0*agg(k,3)
3401 cgrad            ghalf4=0.5d0*agg(k,4)
3402             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3403      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3404             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3405      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3406             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3407      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3408             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3409      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3410 C Derivatives in DC(i+1)
3411             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3412      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3413             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3414      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3415             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3416      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3417             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3418      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3419 C Derivatives in DC(j)
3420             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3421      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3422             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3423      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3424             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3425      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3426             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3427      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3428 C Derivatives in DC(j+1) or DC(nres-1)
3429             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3430      &      -3.0d0*vryg(k,3)*ury)
3431             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3432      &      -3.0d0*vrzg(k,3)*ury)
3433             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3434      &      -3.0d0*vryg(k,3)*urz)
3435             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3436      &      -3.0d0*vrzg(k,3)*urz)
3437 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3438 cgrad              do l=1,4
3439 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3440 cgrad              enddo
3441 cgrad            endif
3442           enddo
3443           acipa(1,1)=a22
3444           acipa(1,2)=a23
3445           acipa(2,1)=a32
3446           acipa(2,2)=a33
3447           a22=-a22
3448           a23=-a23
3449           do l=1,2
3450             do k=1,3
3451               agg(k,l)=-agg(k,l)
3452               aggi(k,l)=-aggi(k,l)
3453               aggi1(k,l)=-aggi1(k,l)
3454               aggj(k,l)=-aggj(k,l)
3455               aggj1(k,l)=-aggj1(k,l)
3456             enddo
3457           enddo
3458           if (j.lt.nres-1) then
3459             a22=-a22
3460             a32=-a32
3461             do l=1,3,2
3462               do k=1,3
3463                 agg(k,l)=-agg(k,l)
3464                 aggi(k,l)=-aggi(k,l)
3465                 aggi1(k,l)=-aggi1(k,l)
3466                 aggj(k,l)=-aggj(k,l)
3467                 aggj1(k,l)=-aggj1(k,l)
3468               enddo
3469             enddo
3470           else
3471             a22=-a22
3472             a23=-a23
3473             a32=-a32
3474             a33=-a33
3475             do l=1,4
3476               do k=1,3
3477                 agg(k,l)=-agg(k,l)
3478                 aggi(k,l)=-aggi(k,l)
3479                 aggi1(k,l)=-aggi1(k,l)
3480                 aggj(k,l)=-aggj(k,l)
3481                 aggj1(k,l)=-aggj1(k,l)
3482               enddo
3483             enddo
3484           endif
3485           ENDIF ! WCORR
3486           IF (wel_loc.gt.0.0d0) THEN
3487 C Contribution to the local-electrostatic energy coming from the i-j pair
3488           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3489      &     +a33*muij(4)
3490 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3491
3492           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3493      &            'eelloc',i,j,eel_loc_ij
3494
3495           eel_loc=eel_loc+eel_loc_ij
3496 C Partial derivatives in virtual-bond dihedral angles gamma
3497           if (i.gt.1)
3498      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3499      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3500      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3501           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3502      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3503      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3504 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3505           do l=1,3
3506             ggg(l)=agg(l,1)*muij(1)+
3507      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3508             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3509             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3510 cgrad            ghalf=0.5d0*ggg(l)
3511 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3512 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3513           enddo
3514 cgrad          do k=i+1,j2
3515 cgrad            do l=1,3
3516 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3517 cgrad            enddo
3518 cgrad          enddo
3519 C Remaining derivatives of eello
3520           do l=1,3
3521             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3522      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3523             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3524      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3525             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3526      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3527             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3528      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3529           enddo
3530           ENDIF
3531 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3532 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3533           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3534      &       .and. num_conti.le.maxconts) then
3535 c            write (iout,*) i,j," entered corr"
3536 C
3537 C Calculate the contact function. The ith column of the array JCONT will
3538 C contain the numbers of atoms that make contacts with the atom I (of numbers
3539 C greater than I). The arrays FACONT and GACONT will contain the values of
3540 C the contact function and its derivative.
3541 c           r0ij=1.02D0*rpp(iteli,itelj)
3542 c           r0ij=1.11D0*rpp(iteli,itelj)
3543             r0ij=2.20D0*rpp(iteli,itelj)
3544 c           r0ij=1.55D0*rpp(iteli,itelj)
3545             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3546             if (fcont.gt.0.0D0) then
3547               num_conti=num_conti+1
3548               if (num_conti.gt.maxconts) then
3549                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3550      &                         ' will skip next contacts for this conf.'
3551               else
3552                 jcont_hb(num_conti,i)=j
3553 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3554 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3555                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3556      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3557 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3558 C  terms.
3559                 d_cont(num_conti,i)=rij
3560 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3561 C     --- Electrostatic-interaction matrix ---
3562                 a_chuj(1,1,num_conti,i)=a22
3563                 a_chuj(1,2,num_conti,i)=a23
3564                 a_chuj(2,1,num_conti,i)=a32
3565                 a_chuj(2,2,num_conti,i)=a33
3566 C     --- Gradient of rij
3567                 do kkk=1,3
3568                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3569                 enddo
3570                 kkll=0
3571                 do k=1,2
3572                   do l=1,2
3573                     kkll=kkll+1
3574                     do m=1,3
3575                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3576                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3577                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3578                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3579                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3580                     enddo
3581                   enddo
3582                 enddo
3583                 ENDIF
3584                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3585 C Calculate contact energies
3586                 cosa4=4.0D0*cosa
3587                 wij=cosa-3.0D0*cosb*cosg
3588                 cosbg1=cosb+cosg
3589                 cosbg2=cosb-cosg
3590 c               fac3=dsqrt(-ael6i)/r0ij**3
3591                 fac3=dsqrt(-ael6i)*r3ij
3592 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3593                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3594                 if (ees0tmp.gt.0) then
3595                   ees0pij=dsqrt(ees0tmp)
3596                 else
3597                   ees0pij=0
3598                 endif
3599 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3600                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3601                 if (ees0tmp.gt.0) then
3602                   ees0mij=dsqrt(ees0tmp)
3603                 else
3604                   ees0mij=0
3605                 endif
3606 c               ees0mij=0.0D0
3607                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3608                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3609 C Diagnostics. Comment out or remove after debugging!
3610 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3611 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3612 c               ees0m(num_conti,i)=0.0D0
3613 C End diagnostics.
3614 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3615 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3616 C Angular derivatives of the contact function
3617                 ees0pij1=fac3/ees0pij
3618                 ees0mij1=fac3/ees0mij
3619                 fac3p=-3.0D0*fac3*rrmij
3620                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3621                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3622 c               ees0mij1=0.0D0
3623                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3624                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3625                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3626                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3627                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3628                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3629                 ecosap=ecosa1+ecosa2
3630                 ecosbp=ecosb1+ecosb2
3631                 ecosgp=ecosg1+ecosg2
3632                 ecosam=ecosa1-ecosa2
3633                 ecosbm=ecosb1-ecosb2
3634                 ecosgm=ecosg1-ecosg2
3635 C Diagnostics
3636 c               ecosap=ecosa1
3637 c               ecosbp=ecosb1
3638 c               ecosgp=ecosg1
3639 c               ecosam=0.0D0
3640 c               ecosbm=0.0D0
3641 c               ecosgm=0.0D0
3642 C End diagnostics
3643                 facont_hb(num_conti,i)=fcont
3644                 fprimcont=fprimcont/rij
3645 cd              facont_hb(num_conti,i)=1.0D0
3646 C Following line is for diagnostics.
3647 cd              fprimcont=0.0D0
3648                 do k=1,3
3649                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3650                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3651                 enddo
3652                 do k=1,3
3653                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3654                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3655                 enddo
3656                 gggp(1)=gggp(1)+ees0pijp*xj
3657                 gggp(2)=gggp(2)+ees0pijp*yj
3658                 gggp(3)=gggp(3)+ees0pijp*zj
3659                 gggm(1)=gggm(1)+ees0mijp*xj
3660                 gggm(2)=gggm(2)+ees0mijp*yj
3661                 gggm(3)=gggm(3)+ees0mijp*zj
3662 C Derivatives due to the contact function
3663                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3664                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3665                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3666                 do k=1,3
3667 c
3668 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3669 c          following the change of gradient-summation algorithm.
3670 c
3671 cgrad                  ghalfp=0.5D0*gggp(k)
3672 cgrad                  ghalfm=0.5D0*gggm(k)
3673                   gacontp_hb1(k,num_conti,i)=!ghalfp
3674      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3675      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3676                   gacontp_hb2(k,num_conti,i)=!ghalfp
3677      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3678      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3679                   gacontp_hb3(k,num_conti,i)=gggp(k)
3680                   gacontm_hb1(k,num_conti,i)=!ghalfm
3681      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3682      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3683                   gacontm_hb2(k,num_conti,i)=!ghalfm
3684      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3685      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3686                   gacontm_hb3(k,num_conti,i)=gggm(k)
3687                 enddo
3688 C Diagnostics. Comment out or remove after debugging!
3689 cdiag           do k=1,3
3690 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3691 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3692 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3693 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3694 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3695 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3696 cdiag           enddo
3697               ENDIF ! wcorr
3698               endif  ! num_conti.le.maxconts
3699             endif  ! fcont.gt.0
3700           endif    ! j.gt.i+1
3701           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3702             do k=1,4
3703               do l=1,3
3704                 ghalf=0.5d0*agg(l,k)
3705                 aggi(l,k)=aggi(l,k)+ghalf
3706                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3707                 aggj(l,k)=aggj(l,k)+ghalf
3708               enddo
3709             enddo
3710             if (j.eq.nres-1 .and. i.lt.j-2) then
3711               do k=1,4
3712                 do l=1,3
3713                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3714                 enddo
3715               enddo
3716             endif
3717           endif
3718 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3719       return
3720       end
3721 C-----------------------------------------------------------------------------
3722       subroutine eturn3(i,eello_turn3)
3723 C Third- and fourth-order contributions from turns
3724       implicit real*8 (a-h,o-z)
3725       include 'DIMENSIONS'
3726       include 'COMMON.IOUNITS'
3727       include 'COMMON.GEO'
3728       include 'COMMON.VAR'
3729       include 'COMMON.LOCAL'
3730       include 'COMMON.CHAIN'
3731       include 'COMMON.DERIV'
3732       include 'COMMON.INTERACT'
3733       include 'COMMON.CONTACTS'
3734       include 'COMMON.TORSION'
3735       include 'COMMON.VECTORS'
3736       include 'COMMON.FFIELD'
3737       include 'COMMON.CONTROL'
3738       dimension ggg(3)
3739       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3740      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3741      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3742       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3743      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3744       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3745      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3746      &    num_conti,j1,j2
3747       j=i+2
3748 c      write (iout,*) "eturn3",i,j,j1,j2
3749       a_temp(1,1)=a22
3750       a_temp(1,2)=a23
3751       a_temp(2,1)=a32
3752       a_temp(2,2)=a33
3753 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3754 C
3755 C               Third-order contributions
3756 C
3757 C                 (i+2)o----(i+3)
3758 C                      | |
3759 C                      | |
3760 C                 (i+1)o----i
3761 C
3762 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3763 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3764         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3765         call transpose2(auxmat(1,1),auxmat1(1,1))
3766         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3767         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3768         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3769      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3770 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3771 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3772 cd     &    ' eello_turn3_num',4*eello_turn3_num
3773 C Derivatives in gamma(i)
3774         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3775         call transpose2(auxmat2(1,1),auxmat3(1,1))
3776         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3777         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3778 C Derivatives in gamma(i+1)
3779         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3780         call transpose2(auxmat2(1,1),auxmat3(1,1))
3781         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3782         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3783      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3784 C Cartesian derivatives
3785         do l=1,3
3786 c            ghalf1=0.5d0*agg(l,1)
3787 c            ghalf2=0.5d0*agg(l,2)
3788 c            ghalf3=0.5d0*agg(l,3)
3789 c            ghalf4=0.5d0*agg(l,4)
3790           a_temp(1,1)=aggi(l,1)!+ghalf1
3791           a_temp(1,2)=aggi(l,2)!+ghalf2
3792           a_temp(2,1)=aggi(l,3)!+ghalf3
3793           a_temp(2,2)=aggi(l,4)!+ghalf4
3794           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3795           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3796      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3797           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3798           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3799           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3800           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3801           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3802           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3803      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3804           a_temp(1,1)=aggj(l,1)!+ghalf1
3805           a_temp(1,2)=aggj(l,2)!+ghalf2
3806           a_temp(2,1)=aggj(l,3)!+ghalf3
3807           a_temp(2,2)=aggj(l,4)!+ghalf4
3808           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3809           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3810      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3811           a_temp(1,1)=aggj1(l,1)
3812           a_temp(1,2)=aggj1(l,2)
3813           a_temp(2,1)=aggj1(l,3)
3814           a_temp(2,2)=aggj1(l,4)
3815           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3816           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3817      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3818         enddo
3819       return
3820       end
3821 C-------------------------------------------------------------------------------
3822       subroutine eturn4(i,eello_turn4)
3823 C Third- and fourth-order contributions from turns
3824       implicit real*8 (a-h,o-z)
3825       include 'DIMENSIONS'
3826       include 'COMMON.IOUNITS'
3827       include 'COMMON.GEO'
3828       include 'COMMON.VAR'
3829       include 'COMMON.LOCAL'
3830       include 'COMMON.CHAIN'
3831       include 'COMMON.DERIV'
3832       include 'COMMON.INTERACT'
3833       include 'COMMON.CONTACTS'
3834       include 'COMMON.TORSION'
3835       include 'COMMON.VECTORS'
3836       include 'COMMON.FFIELD'
3837       include 'COMMON.CONTROL'
3838       dimension ggg(3)
3839       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3840      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3841      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3842       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3843      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3844       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3845      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3846      &    num_conti,j1,j2
3847       j=i+3
3848 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3849 C
3850 C               Fourth-order contributions
3851 C
3852 C                 (i+3)o----(i+4)
3853 C                     /  |
3854 C               (i+2)o   |
3855 C                     \  |
3856 C                 (i+1)o----i
3857 C
3858 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3859 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3860 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3861         a_temp(1,1)=a22
3862         a_temp(1,2)=a23
3863         a_temp(2,1)=a32
3864         a_temp(2,2)=a33
3865         iti1=itortyp(itype(i+1))
3866         iti2=itortyp(itype(i+2))
3867         iti3=itortyp(itype(i+3))
3868 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3869         call transpose2(EUg(1,1,i+1),e1t(1,1))
3870         call transpose2(Eug(1,1,i+2),e2t(1,1))
3871         call transpose2(Eug(1,1,i+3),e3t(1,1))
3872         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3873         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3874         s1=scalar2(b1(1,iti2),auxvec(1))
3875         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3876         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3877         s2=scalar2(b1(1,iti1),auxvec(1))
3878         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3879         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3880         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3881         eello_turn4=eello_turn4-(s1+s2+s3)
3882         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3883      &      'eturn4',i,j,-(s1+s2+s3)
3884 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3885 cd     &    ' eello_turn4_num',8*eello_turn4_num
3886 C Derivatives in gamma(i)
3887         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3888         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3889         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3890         s1=scalar2(b1(1,iti2),auxvec(1))
3891         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3892         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3893         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3894 C Derivatives in gamma(i+1)
3895         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3896         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3897         s2=scalar2(b1(1,iti1),auxvec(1))
3898         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3899         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3900         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3901         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3902 C Derivatives in gamma(i+2)
3903         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3904         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3905         s1=scalar2(b1(1,iti2),auxvec(1))
3906         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3907         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3908         s2=scalar2(b1(1,iti1),auxvec(1))
3909         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3910         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3911         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3912         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3913 C Cartesian derivatives
3914 C Derivatives of this turn contributions in DC(i+2)
3915         if (j.lt.nres-1) then
3916           do l=1,3
3917             a_temp(1,1)=agg(l,1)
3918             a_temp(1,2)=agg(l,2)
3919             a_temp(2,1)=agg(l,3)
3920             a_temp(2,2)=agg(l,4)
3921             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3922             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3923             s1=scalar2(b1(1,iti2),auxvec(1))
3924             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3925             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3926             s2=scalar2(b1(1,iti1),auxvec(1))
3927             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3928             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3929             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3930             ggg(l)=-(s1+s2+s3)
3931             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3932           enddo
3933         endif
3934 C Remaining derivatives of this turn contribution
3935         do l=1,3
3936           a_temp(1,1)=aggi(l,1)
3937           a_temp(1,2)=aggi(l,2)
3938           a_temp(2,1)=aggi(l,3)
3939           a_temp(2,2)=aggi(l,4)
3940           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3941           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3942           s1=scalar2(b1(1,iti2),auxvec(1))
3943           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3944           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3945           s2=scalar2(b1(1,iti1),auxvec(1))
3946           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3947           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3948           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3949           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3950           a_temp(1,1)=aggi1(l,1)
3951           a_temp(1,2)=aggi1(l,2)
3952           a_temp(2,1)=aggi1(l,3)
3953           a_temp(2,2)=aggi1(l,4)
3954           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3955           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3956           s1=scalar2(b1(1,iti2),auxvec(1))
3957           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3958           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3959           s2=scalar2(b1(1,iti1),auxvec(1))
3960           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3961           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3962           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3963           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3964           a_temp(1,1)=aggj(l,1)
3965           a_temp(1,2)=aggj(l,2)
3966           a_temp(2,1)=aggj(l,3)
3967           a_temp(2,2)=aggj(l,4)
3968           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3969           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3970           s1=scalar2(b1(1,iti2),auxvec(1))
3971           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3972           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3973           s2=scalar2(b1(1,iti1),auxvec(1))
3974           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3975           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3976           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3977           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3978           a_temp(1,1)=aggj1(l,1)
3979           a_temp(1,2)=aggj1(l,2)
3980           a_temp(2,1)=aggj1(l,3)
3981           a_temp(2,2)=aggj1(l,4)
3982           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3983           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3984           s1=scalar2(b1(1,iti2),auxvec(1))
3985           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3986           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3987           s2=scalar2(b1(1,iti1),auxvec(1))
3988           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3989           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3990           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3991 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3992           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3993         enddo
3994       return
3995       end
3996 C-----------------------------------------------------------------------------
3997       subroutine vecpr(u,v,w)
3998       implicit real*8(a-h,o-z)
3999       dimension u(3),v(3),w(3)
4000       w(1)=u(2)*v(3)-u(3)*v(2)
4001       w(2)=-u(1)*v(3)+u(3)*v(1)
4002       w(3)=u(1)*v(2)-u(2)*v(1)
4003       return
4004       end
4005 C-----------------------------------------------------------------------------
4006       subroutine unormderiv(u,ugrad,unorm,ungrad)
4007 C This subroutine computes the derivatives of a normalized vector u, given
4008 C the derivatives computed without normalization conditions, ugrad. Returns
4009 C ungrad.
4010       implicit none
4011       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4012       double precision vec(3)
4013       double precision scalar
4014       integer i,j
4015 c      write (2,*) 'ugrad',ugrad
4016 c      write (2,*) 'u',u
4017       do i=1,3
4018         vec(i)=scalar(ugrad(1,i),u(1))
4019       enddo
4020 c      write (2,*) 'vec',vec
4021       do i=1,3
4022         do j=1,3
4023           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4024         enddo
4025       enddo
4026 c      write (2,*) 'ungrad',ungrad
4027       return
4028       end
4029 C-----------------------------------------------------------------------------
4030       subroutine escp_soft_sphere(evdw2,evdw2_14)
4031 C
4032 C This subroutine calculates the excluded-volume interaction energy between
4033 C peptide-group centers and side chains and its gradient in virtual-bond and
4034 C side-chain vectors.
4035 C
4036       implicit real*8 (a-h,o-z)
4037       include 'DIMENSIONS'
4038       include 'COMMON.GEO'
4039       include 'COMMON.VAR'
4040       include 'COMMON.LOCAL'
4041       include 'COMMON.CHAIN'
4042       include 'COMMON.DERIV'
4043       include 'COMMON.INTERACT'
4044       include 'COMMON.FFIELD'
4045       include 'COMMON.IOUNITS'
4046       include 'COMMON.CONTROL'
4047       dimension ggg(3)
4048       evdw2=0.0D0
4049       evdw2_14=0.0d0
4050       r0_scp=4.5d0
4051 cd    print '(a)','Enter ESCP'
4052 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4053       do i=iatscp_s,iatscp_e
4054         iteli=itel(i)
4055         xi=0.5D0*(c(1,i)+c(1,i+1))
4056         yi=0.5D0*(c(2,i)+c(2,i+1))
4057         zi=0.5D0*(c(3,i)+c(3,i+1))
4058
4059         do iint=1,nscp_gr(i)
4060
4061         do j=iscpstart(i,iint),iscpend(i,iint)
4062           itypj=itype(j)
4063 C Uncomment following three lines for SC-p interactions
4064 c         xj=c(1,nres+j)-xi
4065 c         yj=c(2,nres+j)-yi
4066 c         zj=c(3,nres+j)-zi
4067 C Uncomment following three lines for Ca-p interactions
4068           xj=c(1,j)-xi
4069           yj=c(2,j)-yi
4070           zj=c(3,j)-zi
4071           rij=xj*xj+yj*yj+zj*zj
4072           r0ij=r0_scp
4073           r0ijsq=r0ij*r0ij
4074           if (rij.lt.r0ijsq) then
4075             evdwij=0.25d0*(rij-r0ijsq)**2
4076             fac=rij-r0ijsq
4077           else
4078             evdwij=0.0d0
4079             fac=0.0d0
4080           endif
4081           evdw2=evdw2+evdwij
4082 C
4083 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4084 C
4085           ggg(1)=xj*fac
4086           ggg(2)=yj*fac
4087           ggg(3)=zj*fac
4088 cgrad          if (j.lt.i) then
4089 cd          write (iout,*) 'j<i'
4090 C Uncomment following three lines for SC-p interactions
4091 c           do k=1,3
4092 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4093 c           enddo
4094 cgrad          else
4095 cd          write (iout,*) 'j>i'
4096 cgrad            do k=1,3
4097 cgrad              ggg(k)=-ggg(k)
4098 C Uncomment following line for SC-p interactions
4099 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4100 cgrad            enddo
4101 cgrad          endif
4102 cgrad          do k=1,3
4103 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4104 cgrad          enddo
4105 cgrad          kstart=min0(i+1,j)
4106 cgrad          kend=max0(i-1,j-1)
4107 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4108 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4109 cgrad          do k=kstart,kend
4110 cgrad            do l=1,3
4111 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4112 cgrad            enddo
4113 cgrad          enddo
4114           do k=1,3
4115             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4116             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4117           enddo
4118         enddo
4119
4120         enddo ! iint
4121       enddo ! i
4122       return
4123       end
4124 C-----------------------------------------------------------------------------
4125       subroutine escp(evdw2,evdw2_14)
4126 C
4127 C This subroutine calculates the excluded-volume interaction energy between
4128 C peptide-group centers and side chains and its gradient in virtual-bond and
4129 C side-chain vectors.
4130 C
4131       implicit real*8 (a-h,o-z)
4132       include 'DIMENSIONS'
4133       include 'COMMON.GEO'
4134       include 'COMMON.VAR'
4135       include 'COMMON.LOCAL'
4136       include 'COMMON.CHAIN'
4137       include 'COMMON.DERIV'
4138       include 'COMMON.INTERACT'
4139       include 'COMMON.FFIELD'
4140       include 'COMMON.IOUNITS'
4141       include 'COMMON.CONTROL'
4142       dimension ggg(3)
4143       evdw2=0.0D0
4144       evdw2_14=0.0d0
4145 cd    print '(a)','Enter ESCP'
4146 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4147       do i=iatscp_s,iatscp_e
4148         iteli=itel(i)
4149         xi=0.5D0*(c(1,i)+c(1,i+1))
4150         yi=0.5D0*(c(2,i)+c(2,i+1))
4151         zi=0.5D0*(c(3,i)+c(3,i+1))
4152
4153         do iint=1,nscp_gr(i)
4154
4155         do j=iscpstart(i,iint),iscpend(i,iint)
4156           itypj=itype(j)
4157 C Uncomment following three lines for SC-p interactions
4158 c         xj=c(1,nres+j)-xi
4159 c         yj=c(2,nres+j)-yi
4160 c         zj=c(3,nres+j)-zi
4161 C Uncomment following three lines for Ca-p interactions
4162           xj=c(1,j)-xi
4163           yj=c(2,j)-yi
4164           zj=c(3,j)-zi
4165           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4166           fac=rrij**expon2
4167           e1=fac*fac*aad(itypj,iteli)
4168           e2=fac*bad(itypj,iteli)
4169           if (iabs(j-i) .le. 2) then
4170             e1=scal14*e1
4171             e2=scal14*e2
4172             evdw2_14=evdw2_14+e1+e2
4173           endif
4174           evdwij=e1+e2
4175           evdw2=evdw2+evdwij
4176           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4177      &        'evdw2',i,j,evdwij
4178 C
4179 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4180 C
4181           fac=-(evdwij+e1)*rrij
4182           ggg(1)=xj*fac
4183           ggg(2)=yj*fac
4184           ggg(3)=zj*fac
4185 cgrad          if (j.lt.i) then
4186 cd          write (iout,*) 'j<i'
4187 C Uncomment following three lines for SC-p interactions
4188 c           do k=1,3
4189 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4190 c           enddo
4191 cgrad          else
4192 cd          write (iout,*) 'j>i'
4193 cgrad            do k=1,3
4194 cgrad              ggg(k)=-ggg(k)
4195 C Uncomment following line for SC-p interactions
4196 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4197 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4198 cgrad            enddo
4199 cgrad          endif
4200 cgrad          do k=1,3
4201 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4202 cgrad          enddo
4203 cgrad          kstart=min0(i+1,j)
4204 cgrad          kend=max0(i-1,j-1)
4205 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4206 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4207 cgrad          do k=kstart,kend
4208 cgrad            do l=1,3
4209 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4210 cgrad            enddo
4211 cgrad          enddo
4212           do k=1,3
4213             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4214             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4215           enddo
4216         enddo
4217
4218         enddo ! iint
4219       enddo ! i
4220       do i=1,nct
4221         do j=1,3
4222           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4223           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4224           gradx_scp(j,i)=expon*gradx_scp(j,i)
4225         enddo
4226       enddo
4227 C******************************************************************************
4228 C
4229 C                              N O T E !!!
4230 C
4231 C To save time the factor EXPON has been extracted from ALL components
4232 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4233 C use!
4234 C
4235 C******************************************************************************
4236       return
4237       end
4238 C--------------------------------------------------------------------------
4239       subroutine edis(ehpb)
4240 C
4241 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4242 C
4243       implicit real*8 (a-h,o-z)
4244       include 'DIMENSIONS'
4245       include 'COMMON.SBRIDGE'
4246       include 'COMMON.CHAIN'
4247       include 'COMMON.DERIV'
4248       include 'COMMON.VAR'
4249       include 'COMMON.INTERACT'
4250       include 'COMMON.IOUNITS'
4251       dimension ggg(3)
4252       ehpb=0.0D0
4253 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4254 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4255       if (link_end.eq.0) return
4256       do i=link_start,link_end
4257 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4258 C CA-CA distance used in regularization of structure.
4259         ii=ihpb(i)
4260         jj=jhpb(i)
4261 C iii and jjj point to the residues for which the distance is assigned.
4262         if (ii.gt.nres) then
4263           iii=ii-nres
4264           jjj=jj-nres
4265         else
4266           iii=ii
4267           jjj=jj
4268         endif
4269 cd        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj
4270 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4271 C    distance and angle dependent SS bond potential.
4272         if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4273           call ssbond_ene(iii,jjj,eij)
4274           ehpb=ehpb+2*eij
4275 cd          write (iout,*) "eij",eij
4276         else
4277 C Calculate the distance between the two points and its difference from the
4278 C target distance.
4279         dd=dist(ii,jj)
4280         rdis=dd-dhpb(i)
4281 C Get the force constant corresponding to this distance.
4282         waga=forcon(i)
4283 C Calculate the contribution to energy.
4284         ehpb=ehpb+waga*rdis*rdis
4285 C
4286 C Evaluate gradient.
4287 C
4288         fac=waga*rdis/dd
4289 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4290 cd   &   ' waga=',waga,' fac=',fac
4291         do j=1,3
4292           ggg(j)=fac*(c(j,jj)-c(j,ii))
4293         enddo
4294 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4295 C If this is a SC-SC distance, we need to calculate the contributions to the
4296 C Cartesian gradient in the SC vectors (ghpbx).
4297         if (iii.lt.ii) then
4298           do j=1,3
4299             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4300             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4301           enddo
4302         endif
4303 cgrad        do j=iii,jjj-1
4304 cgrad          do k=1,3
4305 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4306 cgrad          enddo
4307 cgrad        enddo
4308         do k=1,3
4309           ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4310           ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4311         enddo
4312         endif
4313       enddo
4314       ehpb=0.5D0*ehpb
4315       return
4316       end
4317 C--------------------------------------------------------------------------
4318       subroutine ssbond_ene(i,j,eij)
4319 C
4320 C Calculate the distance and angle dependent SS-bond potential energy
4321 C using a free-energy function derived based on RHF/6-31G** ab initio
4322 C calculations of diethyl disulfide.
4323 C
4324 C A. Liwo and U. Kozlowska, 11/24/03
4325 C
4326       implicit real*8 (a-h,o-z)
4327       include 'DIMENSIONS'
4328       include 'COMMON.SBRIDGE'
4329       include 'COMMON.CHAIN'
4330       include 'COMMON.DERIV'
4331       include 'COMMON.LOCAL'
4332       include 'COMMON.INTERACT'
4333       include 'COMMON.VAR'
4334       include 'COMMON.IOUNITS'
4335       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4336       itypi=itype(i)
4337       xi=c(1,nres+i)
4338       yi=c(2,nres+i)
4339       zi=c(3,nres+i)
4340       dxi=dc_norm(1,nres+i)
4341       dyi=dc_norm(2,nres+i)
4342       dzi=dc_norm(3,nres+i)
4343 c      dsci_inv=dsc_inv(itypi)
4344       dsci_inv=vbld_inv(nres+i)
4345       itypj=itype(j)
4346 c      dscj_inv=dsc_inv(itypj)
4347       dscj_inv=vbld_inv(nres+j)
4348       xj=c(1,nres+j)-xi
4349       yj=c(2,nres+j)-yi
4350       zj=c(3,nres+j)-zi
4351       dxj=dc_norm(1,nres+j)
4352       dyj=dc_norm(2,nres+j)
4353       dzj=dc_norm(3,nres+j)
4354       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4355       rij=dsqrt(rrij)
4356       erij(1)=xj*rij
4357       erij(2)=yj*rij
4358       erij(3)=zj*rij
4359       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4360       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4361       om12=dxi*dxj+dyi*dyj+dzi*dzj
4362       do k=1,3
4363         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4364         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4365       enddo
4366       rij=1.0d0/rij
4367       deltad=rij-d0cm
4368       deltat1=1.0d0-om1
4369       deltat2=1.0d0+om2
4370       deltat12=om2-om1+2.0d0
4371       cosphi=om12-om1*om2
4372       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4373      &  +akct*deltad*deltat12
4374      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4375 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4376 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4377 c     &  " deltat12",deltat12," eij",eij
4378       ed=2*akcm*deltad+akct*deltat12
4379       pom1=akct*deltad
4380       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4381       eom1=-2*akth*deltat1-pom1-om2*pom2
4382       eom2= 2*akth*deltat2+pom1-om1*pom2
4383       eom12=pom2
4384       do k=1,3
4385         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4386         ghpbx(k,i)=ghpbx(k,i)-ggk
4387      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4388      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4389         ghpbx(k,j)=ghpbx(k,j)+ggk
4390      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4391      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4392         ghpbc(k,i)=ghpbc(k,i)-ggk
4393         ghpbc(k,j)=ghpbc(k,j)+ggk
4394       enddo
4395 C
4396 C Calculate the components of the gradient in DC and X
4397 C
4398 cgrad      do k=i,j-1
4399 cgrad        do l=1,3
4400 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4401 cgrad        enddo
4402 cgrad      enddo
4403       return
4404       end
4405 C--------------------------------------------------------------------------
4406       subroutine ebond(estr)
4407 c
4408 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4409 c
4410       implicit real*8 (a-h,o-z)
4411       include 'DIMENSIONS'
4412       include 'COMMON.LOCAL'
4413       include 'COMMON.GEO'
4414       include 'COMMON.INTERACT'
4415       include 'COMMON.DERIV'
4416       include 'COMMON.VAR'
4417       include 'COMMON.CHAIN'
4418       include 'COMMON.IOUNITS'
4419       include 'COMMON.NAMES'
4420       include 'COMMON.FFIELD'
4421       include 'COMMON.CONTROL'
4422       include 'COMMON.SETUP'
4423       double precision u(3),ud(3)
4424       estr=0.0d0
4425       do i=ibondp_start,ibondp_end
4426         diff = vbld(i)-vbldp0
4427 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4428         estr=estr+diff*diff
4429         do j=1,3
4430           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4431         enddo
4432 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4433       enddo
4434       estr=0.5d0*AKP*estr
4435 c
4436 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4437 c
4438       do i=ibond_start,ibond_end
4439         iti=itype(i)
4440         if (iti.ne.10) then
4441           nbi=nbondterm(iti)
4442           if (nbi.eq.1) then
4443             diff=vbld(i+nres)-vbldsc0(1,iti)
4444 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4445 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4446             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4447             do j=1,3
4448               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4449             enddo
4450           else
4451             do j=1,nbi
4452               diff=vbld(i+nres)-vbldsc0(j,iti)
4453               ud(j)=aksc(j,iti)*diff
4454               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4455             enddo
4456             uprod=u(1)
4457             do j=2,nbi
4458               uprod=uprod*u(j)
4459             enddo
4460             usum=0.0d0
4461             usumsqder=0.0d0
4462             do j=1,nbi
4463               uprod1=1.0d0
4464               uprod2=1.0d0
4465               do k=1,nbi
4466                 if (k.ne.j) then
4467                   uprod1=uprod1*u(k)
4468                   uprod2=uprod2*u(k)*u(k)
4469                 endif
4470               enddo
4471               usum=usum+uprod1
4472               usumsqder=usumsqder+ud(j)*uprod2
4473             enddo
4474             estr=estr+uprod/usum
4475             do j=1,3
4476              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4477             enddo
4478           endif
4479         endif
4480       enddo
4481       return
4482       end
4483 #ifdef CRYST_THETA
4484 C--------------------------------------------------------------------------
4485       subroutine ebend(etheta)
4486 C
4487 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4488 C angles gamma and its derivatives in consecutive thetas and gammas.
4489 C
4490       implicit real*8 (a-h,o-z)
4491       include 'DIMENSIONS'
4492       include 'COMMON.LOCAL'
4493       include 'COMMON.GEO'
4494       include 'COMMON.INTERACT'
4495       include 'COMMON.DERIV'
4496       include 'COMMON.VAR'
4497       include 'COMMON.CHAIN'
4498       include 'COMMON.IOUNITS'
4499       include 'COMMON.NAMES'
4500       include 'COMMON.FFIELD'
4501       include 'COMMON.CONTROL'
4502       common /calcthet/ term1,term2,termm,diffak,ratak,
4503      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4504      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4505       double precision y(2),z(2)
4506       delta=0.02d0*pi
4507 c      time11=dexp(-2*time)
4508 c      time12=1.0d0
4509       etheta=0.0D0
4510 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4511       do i=ithet_start,ithet_end
4512 C Zero the energy function and its derivative at 0 or pi.
4513         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4514         it=itype(i-1)
4515         if (i.gt.3) then
4516 #ifdef OSF
4517           phii=phi(i)
4518           if (phii.ne.phii) phii=150.0
4519 #else
4520           phii=phi(i)
4521 #endif
4522           y(1)=dcos(phii)
4523           y(2)=dsin(phii)
4524         else
4525           y(1)=0.0D0
4526           y(2)=0.0D0
4527         endif
4528         if (i.lt.nres) then
4529 #ifdef OSF
4530           phii1=phi(i+1)
4531           if (phii1.ne.phii1) phii1=150.0
4532           phii1=pinorm(phii1)
4533           z(1)=cos(phii1)
4534 #else
4535           phii1=phi(i+1)
4536           z(1)=dcos(phii1)
4537 #endif
4538           z(2)=dsin(phii1)
4539         else
4540           z(1)=0.0D0
4541           z(2)=0.0D0
4542         endif
4543 C Calculate the "mean" value of theta from the part of the distribution
4544 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4545 C In following comments this theta will be referred to as t_c.
4546         thet_pred_mean=0.0d0
4547         do k=1,2
4548           athetk=athet(k,it)
4549           bthetk=bthet(k,it)
4550           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4551         enddo
4552         dthett=thet_pred_mean*ssd
4553         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4554 C Derivatives of the "mean" values in gamma1 and gamma2.
4555         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
4556         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
4557         if (theta(i).gt.pi-delta) then
4558           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4559      &         E_tc0)
4560           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4561           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4562           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4563      &        E_theta)
4564           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4565      &        E_tc)
4566         else if (theta(i).lt.delta) then
4567           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4568           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4569           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4570      &        E_theta)
4571           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4572           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4573      &        E_tc)
4574         else
4575           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4576      &        E_theta,E_tc)
4577         endif
4578         etheta=etheta+ethetai
4579         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4580      &      'ebend',i,ethetai
4581         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4582         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4583         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4584       enddo
4585 C Ufff.... We've done all this!!!
4586       return
4587       end
4588 C---------------------------------------------------------------------------
4589       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4590      &     E_tc)
4591       implicit real*8 (a-h,o-z)
4592       include 'DIMENSIONS'
4593       include 'COMMON.LOCAL'
4594       include 'COMMON.IOUNITS'
4595       common /calcthet/ term1,term2,termm,diffak,ratak,
4596      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4597      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4598 C Calculate the contributions to both Gaussian lobes.
4599 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4600 C The "polynomial part" of the "standard deviation" of this part of
4601 C the distribution.
4602         sig=polthet(3,it)
4603         do j=2,0,-1
4604           sig=sig*thet_pred_mean+polthet(j,it)
4605         enddo
4606 C Derivative of the "interior part" of the "standard deviation of the"
4607 C gamma-dependent Gaussian lobe in t_c.
4608         sigtc=3*polthet(3,it)
4609         do j=2,1,-1
4610           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4611         enddo
4612         sigtc=sig*sigtc
4613 C Set the parameters of both Gaussian lobes of the distribution.
4614 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4615         fac=sig*sig+sigc0(it)
4616         sigcsq=fac+fac
4617         sigc=1.0D0/sigcsq
4618 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4619         sigsqtc=-4.0D0*sigcsq*sigtc
4620 c       print *,i,sig,sigtc,sigsqtc
4621 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4622         sigtc=-sigtc/(fac*fac)
4623 C Following variable is sigma(t_c)**(-2)
4624         sigcsq=sigcsq*sigcsq
4625         sig0i=sig0(it)
4626         sig0inv=1.0D0/sig0i**2
4627         delthec=thetai-thet_pred_mean
4628         delthe0=thetai-theta0i
4629         term1=-0.5D0*sigcsq*delthec*delthec
4630         term2=-0.5D0*sig0inv*delthe0*delthe0
4631 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4632 C NaNs in taking the logarithm. We extract the largest exponent which is added
4633 C to the energy (this being the log of the distribution) at the end of energy
4634 C term evaluation for this virtual-bond angle.
4635         if (term1.gt.term2) then
4636           termm=term1
4637           term2=dexp(term2-termm)
4638           term1=1.0d0
4639         else
4640           termm=term2
4641           term1=dexp(term1-termm)
4642           term2=1.0d0
4643         endif
4644 C The ratio between the gamma-independent and gamma-dependent lobes of
4645 C the distribution is a Gaussian function of thet_pred_mean too.
4646         diffak=gthet(2,it)-thet_pred_mean
4647         ratak=diffak/gthet(3,it)**2
4648         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4649 C Let's differentiate it in thet_pred_mean NOW.
4650         aktc=ak*ratak
4651 C Now put together the distribution terms to make complete distribution.
4652         termexp=term1+ak*term2
4653         termpre=sigc+ak*sig0i
4654 C Contribution of the bending energy from this theta is just the -log of
4655 C the sum of the contributions from the two lobes and the pre-exponential
4656 C factor. Simple enough, isn't it?
4657         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4658 C NOW the derivatives!!!
4659 C 6/6/97 Take into account the deformation.
4660         E_theta=(delthec*sigcsq*term1
4661      &       +ak*delthe0*sig0inv*term2)/termexp
4662         E_tc=((sigtc+aktc*sig0i)/termpre
4663      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4664      &       aktc*term2)/termexp)
4665       return
4666       end
4667 c-----------------------------------------------------------------------------
4668       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4669       implicit real*8 (a-h,o-z)
4670       include 'DIMENSIONS'
4671       include 'COMMON.LOCAL'
4672       include 'COMMON.IOUNITS'
4673       common /calcthet/ term1,term2,termm,diffak,ratak,
4674      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4675      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4676       delthec=thetai-thet_pred_mean
4677       delthe0=thetai-theta0i
4678 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4679       t3 = thetai-thet_pred_mean
4680       t6 = t3**2
4681       t9 = term1
4682       t12 = t3*sigcsq
4683       t14 = t12+t6*sigsqtc
4684       t16 = 1.0d0
4685       t21 = thetai-theta0i
4686       t23 = t21**2
4687       t26 = term2
4688       t27 = t21*t26
4689       t32 = termexp
4690       t40 = t32**2
4691       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4692      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4693      & *(-t12*t9-ak*sig0inv*t27)
4694       return
4695       end
4696 #else
4697 C--------------------------------------------------------------------------
4698       subroutine ebend(etheta)
4699 C
4700 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4701 C angles gamma and its derivatives in consecutive thetas and gammas.
4702 C ab initio-derived potentials from
4703 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4704 C
4705       implicit real*8 (a-h,o-z)
4706       include 'DIMENSIONS'
4707       include 'COMMON.LOCAL'
4708       include 'COMMON.GEO'
4709       include 'COMMON.INTERACT'
4710       include 'COMMON.DERIV'
4711       include 'COMMON.VAR'
4712       include 'COMMON.CHAIN'
4713       include 'COMMON.IOUNITS'
4714       include 'COMMON.NAMES'
4715       include 'COMMON.FFIELD'
4716       include 'COMMON.CONTROL'
4717       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4718      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4719      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4720      & sinph1ph2(maxdouble,maxdouble)
4721       logical lprn /.false./, lprn1 /.false./
4722       etheta=0.0D0
4723       do i=ithet_start,ithet_end
4724         dethetai=0.0d0
4725         dephii=0.0d0
4726         dephii1=0.0d0
4727         theti2=0.5d0*theta(i)
4728         ityp2=ithetyp(itype(i-1))
4729         do k=1,nntheterm
4730           coskt(k)=dcos(k*theti2)
4731           sinkt(k)=dsin(k*theti2)
4732         enddo
4733         if (i.gt.3) then
4734 #ifdef OSF
4735           phii=phi(i)
4736           if (phii.ne.phii) phii=150.0
4737 #else
4738           phii=phi(i)
4739 #endif
4740           ityp1=ithetyp(itype(i-2))
4741           do k=1,nsingle
4742             cosph1(k)=dcos(k*phii)
4743             sinph1(k)=dsin(k*phii)
4744           enddo
4745         else
4746           phii=0.0d0
4747           ityp1=nthetyp+1
4748           do k=1,nsingle
4749             cosph1(k)=0.0d0
4750             sinph1(k)=0.0d0
4751           enddo
4752         endif
4753         if (i.lt.nres) then
4754 #ifdef OSF
4755           phii1=phi(i+1)
4756           if (phii1.ne.phii1) phii1=150.0
4757           phii1=pinorm(phii1)
4758 #else
4759           phii1=phi(i+1)
4760 #endif
4761           ityp3=ithetyp(itype(i))
4762           do k=1,nsingle
4763             cosph2(k)=dcos(k*phii1)
4764             sinph2(k)=dsin(k*phii1)
4765           enddo
4766         else
4767           phii1=0.0d0
4768           ityp3=nthetyp+1
4769           do k=1,nsingle
4770             cosph2(k)=0.0d0
4771             sinph2(k)=0.0d0
4772           enddo
4773         endif
4774         ethetai=aa0thet(ityp1,ityp2,ityp3)
4775         do k=1,ndouble
4776           do l=1,k-1
4777             ccl=cosph1(l)*cosph2(k-l)
4778             ssl=sinph1(l)*sinph2(k-l)
4779             scl=sinph1(l)*cosph2(k-l)
4780             csl=cosph1(l)*sinph2(k-l)
4781             cosph1ph2(l,k)=ccl-ssl
4782             cosph1ph2(k,l)=ccl+ssl
4783             sinph1ph2(l,k)=scl+csl
4784             sinph1ph2(k,l)=scl-csl
4785           enddo
4786         enddo
4787         if (lprn) then
4788         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4789      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4790         write (iout,*) "coskt and sinkt"
4791         do k=1,nntheterm
4792           write (iout,*) k,coskt(k),sinkt(k)
4793         enddo
4794         endif
4795         do k=1,ntheterm
4796           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4797           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4798      &      *coskt(k)
4799           if (lprn)
4800      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4801      &     " ethetai",ethetai
4802         enddo
4803         if (lprn) then
4804         write (iout,*) "cosph and sinph"
4805         do k=1,nsingle
4806           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4807         enddo
4808         write (iout,*) "cosph1ph2 and sinph2ph2"
4809         do k=2,ndouble
4810           do l=1,k-1
4811             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4812      &         sinph1ph2(l,k),sinph1ph2(k,l)
4813           enddo
4814         enddo
4815         write(iout,*) "ethetai",ethetai
4816         endif
4817         do m=1,ntheterm2
4818           do k=1,nsingle
4819             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4820      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4821      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4822      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4823             ethetai=ethetai+sinkt(m)*aux
4824             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4825             dephii=dephii+k*sinkt(m)*(
4826      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4827      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4828             dephii1=dephii1+k*sinkt(m)*(
4829      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4830      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4831             if (lprn)
4832      &      write (iout,*) "m",m," k",k," bbthet",
4833      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4834      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4835      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4836      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4837           enddo
4838         enddo
4839         if (lprn)
4840      &  write(iout,*) "ethetai",ethetai
4841         do m=1,ntheterm3
4842           do k=2,ndouble
4843             do l=1,k-1
4844               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4845      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4846      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4847      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4848               ethetai=ethetai+sinkt(m)*aux
4849               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4850               dephii=dephii+l*sinkt(m)*(
4851      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4852      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4853      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4854      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4855               dephii1=dephii1+(k-l)*sinkt(m)*(
4856      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4857      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4858      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
4859      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4860               if (lprn) then
4861               write (iout,*) "m",m," k",k," l",l," ffthet",
4862      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
4863      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
4864      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
4865      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4866               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4867      &            cosph1ph2(k,l)*sinkt(m),
4868      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4869               endif
4870             enddo
4871           enddo
4872         enddo
4873 10      continue
4874         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4875      &   i,theta(i)*rad2deg,phii*rad2deg,
4876      &   phii1*rad2deg,ethetai
4877         etheta=etheta+ethetai
4878         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4879         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4880         gloc(nphi+i-2,icg)=wang*dethetai
4881       enddo
4882       return
4883       end
4884 #endif
4885 #ifdef CRYST_SC
4886 c-----------------------------------------------------------------------------
4887       subroutine esc(escloc)
4888 C Calculate the local energy of a side chain and its derivatives in the
4889 C corresponding virtual-bond valence angles THETA and the spherical angles
4890 C ALPHA and OMEGA.
4891       implicit real*8 (a-h,o-z)
4892       include 'DIMENSIONS'
4893       include 'COMMON.GEO'
4894       include 'COMMON.LOCAL'
4895       include 'COMMON.VAR'
4896       include 'COMMON.INTERACT'
4897       include 'COMMON.DERIV'
4898       include 'COMMON.CHAIN'
4899       include 'COMMON.IOUNITS'
4900       include 'COMMON.NAMES'
4901       include 'COMMON.FFIELD'
4902       include 'COMMON.CONTROL'
4903       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4904      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4905       common /sccalc/ time11,time12,time112,theti,it,nlobit
4906       delta=0.02d0*pi
4907       escloc=0.0D0
4908 c     write (iout,'(a)') 'ESC'
4909       do i=loc_start,loc_end
4910         it=itype(i)
4911         if (it.eq.10) goto 1
4912         nlobit=nlob(it)
4913 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4914 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4915         theti=theta(i+1)-pipol
4916         x(1)=dtan(theti)
4917         x(2)=alph(i)
4918         x(3)=omeg(i)
4919
4920         if (x(2).gt.pi-delta) then
4921           xtemp(1)=x(1)
4922           xtemp(2)=pi-delta
4923           xtemp(3)=x(3)
4924           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4925           xtemp(2)=pi
4926           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4927           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4928      &        escloci,dersc(2))
4929           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4930      &        ddersc0(1),dersc(1))
4931           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4932      &        ddersc0(3),dersc(3))
4933           xtemp(2)=pi-delta
4934           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4935           xtemp(2)=pi
4936           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4937           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4938      &            dersc0(2),esclocbi,dersc02)
4939           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4940      &            dersc12,dersc01)
4941           call splinthet(x(2),0.5d0*delta,ss,ssd)
4942           dersc0(1)=dersc01
4943           dersc0(2)=dersc02
4944           dersc0(3)=0.0d0
4945           do k=1,3
4946             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4947           enddo
4948           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4949 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4950 c    &             esclocbi,ss,ssd
4951           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4952 c         escloci=esclocbi
4953 c         write (iout,*) escloci
4954         else if (x(2).lt.delta) then
4955           xtemp(1)=x(1)
4956           xtemp(2)=delta
4957           xtemp(3)=x(3)
4958           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4959           xtemp(2)=0.0d0
4960           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4961           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4962      &        escloci,dersc(2))
4963           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4964      &        ddersc0(1),dersc(1))
4965           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4966      &        ddersc0(3),dersc(3))
4967           xtemp(2)=delta
4968           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4969           xtemp(2)=0.0d0
4970           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4971           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4972      &            dersc0(2),esclocbi,dersc02)
4973           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4974      &            dersc12,dersc01)
4975           dersc0(1)=dersc01
4976           dersc0(2)=dersc02
4977           dersc0(3)=0.0d0
4978           call splinthet(x(2),0.5d0*delta,ss,ssd)
4979           do k=1,3
4980             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4981           enddo
4982           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4983 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4984 c    &             esclocbi,ss,ssd
4985           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4986 c         write (iout,*) escloci
4987         else
4988           call enesc(x,escloci,dersc,ddummy,.false.)
4989         endif
4990
4991         escloc=escloc+escloci
4992         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4993      &     'escloc',i,escloci
4994 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4995
4996         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4997      &   wscloc*dersc(1)
4998         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4999         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5000     1   continue
5001       enddo
5002       return
5003       end
5004 C---------------------------------------------------------------------------
5005       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5006       implicit real*8 (a-h,o-z)
5007       include 'DIMENSIONS'
5008       include 'COMMON.GEO'
5009       include 'COMMON.LOCAL'
5010       include 'COMMON.IOUNITS'
5011       common /sccalc/ time11,time12,time112,theti,it,nlobit
5012       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5013       double precision contr(maxlob,-1:1)
5014       logical mixed
5015 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5016         escloc_i=0.0D0
5017         do j=1,3
5018           dersc(j)=0.0D0
5019           if (mixed) ddersc(j)=0.0d0
5020         enddo
5021         x3=x(3)
5022
5023 C Because of periodicity of the dependence of the SC energy in omega we have
5024 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5025 C To avoid underflows, first compute & store the exponents.
5026
5027         do iii=-1,1
5028
5029           x(3)=x3+iii*dwapi
5030
5031           do j=1,nlobit
5032             do k=1,3
5033               z(k)=x(k)-censc(k,j,it)
5034             enddo
5035             do k=1,3
5036               Axk=0.0D0
5037               do l=1,3
5038                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5039               enddo
5040               Ax(k,j,iii)=Axk
5041             enddo
5042             expfac=0.0D0
5043             do k=1,3
5044               expfac=expfac+Ax(k,j,iii)*z(k)
5045             enddo
5046             contr(j,iii)=expfac
5047           enddo ! j
5048
5049         enddo ! iii
5050
5051         x(3)=x3
5052 C As in the case of ebend, we want to avoid underflows in exponentiation and
5053 C subsequent NaNs and INFs in energy calculation.
5054 C Find the largest exponent
5055         emin=contr(1,-1)
5056         do iii=-1,1
5057           do j=1,nlobit
5058             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5059           enddo
5060         enddo
5061         emin=0.5D0*emin
5062 cd      print *,'it=',it,' emin=',emin
5063
5064 C Compute the contribution to SC energy and derivatives
5065         do iii=-1,1
5066
5067           do j=1,nlobit
5068 #ifdef OSF
5069             adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin
5070             if(adexp.ne.adexp) adexp=1.0
5071             expfac=dexp(adexp)
5072 #else
5073             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
5074 #endif
5075 cd          print *,'j=',j,' expfac=',expfac
5076             escloc_i=escloc_i+expfac
5077             do k=1,3
5078               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5079             enddo
5080             if (mixed) then
5081               do k=1,3,2
5082                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5083      &            +gaussc(k,2,j,it))*expfac
5084               enddo
5085             endif
5086           enddo
5087
5088         enddo ! iii
5089
5090         dersc(1)=dersc(1)/cos(theti)**2
5091         ddersc(1)=ddersc(1)/cos(theti)**2
5092         ddersc(3)=ddersc(3)
5093
5094         escloci=-(dlog(escloc_i)-emin)
5095         do j=1,3
5096           dersc(j)=dersc(j)/escloc_i
5097         enddo
5098         if (mixed) then
5099           do j=1,3,2
5100             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5101           enddo
5102         endif
5103       return
5104       end
5105 C------------------------------------------------------------------------------
5106       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5107       implicit real*8 (a-h,o-z)
5108       include 'DIMENSIONS'
5109       include 'COMMON.GEO'
5110       include 'COMMON.LOCAL'
5111       include 'COMMON.IOUNITS'
5112       common /sccalc/ time11,time12,time112,theti,it,nlobit
5113       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5114       double precision contr(maxlob)
5115       logical mixed
5116
5117       escloc_i=0.0D0
5118
5119       do j=1,3
5120         dersc(j)=0.0D0
5121       enddo
5122
5123       do j=1,nlobit
5124         do k=1,2
5125           z(k)=x(k)-censc(k,j,it)
5126         enddo
5127         z(3)=dwapi
5128         do k=1,3
5129           Axk=0.0D0
5130           do l=1,3
5131             Axk=Axk+gaussc(l,k,j,it)*z(l)
5132           enddo
5133           Ax(k,j)=Axk
5134         enddo
5135         expfac=0.0D0
5136         do k=1,3
5137           expfac=expfac+Ax(k,j)*z(k)
5138         enddo
5139         contr(j)=expfac
5140       enddo ! j
5141
5142 C As in the case of ebend, we want to avoid underflows in exponentiation and
5143 C subsequent NaNs and INFs in energy calculation.
5144 C Find the largest exponent
5145       emin=contr(1)
5146       do j=1,nlobit
5147         if (emin.gt.contr(j)) emin=contr(j)
5148       enddo
5149       emin=0.5D0*emin
5150
5151 C Compute the contribution to SC energy and derivatives
5152
5153       dersc12=0.0d0
5154       do j=1,nlobit
5155         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
5156         escloc_i=escloc_i+expfac
5157         do k=1,2
5158           dersc(k)=dersc(k)+Ax(k,j)*expfac
5159         enddo
5160         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5161      &            +gaussc(1,2,j,it))*expfac
5162         dersc(3)=0.0d0
5163       enddo
5164
5165       dersc(1)=dersc(1)/cos(theti)**2
5166       dersc12=dersc12/cos(theti)**2
5167       escloci=-(dlog(escloc_i)-emin)
5168       do j=1,2
5169         dersc(j)=dersc(j)/escloc_i
5170       enddo
5171       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5172       return
5173       end
5174 #else
5175 c----------------------------------------------------------------------------------
5176       subroutine esc(escloc)
5177 C Calculate the local energy of a side chain and its derivatives in the
5178 C corresponding virtual-bond valence angles THETA and the spherical angles
5179 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5180 C added by Urszula Kozlowska. 07/11/2007
5181 C
5182       implicit real*8 (a-h,o-z)
5183       include 'DIMENSIONS'
5184       include 'COMMON.GEO'
5185       include 'COMMON.LOCAL'
5186       include 'COMMON.VAR'
5187       include 'COMMON.SCROT'
5188       include 'COMMON.INTERACT'
5189       include 'COMMON.DERIV'
5190       include 'COMMON.CHAIN'
5191       include 'COMMON.IOUNITS'
5192       include 'COMMON.NAMES'
5193       include 'COMMON.FFIELD'
5194       include 'COMMON.CONTROL'
5195       include 'COMMON.VECTORS'
5196       double precision x_prime(3),y_prime(3),z_prime(3)
5197      &    , sumene,dsc_i,dp2_i,x(65),
5198      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5199      &    de_dxx,de_dyy,de_dzz,de_dt
5200       double precision s1_t,s1_6_t,s2_t,s2_6_t
5201       double precision
5202      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5203      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5204      & dt_dCi(3),dt_dCi1(3)
5205       common /sccalc/ time11,time12,time112,theti,it,nlobit
5206       delta=0.02d0*pi
5207       escloc=0.0D0
5208       do i=loc_start,loc_end
5209         costtab(i+1) =dcos(theta(i+1))
5210         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5211         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5212         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5213         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5214         cosfac=dsqrt(cosfac2)
5215         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5216         sinfac=dsqrt(sinfac2)
5217         it=itype(i)
5218         if (it.eq.10) goto 1
5219 c
5220 C  Compute the axes of tghe local cartesian coordinates system; store in
5221 c   x_prime, y_prime and z_prime
5222 c
5223         do j=1,3
5224           x_prime(j) = 0.00
5225           y_prime(j) = 0.00
5226           z_prime(j) = 0.00
5227         enddo
5228 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5229 C     &   dc_norm(3,i+nres)
5230         do j = 1,3
5231           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5232           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5233         enddo
5234         do j = 1,3
5235           z_prime(j) = -uz(j,i-1)
5236         enddo
5237 c       write (2,*) "i",i
5238 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5239 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5240 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5241 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5242 c      & " xy",scalar(x_prime(1),y_prime(1)),
5243 c      & " xz",scalar(x_prime(1),z_prime(1)),
5244 c      & " yy",scalar(y_prime(1),y_prime(1)),
5245 c      & " yz",scalar(y_prime(1),z_prime(1)),
5246 c      & " zz",scalar(z_prime(1),z_prime(1))
5247 c
5248 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5249 C to local coordinate system. Store in xx, yy, zz.
5250 c
5251         xx=0.0d0
5252         yy=0.0d0
5253         zz=0.0d0
5254         do j = 1,3
5255           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5256           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5257           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5258         enddo
5259
5260         xxtab(i)=xx
5261         yytab(i)=yy
5262         zztab(i)=zz
5263 C
5264 C Compute the energy of the ith side cbain
5265 C
5266 c        write (2,*) "xx",xx," yy",yy," zz",zz
5267         it=itype(i)
5268         do j = 1,65
5269           x(j) = sc_parmin(j,it)
5270         enddo
5271 #ifdef CHECK_COORD
5272 Cc diagnostics - remove later
5273         xx1 = dcos(alph(2))
5274         yy1 = dsin(alph(2))*dcos(omeg(2))
5275         zz1 = -dsin(alph(2))*dsin(omeg(2))
5276         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5277      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5278      &    xx1,yy1,zz1
5279 C,"  --- ", xx_w,yy_w,zz_w
5280 c end diagnostics
5281 #endif
5282         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5283      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5284      &   + x(10)*yy*zz
5285         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5286      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5287      & + x(20)*yy*zz
5288         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5289      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5290      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5291      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5292      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5293      &  +x(40)*xx*yy*zz
5294         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5295      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5296      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5297      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5298      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5299      &  +x(60)*xx*yy*zz
5300         dsc_i   = 0.743d0+x(61)
5301         dp2_i   = 1.9d0+x(62)
5302         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5303      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5304         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5305      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5306         s1=(1+x(63))/(0.1d0 + dscp1)
5307         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5308         s2=(1+x(65))/(0.1d0 + dscp2)
5309         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5310         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5311      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5312 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5313 c     &   sumene4,
5314 c     &   dscp1,dscp2,sumene
5315 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5316         escloc = escloc + sumene
5317 c        write (2,*) "i",i," escloc",sumene,escloc
5318 #ifdef DEBUG
5319 C
5320 C This section to check the numerical derivatives of the energy of ith side
5321 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5322 C #define DEBUG in the code to turn it on.
5323 C
5324         write (2,*) "sumene               =",sumene
5325         aincr=1.0d-7
5326         xxsave=xx
5327         xx=xx+aincr
5328         write (2,*) xx,yy,zz
5329         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5330         de_dxx_num=(sumenep-sumene)/aincr
5331         xx=xxsave
5332         write (2,*) "xx+ sumene from enesc=",sumenep
5333         yysave=yy
5334         yy=yy+aincr
5335         write (2,*) xx,yy,zz
5336         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5337         de_dyy_num=(sumenep-sumene)/aincr
5338         yy=yysave
5339         write (2,*) "yy+ sumene from enesc=",sumenep
5340         zzsave=zz
5341         zz=zz+aincr
5342         write (2,*) xx,yy,zz
5343         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5344         de_dzz_num=(sumenep-sumene)/aincr
5345         zz=zzsave
5346         write (2,*) "zz+ sumene from enesc=",sumenep
5347         costsave=cost2tab(i+1)
5348         sintsave=sint2tab(i+1)
5349         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5350         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5351         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5352         de_dt_num=(sumenep-sumene)/aincr
5353         write (2,*) " t+ sumene from enesc=",sumenep
5354         cost2tab(i+1)=costsave
5355         sint2tab(i+1)=sintsave
5356 C End of diagnostics section.
5357 #endif
5358 C
5359 C Compute the gradient of esc
5360 C
5361         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5362         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5363         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5364         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5365         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5366         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5367         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5368         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5369         pom1=(sumene3*sint2tab(i+1)+sumene1)
5370      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5371         pom2=(sumene4*cost2tab(i+1)+sumene2)
5372      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5373         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5374         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5375      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5376      &  +x(40)*yy*zz
5377         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5378         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5379      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5380      &  +x(60)*yy*zz
5381         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5382      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5383      &        +(pom1+pom2)*pom_dx
5384 #ifdef DEBUG
5385         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5386 #endif
5387 C
5388         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5389         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5390      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5391      &  +x(40)*xx*zz
5392         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5393         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5394      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5395      &  +x(59)*zz**2 +x(60)*xx*zz
5396         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5397      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5398      &        +(pom1-pom2)*pom_dy
5399 #ifdef DEBUG
5400         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5401 #endif
5402 C
5403         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5404      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5405      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5406      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5407      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5408      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5409      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5410      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5411 #ifdef DEBUG
5412         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5413 #endif
5414 C
5415         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5416      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5417      &  +pom1*pom_dt1+pom2*pom_dt2
5418 #ifdef DEBUG
5419         write(2,*), "de_dt = ", de_dt,de_dt_num
5420 #endif
5421 c
5422 C
5423        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5424        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5425        cosfac2xx=cosfac2*xx
5426        sinfac2yy=sinfac2*yy
5427        do k = 1,3
5428          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5429      &      vbld_inv(i+1)
5430          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5431      &      vbld_inv(i)
5432          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5433          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5434 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5435 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5436 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5437 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5438          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5439          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5440          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5441          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5442          dZZ_Ci1(k)=0.0d0
5443          dZZ_Ci(k)=0.0d0
5444          do j=1,3
5445            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5446            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5447          enddo
5448
5449          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5450          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5451          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5452 c
5453          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5454          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5455        enddo
5456
5457        do k=1,3
5458          dXX_Ctab(k,i)=dXX_Ci(k)
5459          dXX_C1tab(k,i)=dXX_Ci1(k)
5460          dYY_Ctab(k,i)=dYY_Ci(k)
5461          dYY_C1tab(k,i)=dYY_Ci1(k)
5462          dZZ_Ctab(k,i)=dZZ_Ci(k)
5463          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5464          dXX_XYZtab(k,i)=dXX_XYZ(k)
5465          dYY_XYZtab(k,i)=dYY_XYZ(k)
5466          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5467        enddo
5468
5469        do k = 1,3
5470 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5471 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5472 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5473 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5474 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5475 c     &    dt_dci(k)
5476 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5477 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5478          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5479      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5480          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5481      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5482          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5483      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5484        enddo
5485 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5486 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5487
5488 C to check gradient call subroutine check_grad
5489
5490     1 continue
5491       enddo
5492       return
5493       end
5494 c------------------------------------------------------------------------------
5495       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5496       implicit none
5497       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5498      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5499       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5500      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5501      &   + x(10)*yy*zz
5502       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5503      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5504      & + x(20)*yy*zz
5505       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5506      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5507      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5508      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5509      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5510      &  +x(40)*xx*yy*zz
5511       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5512      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5513      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5514      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5515      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5516      &  +x(60)*xx*yy*zz
5517       dsc_i   = 0.743d0+x(61)
5518       dp2_i   = 1.9d0+x(62)
5519       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5520      &          *(xx*cost2+yy*sint2))
5521       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5522      &          *(xx*cost2-yy*sint2))
5523       s1=(1+x(63))/(0.1d0 + dscp1)
5524       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5525       s2=(1+x(65))/(0.1d0 + dscp2)
5526       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5527       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5528      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5529       enesc=sumene
5530       return
5531       end
5532 #endif
5533 c------------------------------------------------------------------------------
5534       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5535 C
5536 C This procedure calculates two-body contact function g(rij) and its derivative:
5537 C
5538 C           eps0ij                                     !       x < -1
5539 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5540 C            0                                         !       x > 1
5541 C
5542 C where x=(rij-r0ij)/delta
5543 C
5544 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5545 C
5546       implicit none
5547       double precision rij,r0ij,eps0ij,fcont,fprimcont
5548       double precision x,x2,x4,delta
5549 c     delta=0.02D0*r0ij
5550 c      delta=0.2D0*r0ij
5551       x=(rij-r0ij)/delta
5552       if (x.lt.-1.0D0) then
5553         fcont=eps0ij
5554         fprimcont=0.0D0
5555       else if (x.le.1.0D0) then
5556         x2=x*x
5557         x4=x2*x2
5558         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5559         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5560       else
5561         fcont=0.0D0
5562         fprimcont=0.0D0
5563       endif
5564       return
5565       end
5566 c------------------------------------------------------------------------------
5567       subroutine splinthet(theti,delta,ss,ssder)
5568       implicit real*8 (a-h,o-z)
5569       include 'DIMENSIONS'
5570       include 'COMMON.VAR'
5571       include 'COMMON.GEO'
5572       thetup=pi-delta
5573       thetlow=delta
5574       if (theti.gt.pipol) then
5575         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5576       else
5577         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5578         ssder=-ssder
5579       endif
5580       return
5581       end
5582 c------------------------------------------------------------------------------
5583       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5584       implicit none
5585       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5586       double precision ksi,ksi2,ksi3,a1,a2,a3
5587       a1=fprim0*delta/(f1-f0)
5588       a2=3.0d0-2.0d0*a1
5589       a3=a1-2.0d0
5590       ksi=(x-x0)/delta
5591       ksi2=ksi*ksi
5592       ksi3=ksi2*ksi
5593       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5594       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5595       return
5596       end
5597 c------------------------------------------------------------------------------
5598       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5599       implicit none
5600       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5601       double precision ksi,ksi2,ksi3,a1,a2,a3
5602       ksi=(x-x0)/delta
5603       ksi2=ksi*ksi
5604       ksi3=ksi2*ksi
5605       a1=fprim0x*delta
5606       a2=3*(f1x-f0x)-2*fprim0x*delta
5607       a3=fprim0x*delta-2*(f1x-f0x)
5608       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5609       return
5610       end
5611 C-----------------------------------------------------------------------------
5612 #ifdef CRYST_TOR
5613 C-----------------------------------------------------------------------------
5614       subroutine etor(etors,edihcnstr)
5615       implicit real*8 (a-h,o-z)
5616       include 'DIMENSIONS'
5617       include 'COMMON.VAR'
5618       include 'COMMON.GEO'
5619       include 'COMMON.LOCAL'
5620       include 'COMMON.TORSION'
5621       include 'COMMON.INTERACT'
5622       include 'COMMON.DERIV'
5623       include 'COMMON.CHAIN'
5624       include 'COMMON.NAMES'
5625       include 'COMMON.IOUNITS'
5626       include 'COMMON.FFIELD'
5627       include 'COMMON.TORCNSTR'
5628       include 'COMMON.CONTROL'
5629       logical lprn
5630 C Set lprn=.true. for debugging
5631       lprn=.false.
5632 c      lprn=.true.
5633       etors=0.0D0
5634       do i=iphi_start,iphi_end
5635       etors_ii=0.0D0
5636         itori=itortyp(itype(i-2))
5637         itori1=itortyp(itype(i-1))
5638         phii=phi(i)
5639         gloci=0.0D0
5640 C Proline-Proline pair is a special case...
5641         if (itori.eq.3 .and. itori1.eq.3) then
5642           if (phii.gt.-dwapi3) then
5643             cosphi=dcos(3*phii)
5644             fac=1.0D0/(1.0D0-cosphi)
5645             etorsi=v1(1,3,3)*fac
5646             etorsi=etorsi+etorsi
5647             etors=etors+etorsi-v1(1,3,3)
5648             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5649             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5650           endif
5651           do j=1,3
5652             v1ij=v1(j+1,itori,itori1)
5653             v2ij=v2(j+1,itori,itori1)
5654             cosphi=dcos(j*phii)
5655             sinphi=dsin(j*phii)
5656             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5657             if (energy_dec) etors_ii=etors_ii+
5658      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5659             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5660           enddo
5661         else
5662           do j=1,nterm_old
5663             v1ij=v1(j,itori,itori1)
5664             v2ij=v2(j,itori,itori1)
5665             cosphi=dcos(j*phii)
5666             sinphi=dsin(j*phii)
5667             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5668             if (energy_dec) etors_ii=etors_ii+
5669      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5670             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5671           enddo
5672         endif
5673         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5674      &        'etor',i,etors_ii
5675         if (lprn)
5676      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5677      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5678      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5679         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5680         write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5681       enddo
5682 ! 6/20/98 - dihedral angle constraints
5683       edihcnstr=0.0d0
5684       do i=1,ndih_constr
5685         itori=idih_constr(i)
5686         phii=phi(itori)
5687         difi=phii-phi0(i)
5688         if (difi.gt.drange(i)) then
5689           difi=difi-drange(i)
5690           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5691           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5692         else if (difi.lt.-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         endif
5697 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5698 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5699       enddo
5700 !      write (iout,*) 'edihcnstr',edihcnstr
5701       return
5702       end
5703 c------------------------------------------------------------------------------
5704       subroutine etor_d(etors_d)
5705       etors_d=0.0d0
5706       return
5707       end
5708 c----------------------------------------------------------------------------
5709 #else
5710       subroutine etor(etors,edihcnstr)
5711       implicit real*8 (a-h,o-z)
5712       include 'DIMENSIONS'
5713       include 'COMMON.VAR'
5714       include 'COMMON.GEO'
5715       include 'COMMON.LOCAL'
5716       include 'COMMON.TORSION'
5717       include 'COMMON.INTERACT'
5718       include 'COMMON.DERIV'
5719       include 'COMMON.CHAIN'
5720       include 'COMMON.NAMES'
5721       include 'COMMON.IOUNITS'
5722       include 'COMMON.FFIELD'
5723       include 'COMMON.TORCNSTR'
5724       include 'COMMON.CONTROL'
5725       logical lprn
5726 C Set lprn=.true. for debugging
5727       lprn=.false.
5728 c     lprn=.true.
5729       etors=0.0D0
5730       do i=iphi_start,iphi_end
5731       etors_ii=0.0D0
5732         itori=itortyp(itype(i-2))
5733         itori1=itortyp(itype(i-1))
5734         phii=phi(i)
5735         gloci=0.0D0
5736 C Regular cosine and sine terms
5737         do j=1,nterm(itori,itori1)
5738           v1ij=v1(j,itori,itori1)
5739           v2ij=v2(j,itori,itori1)
5740           cosphi=dcos(j*phii)
5741           sinphi=dsin(j*phii)
5742           etors=etors+v1ij*cosphi+v2ij*sinphi
5743           if (energy_dec) etors_ii=etors_ii+
5744      &                v1ij*cosphi+v2ij*sinphi
5745           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5746         enddo
5747 C Lorentz terms
5748 C                         v1
5749 C  E = SUM ----------------------------------- - v1
5750 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5751 C
5752         cosphi=dcos(0.5d0*phii)
5753         sinphi=dsin(0.5d0*phii)
5754         do j=1,nlor(itori,itori1)
5755           vl1ij=vlor1(j,itori,itori1)
5756           vl2ij=vlor2(j,itori,itori1)
5757           vl3ij=vlor3(j,itori,itori1)
5758           pom=vl2ij*cosphi+vl3ij*sinphi
5759           pom1=1.0d0/(pom*pom+1.0d0)
5760           etors=etors+vl1ij*pom1
5761           if (energy_dec) etors_ii=etors_ii+
5762      &                vl1ij*pom1
5763           pom=-pom*pom1*pom1
5764           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5765         enddo
5766 C Subtract the constant term
5767         etors=etors-v0(itori,itori1)
5768           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5769      &         'etor',i,etors_ii-v0(itori,itori1)
5770         if (lprn)
5771      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5772      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5773      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5774         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5775 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5776       enddo
5777 ! 6/20/98 - dihedral angle constraints
5778       edihcnstr=0.0d0
5779 c      do i=1,ndih_constr
5780       do i=idihconstr_start,idihconstr_end
5781         itori=idih_constr(i)
5782         phii=phi(itori)
5783         difi=pinorm(phii-phi0(i))
5784         if (difi.gt.drange(i)) then
5785           difi=difi-drange(i)
5786           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5787           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5788         else if (difi.lt.-drange(i)) then
5789           difi=difi+drange(i)
5790           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5791           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5792         else
5793           difi=0.0
5794         endif
5795 c        write (iout,*) "gloci", gloc(i-3,icg)
5796 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5797 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5798 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5799       enddo
5800 cd       write (iout,*) 'edihcnstr',edihcnstr
5801       return
5802       end
5803 c----------------------------------------------------------------------------
5804       subroutine etor_d(etors_d)
5805 C 6/23/01 Compute double torsional energy
5806       implicit real*8 (a-h,o-z)
5807       include 'DIMENSIONS'
5808       include 'COMMON.VAR'
5809       include 'COMMON.GEO'
5810       include 'COMMON.LOCAL'
5811       include 'COMMON.TORSION'
5812       include 'COMMON.INTERACT'
5813       include 'COMMON.DERIV'
5814       include 'COMMON.CHAIN'
5815       include 'COMMON.NAMES'
5816       include 'COMMON.IOUNITS'
5817       include 'COMMON.FFIELD'
5818       include 'COMMON.TORCNSTR'
5819       logical lprn
5820 C Set lprn=.true. for debugging
5821       lprn=.false.
5822 c     lprn=.true.
5823       etors_d=0.0D0
5824       do i=iphid_start,iphid_end
5825         itori=itortyp(itype(i-2))
5826         itori1=itortyp(itype(i-1))
5827         itori2=itortyp(itype(i))
5828         phii=phi(i)
5829         phii1=phi(i+1)
5830         gloci1=0.0D0
5831         gloci2=0.0D0
5832         do j=1,ntermd_1(itori,itori1,itori2)
5833           v1cij=v1c(1,j,itori,itori1,itori2)
5834           v1sij=v1s(1,j,itori,itori1,itori2)
5835           v2cij=v1c(2,j,itori,itori1,itori2)
5836           v2sij=v1s(2,j,itori,itori1,itori2)
5837           cosphi1=dcos(j*phii)
5838           sinphi1=dsin(j*phii)
5839           cosphi2=dcos(j*phii1)
5840           sinphi2=dsin(j*phii1)
5841           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5842      &     v2cij*cosphi2+v2sij*sinphi2
5843           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5844           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5845         enddo
5846         do k=2,ntermd_2(itori,itori1,itori2)
5847           do l=1,k-1
5848             v1cdij = v2c(k,l,itori,itori1,itori2)
5849             v2cdij = v2c(l,k,itori,itori1,itori2)
5850             v1sdij = v2s(k,l,itori,itori1,itori2)
5851             v2sdij = v2s(l,k,itori,itori1,itori2)
5852             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5853             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5854             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5855             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5856             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5857      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5858             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5859      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5860             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5861      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5862           enddo
5863         enddo
5864         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5865         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5866 c        write (iout,*) "gloci", gloc(i-3,icg)
5867       enddo
5868       return
5869       end
5870 #endif
5871 c------------------------------------------------------------------------------
5872       subroutine eback_sc_corr(esccor)
5873 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5874 c        conformational states; temporarily implemented as differences
5875 c        between UNRES torsional potentials (dependent on three types of
5876 c        residues) and the torsional potentials dependent on all 20 types
5877 c        of residues computed from AM1  energy surfaces of terminally-blocked
5878 c        amino-acid residues.
5879       implicit real*8 (a-h,o-z)
5880       include 'DIMENSIONS'
5881       include 'COMMON.VAR'
5882       include 'COMMON.GEO'
5883       include 'COMMON.LOCAL'
5884       include 'COMMON.TORSION'
5885       include 'COMMON.SCCOR'
5886       include 'COMMON.INTERACT'
5887       include 'COMMON.DERIV'
5888       include 'COMMON.CHAIN'
5889       include 'COMMON.NAMES'
5890       include 'COMMON.IOUNITS'
5891       include 'COMMON.FFIELD'
5892       include 'COMMON.CONTROL'
5893       logical lprn
5894 C Set lprn=.true. for debugging
5895       lprn=.false.
5896 c      lprn=.true.
5897 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
5898       esccor=0.0D0
5899       do i=itau_start,itau_end
5900         esccor_ii=0.0D0
5901         isccori=isccortyp(itype(i-2))
5902         isccori1=isccortyp(itype(i-1))
5903         phii=phi(i)
5904 cccc  Added 9 May 2012
5905 cc Tauangle is torsional engle depending on the value of first digit
5906 c(see comment below)
5907 cc Omicron is flat angle depending on the value of first digit
5908 c(see comment below)
5909
5910
5911         do intertyp=1,3 !intertyp
5912 cc Added 09 May 2012 (Adasko)
5913 cc  Intertyp means interaction type of backbone mainchain correlation:
5914 c   1 = SC...Ca...Ca...Ca
5915 c   2 = Ca...Ca...Ca...SC
5916 c   3 = SC...Ca...Ca...SCi
5917         gloci=0.0D0
5918         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5919      &      (itype(i-1).eq.10).or.(itype(i-2).eq.21).or.
5920      &      (itype(i-1).eq.21)))
5921      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5922      &     .or.(itype(i-2).eq.21)))
5923      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5924      &      (itype(i-1).eq.21)))) cycle
5925         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle
5926         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21))
5927      & cycle
5928         do j=1,nterm_sccor(isccori,isccori1)
5929           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5930           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5931           cosphi=dcos(j*tauangle(intertyp,i))
5932           sinphi=dsin(j*tauangle(intertyp,i))
5933           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5934           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5935         enddo
5936         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5937 c        write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
5938 c     &gloc_sc(intertyp,i-3,icg)
5939         if (lprn)
5940      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5941      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5942      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
5943      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
5944         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5945        enddo !intertyp
5946       enddo
5947 c        do i=1,nres
5948 c        write (iout,*) "W@T@F",  gloc_sc(1,i,icg),gloc(i,icg)
5949 c        enddo
5950       return
5951       end
5952 c----------------------------------------------------------------------------
5953       subroutine multibody(ecorr)
5954 C This subroutine calculates multi-body contributions to energy following
5955 C the idea of Skolnick et al. If side chains I and J make a contact and
5956 C at the same time side chains I+1 and J+1 make a contact, an extra
5957 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5958       implicit real*8 (a-h,o-z)
5959       include 'DIMENSIONS'
5960       include 'COMMON.IOUNITS'
5961       include 'COMMON.DERIV'
5962       include 'COMMON.INTERACT'
5963       include 'COMMON.CONTACTS'
5964       double precision gx(3),gx1(3)
5965       logical lprn
5966
5967 C Set lprn=.true. for debugging
5968       lprn=.false.
5969
5970       if (lprn) then
5971         write (iout,'(a)') 'Contact function values:'
5972         do i=nnt,nct-2
5973           write (iout,'(i2,20(1x,i2,f10.5))')
5974      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5975         enddo
5976       endif
5977       ecorr=0.0D0
5978       do i=nnt,nct
5979         do j=1,3
5980           gradcorr(j,i)=0.0D0
5981           gradxorr(j,i)=0.0D0
5982         enddo
5983       enddo
5984       do i=nnt,nct-2
5985
5986         DO ISHIFT = 3,4
5987
5988         i1=i+ishift
5989         num_conti=num_cont(i)
5990         num_conti1=num_cont(i1)
5991         do jj=1,num_conti
5992           j=jcont(jj,i)
5993           do kk=1,num_conti1
5994             j1=jcont(kk,i1)
5995             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5996 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5997 cd   &                   ' ishift=',ishift
5998 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5999 C The system gains extra energy.
6000               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6001             endif   ! j1==j+-ishift
6002           enddo     ! kk
6003         enddo       ! jj
6004
6005         ENDDO ! ISHIFT
6006
6007       enddo         ! i
6008       return
6009       end
6010 c------------------------------------------------------------------------------
6011       double precision function esccorr(i,j,k,l,jj,kk)
6012       implicit real*8 (a-h,o-z)
6013       include 'DIMENSIONS'
6014       include 'COMMON.IOUNITS'
6015       include 'COMMON.DERIV'
6016       include 'COMMON.INTERACT'
6017       include 'COMMON.CONTACTS'
6018       double precision gx(3),gx1(3)
6019       logical lprn
6020       lprn=.false.
6021       eij=facont(jj,i)
6022       ekl=facont(kk,k)
6023 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6024 C Calculate the multi-body contribution to energy.
6025 C Calculate multi-body contributions to the gradient.
6026 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6027 cd   & k,l,(gacont(m,kk,k),m=1,3)
6028       do m=1,3
6029         gx(m) =ekl*gacont(m,jj,i)
6030         gx1(m)=eij*gacont(m,kk,k)
6031         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6032         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6033         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6034         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6035       enddo
6036       do m=i,j-1
6037         do ll=1,3
6038           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6039         enddo
6040       enddo
6041       do m=k,l-1
6042         do ll=1,3
6043           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6044         enddo
6045       enddo
6046       esccorr=-eij*ekl
6047       return
6048       end
6049 c------------------------------------------------------------------------------
6050       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6051 C This subroutine calculates multi-body contributions to hydrogen-bonding
6052       implicit real*8 (a-h,o-z)
6053       include 'DIMENSIONS'
6054       include 'COMMON.IOUNITS'
6055 #ifdef MPI
6056       include "mpif.h"
6057       parameter (max_cont=maxconts)
6058       parameter (max_dim=26)
6059       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6060       double precision zapas(max_dim,maxconts,max_fg_procs),
6061      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6062       common /przechowalnia/ zapas
6063       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6064      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6065 #endif
6066       include 'COMMON.SETUP'
6067       include 'COMMON.FFIELD'
6068       include 'COMMON.DERIV'
6069       include 'COMMON.INTERACT'
6070       include 'COMMON.CONTACTS'
6071       include 'COMMON.CONTROL'
6072       include 'COMMON.LOCAL'
6073       double precision gx(3),gx1(3),time00
6074       logical lprn,ldone
6075
6076 C Set lprn=.true. for debugging
6077       lprn=.false.
6078 #ifdef MPI
6079       n_corr=0
6080       n_corr1=0
6081       if (nfgtasks.le.1) goto 30
6082       if (lprn) then
6083         write (iout,'(a)') 'Contact function values before RECEIVE:'
6084         do i=nnt,nct-2
6085           write (iout,'(2i3,50(1x,i2,f5.2))')
6086      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6087      &    j=1,num_cont_hb(i))
6088         enddo
6089       endif
6090       call flush(iout)
6091       do i=1,ntask_cont_from
6092         ncont_recv(i)=0
6093       enddo
6094       do i=1,ntask_cont_to
6095         ncont_sent(i)=0
6096       enddo
6097 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6098 c     & ntask_cont_to
6099 C Make the list of contacts to send to send to other procesors
6100 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6101 c      call flush(iout)
6102       do i=iturn3_start,iturn3_end
6103 c        write (iout,*) "make contact list turn3",i," num_cont",
6104 c     &    num_cont_hb(i)
6105         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6106       enddo
6107       do i=iturn4_start,iturn4_end
6108 c        write (iout,*) "make contact list turn4",i," num_cont",
6109 c     &   num_cont_hb(i)
6110         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6111       enddo
6112       do ii=1,nat_sent
6113         i=iat_sent(ii)
6114 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6115 c     &    num_cont_hb(i)
6116         do j=1,num_cont_hb(i)
6117         do k=1,4
6118           jjc=jcont_hb(j,i)
6119           iproc=iint_sent_local(k,jjc,ii)
6120 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6121           if (iproc.gt.0) then
6122             ncont_sent(iproc)=ncont_sent(iproc)+1
6123             nn=ncont_sent(iproc)
6124             zapas(1,nn,iproc)=i
6125             zapas(2,nn,iproc)=jjc
6126             zapas(3,nn,iproc)=facont_hb(j,i)
6127             zapas(4,nn,iproc)=ees0p(j,i)
6128             zapas(5,nn,iproc)=ees0m(j,i)
6129             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6130             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6131             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6132             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6133             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6134             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6135             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6136             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6137             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6138             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6139             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6140             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6141             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6142             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6143             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6144             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6145             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6146             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6147             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6148             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6149             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6150           endif
6151         enddo
6152         enddo
6153       enddo
6154       if (lprn) then
6155       write (iout,*)
6156      &  "Numbers of contacts to be sent to other processors",
6157      &  (ncont_sent(i),i=1,ntask_cont_to)
6158       write (iout,*) "Contacts sent"
6159       do ii=1,ntask_cont_to
6160         nn=ncont_sent(ii)
6161         iproc=itask_cont_to(ii)
6162         write (iout,*) nn," contacts to processor",iproc,
6163      &   " of CONT_TO_COMM group"
6164         do i=1,nn
6165           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6166         enddo
6167       enddo
6168       call flush(iout)
6169       endif
6170       CorrelType=477
6171       CorrelID=fg_rank+1
6172       CorrelType1=478
6173       CorrelID1=nfgtasks+fg_rank+1
6174       ireq=0
6175 C Receive the numbers of needed contacts from other processors
6176       do ii=1,ntask_cont_from
6177         iproc=itask_cont_from(ii)
6178         ireq=ireq+1
6179         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6180      &    FG_COMM,req(ireq),IERR)
6181       enddo
6182 c      write (iout,*) "IRECV ended"
6183 c      call flush(iout)
6184 C Send the number of contacts needed by other processors
6185       do ii=1,ntask_cont_to
6186         iproc=itask_cont_to(ii)
6187         ireq=ireq+1
6188         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6189      &    FG_COMM,req(ireq),IERR)
6190       enddo
6191 c      write (iout,*) "ISEND ended"
6192 c      write (iout,*) "number of requests (nn)",ireq
6193       call flush(iout)
6194       if (ireq.gt.0)
6195      &  call MPI_Waitall(ireq,req,status_array,ierr)
6196 c      write (iout,*)
6197 c     &  "Numbers of contacts to be received from other processors",
6198 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6199 c      call flush(iout)
6200 C Receive contacts
6201       ireq=0
6202       do ii=1,ntask_cont_from
6203         iproc=itask_cont_from(ii)
6204         nn=ncont_recv(ii)
6205 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6206 c     &   " of CONT_TO_COMM group"
6207         call flush(iout)
6208         if (nn.gt.0) then
6209           ireq=ireq+1
6210           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6211      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6212 c          write (iout,*) "ireq,req",ireq,req(ireq)
6213         endif
6214       enddo
6215 C Send the contacts to processors that need them
6216       do ii=1,ntask_cont_to
6217         iproc=itask_cont_to(ii)
6218         nn=ncont_sent(ii)
6219 c        write (iout,*) nn," contacts to processor",iproc,
6220 c     &   " of CONT_TO_COMM group"
6221         if (nn.gt.0) then
6222           ireq=ireq+1
6223           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6224      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6225 c          write (iout,*) "ireq,req",ireq,req(ireq)
6226 c          do i=1,nn
6227 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6228 c          enddo
6229         endif
6230       enddo
6231 c      write (iout,*) "number of requests (contacts)",ireq
6232 c      write (iout,*) "req",(req(i),i=1,4)
6233 c      call flush(iout)
6234       if (ireq.gt.0)
6235      & call MPI_Waitall(ireq,req,status_array,ierr)
6236       do iii=1,ntask_cont_from
6237         iproc=itask_cont_from(iii)
6238         nn=ncont_recv(iii)
6239         if (lprn) then
6240         write (iout,*) "Received",nn," contacts from processor",iproc,
6241      &   " of CONT_FROM_COMM group"
6242         call flush(iout)
6243         do i=1,nn
6244           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6245         enddo
6246         call flush(iout)
6247         endif
6248         do i=1,nn
6249           ii=zapas_recv(1,i,iii)
6250 c Flag the received contacts to prevent double-counting
6251           jj=-zapas_recv(2,i,iii)
6252 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6253 c          call flush(iout)
6254           nnn=num_cont_hb(ii)+1
6255           num_cont_hb(ii)=nnn
6256           jcont_hb(nnn,ii)=jj
6257           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6258           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6259           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6260           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6261           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6262           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6263           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6264           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6265           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6266           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6267           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6268           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6269           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6270           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6271           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6272           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6273           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6274           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6275           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6276           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6277           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6278           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6279           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6280           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6281         enddo
6282       enddo
6283       call flush(iout)
6284       if (lprn) then
6285         write (iout,'(a)') 'Contact function values after receive:'
6286         do i=nnt,nct-2
6287           write (iout,'(2i3,50(1x,i3,f5.2))')
6288      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6289      &    j=1,num_cont_hb(i))
6290         enddo
6291         call flush(iout)
6292       endif
6293    30 continue
6294 #endif
6295       if (lprn) then
6296         write (iout,'(a)') 'Contact function values:'
6297         do i=nnt,nct-2
6298           write (iout,'(2i3,50(1x,i3,f5.2))')
6299      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6300      &    j=1,num_cont_hb(i))
6301         enddo
6302       endif
6303       ecorr=0.0D0
6304 C Remove the loop below after debugging !!!
6305       do i=nnt,nct
6306         do j=1,3
6307           gradcorr(j,i)=0.0D0
6308           gradxorr(j,i)=0.0D0
6309         enddo
6310       enddo
6311 C Calculate the local-electrostatic correlation terms
6312       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6313         i1=i+1
6314         num_conti=num_cont_hb(i)
6315         num_conti1=num_cont_hb(i+1)
6316         do jj=1,num_conti
6317           j=jcont_hb(jj,i)
6318           jp=iabs(j)
6319           do kk=1,num_conti1
6320             j1=jcont_hb(kk,i1)
6321             jp1=iabs(j1)
6322 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6323 c     &         ' jj=',jj,' kk=',kk
6324             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6325      &          .or. j.lt.0 .and. j1.gt.0) .and.
6326      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6327 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6328 C The system gains extra energy.
6329               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6330               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6331      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6332               n_corr=n_corr+1
6333             else if (j1.eq.j) then
6334 C Contacts I-J and I-(J+1) occur simultaneously.
6335 C The system loses extra energy.
6336 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6337             endif
6338           enddo ! kk
6339           do kk=1,num_conti
6340             j1=jcont_hb(kk,i)
6341 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6342 c    &         ' jj=',jj,' kk=',kk
6343             if (j1.eq.j+1) then
6344 C Contacts I-J and (I+1)-J occur simultaneously.
6345 C The system loses extra energy.
6346 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6347             endif ! j1==j+1
6348           enddo ! kk
6349         enddo ! jj
6350       enddo ! i
6351       return
6352       end
6353 c------------------------------------------------------------------------------
6354       subroutine add_hb_contact(ii,jj,itask)
6355       implicit real*8 (a-h,o-z)
6356       include "DIMENSIONS"
6357       include "COMMON.IOUNITS"
6358       integer max_cont
6359       integer max_dim
6360       parameter (max_cont=maxconts)
6361       parameter (max_dim=26)
6362       include "COMMON.CONTACTS"
6363       double precision zapas(max_dim,maxconts,max_fg_procs),
6364      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6365       common /przechowalnia/ zapas
6366       integer i,j,ii,jj,iproc,itask(4),nn
6367 c      write (iout,*) "itask",itask
6368       do i=1,2
6369         iproc=itask(i)
6370         if (iproc.gt.0) then
6371           do j=1,num_cont_hb(ii)
6372             jjc=jcont_hb(j,ii)
6373 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6374             if (jjc.eq.jj) then
6375               ncont_sent(iproc)=ncont_sent(iproc)+1
6376               nn=ncont_sent(iproc)
6377               zapas(1,nn,iproc)=ii
6378               zapas(2,nn,iproc)=jjc
6379               zapas(3,nn,iproc)=facont_hb(j,ii)
6380               zapas(4,nn,iproc)=ees0p(j,ii)
6381               zapas(5,nn,iproc)=ees0m(j,ii)
6382               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6383               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6384               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6385               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6386               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6387               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6388               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6389               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6390               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6391               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6392               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6393               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6394               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6395               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6396               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6397               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6398               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6399               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6400               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6401               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6402               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6403               exit
6404             endif
6405           enddo
6406         endif
6407       enddo
6408       return
6409       end
6410 c------------------------------------------------------------------------------
6411       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6412      &  n_corr1)
6413 C This subroutine calculates multi-body contributions to hydrogen-bonding
6414       implicit real*8 (a-h,o-z)
6415       include 'DIMENSIONS'
6416       include 'COMMON.IOUNITS'
6417 #ifdef MPI
6418       include "mpif.h"
6419       parameter (max_cont=maxconts)
6420       parameter (max_dim=70)
6421       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6422       double precision zapas(max_dim,maxconts,max_fg_procs),
6423      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6424       common /przechowalnia/ zapas
6425       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6426      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6427 #endif
6428       include 'COMMON.SETUP'
6429       include 'COMMON.FFIELD'
6430       include 'COMMON.DERIV'
6431       include 'COMMON.LOCAL'
6432       include 'COMMON.INTERACT'
6433       include 'COMMON.CONTACTS'
6434       include 'COMMON.CHAIN'
6435       include 'COMMON.CONTROL'
6436       double precision gx(3),gx1(3)
6437       integer num_cont_hb_old(maxres)
6438       logical lprn,ldone
6439       double precision eello4,eello5,eelo6,eello_turn6
6440       external eello4,eello5,eello6,eello_turn6
6441 C Set lprn=.true. for debugging
6442       lprn=.false.
6443       eturn6=0.0d0
6444 #ifdef MPI
6445       do i=1,nres
6446         num_cont_hb_old(i)=num_cont_hb(i)
6447       enddo
6448       n_corr=0
6449       n_corr1=0
6450       if (nfgtasks.le.1) goto 30
6451       if (lprn) then
6452         write (iout,'(a)') 'Contact function values before RECEIVE:'
6453         do i=nnt,nct-2
6454           write (iout,'(2i3,50(1x,i2,f5.2))')
6455      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6456      &    j=1,num_cont_hb(i))
6457         enddo
6458       endif
6459       call flush(iout)
6460       do i=1,ntask_cont_from
6461         ncont_recv(i)=0
6462       enddo
6463       do i=1,ntask_cont_to
6464         ncont_sent(i)=0
6465       enddo
6466 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6467 c     & ntask_cont_to
6468 C Make the list of contacts to send to send to other procesors
6469       do i=iturn3_start,iturn3_end
6470 c        write (iout,*) "make contact list turn3",i," num_cont",
6471 c     &    num_cont_hb(i)
6472         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6473       enddo
6474       do i=iturn4_start,iturn4_end
6475 c        write (iout,*) "make contact list turn4",i," num_cont",
6476 c     &   num_cont_hb(i)
6477         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6478       enddo
6479       do ii=1,nat_sent
6480         i=iat_sent(ii)
6481 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6482 c     &    num_cont_hb(i)
6483         do j=1,num_cont_hb(i)
6484         do k=1,4
6485           jjc=jcont_hb(j,i)
6486           iproc=iint_sent_local(k,jjc,ii)
6487 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6488           if (iproc.ne.0) then
6489             ncont_sent(iproc)=ncont_sent(iproc)+1
6490             nn=ncont_sent(iproc)
6491             zapas(1,nn,iproc)=i
6492             zapas(2,nn,iproc)=jjc
6493             zapas(3,nn,iproc)=d_cont(j,i)
6494             ind=3
6495             do kk=1,3
6496               ind=ind+1
6497               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6498             enddo
6499             do kk=1,2
6500               do ll=1,2
6501                 ind=ind+1
6502                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6503               enddo
6504             enddo
6505             do jj=1,5
6506               do kk=1,3
6507                 do ll=1,2
6508                   do mm=1,2
6509                     ind=ind+1
6510                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6511                   enddo
6512                 enddo
6513               enddo
6514             enddo
6515           endif
6516         enddo
6517         enddo
6518       enddo
6519       if (lprn) then
6520       write (iout,*)
6521      &  "Numbers of contacts to be sent to other processors",
6522      &  (ncont_sent(i),i=1,ntask_cont_to)
6523       write (iout,*) "Contacts sent"
6524       do ii=1,ntask_cont_to
6525         nn=ncont_sent(ii)
6526         iproc=itask_cont_to(ii)
6527         write (iout,*) nn," contacts to processor",iproc,
6528      &   " of CONT_TO_COMM group"
6529         do i=1,nn
6530           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6531         enddo
6532       enddo
6533       call flush(iout)
6534       endif
6535       CorrelType=477
6536       CorrelID=fg_rank+1
6537       CorrelType1=478
6538       CorrelID1=nfgtasks+fg_rank+1
6539       ireq=0
6540 C Receive the numbers of needed contacts from other processors
6541       do ii=1,ntask_cont_from
6542         iproc=itask_cont_from(ii)
6543         ireq=ireq+1
6544         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6545      &    FG_COMM,req(ireq),IERR)
6546       enddo
6547 c      write (iout,*) "IRECV ended"
6548 c      call flush(iout)
6549 C Send the number of contacts needed by other processors
6550       do ii=1,ntask_cont_to
6551         iproc=itask_cont_to(ii)
6552         ireq=ireq+1
6553         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6554      &    FG_COMM,req(ireq),IERR)
6555       enddo
6556 c      write (iout,*) "ISEND ended"
6557 c      write (iout,*) "number of requests (nn)",ireq
6558       call flush(iout)
6559       if (ireq.gt.0)
6560      &  call MPI_Waitall(ireq,req,status_array,ierr)
6561 c      write (iout,*)
6562 c     &  "Numbers of contacts to be received from other processors",
6563 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6564 c      call flush(iout)
6565 C Receive contacts
6566       ireq=0
6567       do ii=1,ntask_cont_from
6568         iproc=itask_cont_from(ii)
6569         nn=ncont_recv(ii)
6570 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6571 c     &   " of CONT_TO_COMM group"
6572         call flush(iout)
6573         if (nn.gt.0) then
6574           ireq=ireq+1
6575           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6576      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6577 c          write (iout,*) "ireq,req",ireq,req(ireq)
6578         endif
6579       enddo
6580 C Send the contacts to processors that need them
6581       do ii=1,ntask_cont_to
6582         iproc=itask_cont_to(ii)
6583         nn=ncont_sent(ii)
6584 c        write (iout,*) nn," contacts to processor",iproc,
6585 c     &   " of CONT_TO_COMM group"
6586         if (nn.gt.0) then
6587           ireq=ireq+1
6588           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6589      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6590 c          write (iout,*) "ireq,req",ireq,req(ireq)
6591 c          do i=1,nn
6592 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6593 c          enddo
6594         endif
6595       enddo
6596 c      write (iout,*) "number of requests (contacts)",ireq
6597 c      write (iout,*) "req",(req(i),i=1,4)
6598 c      call flush(iout)
6599       if (ireq.gt.0)
6600      & call MPI_Waitall(ireq,req,status_array,ierr)
6601       do iii=1,ntask_cont_from
6602         iproc=itask_cont_from(iii)
6603         nn=ncont_recv(iii)
6604         if (lprn) then
6605         write (iout,*) "Received",nn," contacts from processor",iproc,
6606      &   " of CONT_FROM_COMM group"
6607         call flush(iout)
6608         do i=1,nn
6609           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6610         enddo
6611         call flush(iout)
6612         endif
6613         do i=1,nn
6614           ii=zapas_recv(1,i,iii)
6615 c Flag the received contacts to prevent double-counting
6616           jj=-zapas_recv(2,i,iii)
6617 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6618 c          call flush(iout)
6619           nnn=num_cont_hb(ii)+1
6620           num_cont_hb(ii)=nnn
6621           jcont_hb(nnn,ii)=jj
6622           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6623           ind=3
6624           do kk=1,3
6625             ind=ind+1
6626             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6627           enddo
6628           do kk=1,2
6629             do ll=1,2
6630               ind=ind+1
6631               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6632             enddo
6633           enddo
6634           do jj=1,5
6635             do kk=1,3
6636               do ll=1,2
6637                 do mm=1,2
6638                   ind=ind+1
6639                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6640                 enddo
6641               enddo
6642             enddo
6643           enddo
6644         enddo
6645       enddo
6646       call flush(iout)
6647       if (lprn) then
6648         write (iout,'(a)') 'Contact function values after receive:'
6649         do i=nnt,nct-2
6650           write (iout,'(2i3,50(1x,i3,5f6.3))')
6651      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6652      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6653         enddo
6654         call flush(iout)
6655       endif
6656    30 continue
6657 #endif
6658       if (lprn) then
6659         write (iout,'(a)') 'Contact function values:'
6660         do i=nnt,nct-2
6661           write (iout,'(2i3,50(1x,i2,5f6.3))')
6662      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6663      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6664         enddo
6665       endif
6666       ecorr=0.0D0
6667       ecorr5=0.0d0
6668       ecorr6=0.0d0
6669 C Remove the loop below after debugging !!!
6670       do i=nnt,nct
6671         do j=1,3
6672           gradcorr(j,i)=0.0D0
6673           gradxorr(j,i)=0.0D0
6674         enddo
6675       enddo
6676 C Calculate the dipole-dipole interaction energies
6677       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6678       do i=iatel_s,iatel_e+1
6679         num_conti=num_cont_hb(i)
6680         do jj=1,num_conti
6681           j=jcont_hb(jj,i)
6682 #ifdef MOMENT
6683           call dipole(i,j,jj)
6684 #endif
6685         enddo
6686       enddo
6687       endif
6688 C Calculate the local-electrostatic correlation terms
6689 c                write (iout,*) "gradcorr5 in eello5 before loop"
6690 c                do iii=1,nres
6691 c                  write (iout,'(i5,3f10.5)')
6692 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6693 c                enddo
6694       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6695 c        write (iout,*) "corr loop i",i
6696         i1=i+1
6697         num_conti=num_cont_hb(i)
6698         num_conti1=num_cont_hb(i+1)
6699         do jj=1,num_conti
6700           j=jcont_hb(jj,i)
6701           jp=iabs(j)
6702           do kk=1,num_conti1
6703             j1=jcont_hb(kk,i1)
6704             jp1=iabs(j1)
6705 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6706 c     &         ' jj=',jj,' kk=',kk
6707 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6708             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6709      &          .or. j.lt.0 .and. j1.gt.0) .and.
6710      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6711 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6712 C The system gains extra energy.
6713               n_corr=n_corr+1
6714               sqd1=dsqrt(d_cont(jj,i))
6715               sqd2=dsqrt(d_cont(kk,i1))
6716               sred_geom = sqd1*sqd2
6717               IF (sred_geom.lt.cutoff_corr) THEN
6718                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6719      &            ekont,fprimcont)
6720 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6721 cd     &         ' jj=',jj,' kk=',kk
6722                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6723                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6724                 do l=1,3
6725                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6726                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6727                 enddo
6728                 n_corr1=n_corr1+1
6729 cd               write (iout,*) 'sred_geom=',sred_geom,
6730 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6731 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6732 cd               write (iout,*) "g_contij",g_contij
6733 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6734 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6735                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6736                 if (wcorr4.gt.0.0d0)
6737      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6738                   if (energy_dec.and.wcorr4.gt.0.0d0)
6739      1                 write (iout,'(a6,4i5,0pf7.3)')
6740      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6741 c                write (iout,*) "gradcorr5 before eello5"
6742 c                do iii=1,nres
6743 c                  write (iout,'(i5,3f10.5)')
6744 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6745 c                enddo
6746                 if (wcorr5.gt.0.0d0)
6747      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6748 c                write (iout,*) "gradcorr5 after eello5"
6749 c                do iii=1,nres
6750 c                  write (iout,'(i5,3f10.5)')
6751 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6752 c                enddo
6753                   if (energy_dec.and.wcorr5.gt.0.0d0)
6754      1                 write (iout,'(a6,4i5,0pf7.3)')
6755      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6756 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6757 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6758                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6759      &               .or. wturn6.eq.0.0d0))then
6760 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6761                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6762                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6763      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6764 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6765 cd     &            'ecorr6=',ecorr6
6766 cd                write (iout,'(4e15.5)') sred_geom,
6767 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6768 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6769 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6770                 else if (wturn6.gt.0.0d0
6771      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6772 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6773                   eturn6=eturn6+eello_turn6(i,jj,kk)
6774                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6775      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6776 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6777                 endif
6778               ENDIF
6779 1111          continue
6780             endif
6781           enddo ! kk
6782         enddo ! jj
6783       enddo ! i
6784       do i=1,nres
6785         num_cont_hb(i)=num_cont_hb_old(i)
6786       enddo
6787 c                write (iout,*) "gradcorr5 in eello5"
6788 c                do iii=1,nres
6789 c                  write (iout,'(i5,3f10.5)')
6790 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6791 c                enddo
6792       return
6793       end
6794 c------------------------------------------------------------------------------
6795       subroutine add_hb_contact_eello(ii,jj,itask)
6796       implicit real*8 (a-h,o-z)
6797       include "DIMENSIONS"
6798       include "COMMON.IOUNITS"
6799       integer max_cont
6800       integer max_dim
6801       parameter (max_cont=maxconts)
6802       parameter (max_dim=70)
6803       include "COMMON.CONTACTS"
6804       double precision zapas(max_dim,maxconts,max_fg_procs),
6805      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6806       common /przechowalnia/ zapas
6807       integer i,j,ii,jj,iproc,itask(4),nn
6808 c      write (iout,*) "itask",itask
6809       do i=1,2
6810         iproc=itask(i)
6811         if (iproc.gt.0) then
6812           do j=1,num_cont_hb(ii)
6813             jjc=jcont_hb(j,ii)
6814 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6815             if (jjc.eq.jj) then
6816               ncont_sent(iproc)=ncont_sent(iproc)+1
6817               nn=ncont_sent(iproc)
6818               zapas(1,nn,iproc)=ii
6819               zapas(2,nn,iproc)=jjc
6820               zapas(3,nn,iproc)=d_cont(j,ii)
6821               ind=3
6822               do kk=1,3
6823                 ind=ind+1
6824                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6825               enddo
6826               do kk=1,2
6827                 do ll=1,2
6828                   ind=ind+1
6829                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6830                 enddo
6831               enddo
6832               do jj=1,5
6833                 do kk=1,3
6834                   do ll=1,2
6835                     do mm=1,2
6836                       ind=ind+1
6837                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6838                     enddo
6839                   enddo
6840                 enddo
6841               enddo
6842               exit
6843             endif
6844           enddo
6845         endif
6846       enddo
6847       return
6848       end
6849 c------------------------------------------------------------------------------
6850       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6851       implicit real*8 (a-h,o-z)
6852       include 'DIMENSIONS'
6853       include 'COMMON.IOUNITS'
6854       include 'COMMON.DERIV'
6855       include 'COMMON.INTERACT'
6856       include 'COMMON.CONTACTS'
6857       double precision gx(3),gx1(3)
6858       logical lprn
6859       lprn=.false.
6860       eij=facont_hb(jj,i)
6861       ekl=facont_hb(kk,k)
6862       ees0pij=ees0p(jj,i)
6863       ees0pkl=ees0p(kk,k)
6864       ees0mij=ees0m(jj,i)
6865       ees0mkl=ees0m(kk,k)
6866       ekont=eij*ekl
6867       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6868 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6869 C Following 4 lines for diagnostics.
6870 cd    ees0pkl=0.0D0
6871 cd    ees0pij=1.0D0
6872 cd    ees0mkl=0.0D0
6873 cd    ees0mij=1.0D0
6874 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6875 c     & 'Contacts ',i,j,
6876 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6877 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6878 c     & 'gradcorr_long'
6879 C Calculate the multi-body contribution to energy.
6880 c      ecorr=ecorr+ekont*ees
6881 C Calculate multi-body contributions to the gradient.
6882       coeffpees0pij=coeffp*ees0pij
6883       coeffmees0mij=coeffm*ees0mij
6884       coeffpees0pkl=coeffp*ees0pkl
6885       coeffmees0mkl=coeffm*ees0mkl
6886       do ll=1,3
6887 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6888         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6889      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6890      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6891         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6892      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6893      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6894 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6895         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6896      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6897      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6898         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6899      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6900      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6901         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6902      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6903      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6904         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6905         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6906         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6907      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6908      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6909         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6910         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6911 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6912       enddo
6913 c      write (iout,*)
6914 cgrad      do m=i+1,j-1
6915 cgrad        do ll=1,3
6916 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6917 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6918 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6919 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6920 cgrad        enddo
6921 cgrad      enddo
6922 cgrad      do m=k+1,l-1
6923 cgrad        do ll=1,3
6924 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6925 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6926 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6927 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6928 cgrad        enddo
6929 cgrad      enddo
6930 c      write (iout,*) "ehbcorr",ekont*ees
6931       ehbcorr=ekont*ees
6932       return
6933       end
6934 #ifdef MOMENT
6935 C---------------------------------------------------------------------------
6936       subroutine dipole(i,j,jj)
6937       implicit real*8 (a-h,o-z)
6938       include 'DIMENSIONS'
6939       include 'COMMON.IOUNITS'
6940       include 'COMMON.CHAIN'
6941       include 'COMMON.FFIELD'
6942       include 'COMMON.DERIV'
6943       include 'COMMON.INTERACT'
6944       include 'COMMON.CONTACTS'
6945       include 'COMMON.TORSION'
6946       include 'COMMON.VAR'
6947       include 'COMMON.GEO'
6948       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6949      &  auxmat(2,2)
6950       iti1 = itortyp(itype(i+1))
6951       if (j.lt.nres-1) then
6952         itj1 = itortyp(itype(j+1))
6953       else
6954         itj1=ntortyp+1
6955       endif
6956       do iii=1,2
6957         dipi(iii,1)=Ub2(iii,i)
6958         dipderi(iii)=Ub2der(iii,i)
6959         dipi(iii,2)=b1(iii,iti1)
6960         dipj(iii,1)=Ub2(iii,j)
6961         dipderj(iii)=Ub2der(iii,j)
6962         dipj(iii,2)=b1(iii,itj1)
6963       enddo
6964       kkk=0
6965       do iii=1,2
6966         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6967         do jjj=1,2
6968           kkk=kkk+1
6969           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6970         enddo
6971       enddo
6972       do kkk=1,5
6973         do lll=1,3
6974           mmm=0
6975           do iii=1,2
6976             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6977      &        auxvec(1))
6978             do jjj=1,2
6979               mmm=mmm+1
6980               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6981             enddo
6982           enddo
6983         enddo
6984       enddo
6985       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6986       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6987       do iii=1,2
6988         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6989       enddo
6990       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6991       do iii=1,2
6992         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6993       enddo
6994       return
6995       end
6996 #endif
6997 C---------------------------------------------------------------------------
6998       subroutine calc_eello(i,j,k,l,jj,kk)
6999 C
7000 C This subroutine computes matrices and vectors needed to calculate
7001 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7002 C
7003       implicit real*8 (a-h,o-z)
7004       include 'DIMENSIONS'
7005       include 'COMMON.IOUNITS'
7006       include 'COMMON.CHAIN'
7007       include 'COMMON.DERIV'
7008       include 'COMMON.INTERACT'
7009       include 'COMMON.CONTACTS'
7010       include 'COMMON.TORSION'
7011       include 'COMMON.VAR'
7012       include 'COMMON.GEO'
7013       include 'COMMON.FFIELD'
7014       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7015      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7016       logical lprn
7017       common /kutas/ lprn
7018 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7019 cd     & ' jj=',jj,' kk=',kk
7020 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7021 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7022 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7023       do iii=1,2
7024         do jjj=1,2
7025           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7026           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7027         enddo
7028       enddo
7029       call transpose2(aa1(1,1),aa1t(1,1))
7030       call transpose2(aa2(1,1),aa2t(1,1))
7031       do kkk=1,5
7032         do lll=1,3
7033           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7034      &      aa1tder(1,1,lll,kkk))
7035           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7036      &      aa2tder(1,1,lll,kkk))
7037         enddo
7038       enddo
7039       if (l.eq.j+1) then
7040 C parallel orientation of the two CA-CA-CA frames.
7041         if (i.gt.1) then
7042           iti=itortyp(itype(i))
7043         else
7044           iti=ntortyp+1
7045         endif
7046         itk1=itortyp(itype(k+1))
7047         itj=itortyp(itype(j))
7048         if (l.lt.nres-1) then
7049           itl1=itortyp(itype(l+1))
7050         else
7051           itl1=ntortyp+1
7052         endif
7053 C A1 kernel(j+1) A2T
7054 cd        do iii=1,2
7055 cd          write (iout,'(3f10.5,5x,3f10.5)')
7056 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7057 cd        enddo
7058         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7059      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7060      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7061 C Following matrices are needed only for 6-th order cumulants
7062         IF (wcorr6.gt.0.0d0) THEN
7063         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7064      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7065      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7066         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7067      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7068      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7069      &   ADtEAderx(1,1,1,1,1,1))
7070         lprn=.false.
7071         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7072      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7073      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7074      &   ADtEA1derx(1,1,1,1,1,1))
7075         ENDIF
7076 C End 6-th order cumulants
7077 cd        lprn=.false.
7078 cd        if (lprn) then
7079 cd        write (2,*) 'In calc_eello6'
7080 cd        do iii=1,2
7081 cd          write (2,*) 'iii=',iii
7082 cd          do kkk=1,5
7083 cd            write (2,*) 'kkk=',kkk
7084 cd            do jjj=1,2
7085 cd              write (2,'(3(2f10.5),5x)')
7086 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7087 cd            enddo
7088 cd          enddo
7089 cd        enddo
7090 cd        endif
7091         call transpose2(EUgder(1,1,k),auxmat(1,1))
7092         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7093         call transpose2(EUg(1,1,k),auxmat(1,1))
7094         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7095         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7096         do iii=1,2
7097           do kkk=1,5
7098             do lll=1,3
7099               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7100      &          EAEAderx(1,1,lll,kkk,iii,1))
7101             enddo
7102           enddo
7103         enddo
7104 C A1T kernel(i+1) A2
7105         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7106      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7107      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7108 C Following matrices are needed only for 6-th order cumulants
7109         IF (wcorr6.gt.0.0d0) THEN
7110         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7111      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7112      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7113         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7114      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7115      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7116      &   ADtEAderx(1,1,1,1,1,2))
7117         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7118      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7119      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7120      &   ADtEA1derx(1,1,1,1,1,2))
7121         ENDIF
7122 C End 6-th order cumulants
7123         call transpose2(EUgder(1,1,l),auxmat(1,1))
7124         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7125         call transpose2(EUg(1,1,l),auxmat(1,1))
7126         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7127         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7128         do iii=1,2
7129           do kkk=1,5
7130             do lll=1,3
7131               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7132      &          EAEAderx(1,1,lll,kkk,iii,2))
7133             enddo
7134           enddo
7135         enddo
7136 C AEAb1 and AEAb2
7137 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7138 C They are needed only when the fifth- or the sixth-order cumulants are
7139 C indluded.
7140         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7141         call transpose2(AEA(1,1,1),auxmat(1,1))
7142         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7143         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7144         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7145         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7146         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7147         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7148         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7149         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7150         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7151         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7152         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7153         call transpose2(AEA(1,1,2),auxmat(1,1))
7154         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7155         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7156         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7157         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7158         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7159         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7160         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7161         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7162         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7163         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7164         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7165 C Calculate the Cartesian derivatives of the vectors.
7166         do iii=1,2
7167           do kkk=1,5
7168             do lll=1,3
7169               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7170               call matvec2(auxmat(1,1),b1(1,iti),
7171      &          AEAb1derx(1,lll,kkk,iii,1,1))
7172               call matvec2(auxmat(1,1),Ub2(1,i),
7173      &          AEAb2derx(1,lll,kkk,iii,1,1))
7174               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7175      &          AEAb1derx(1,lll,kkk,iii,2,1))
7176               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7177      &          AEAb2derx(1,lll,kkk,iii,2,1))
7178               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7179               call matvec2(auxmat(1,1),b1(1,itj),
7180      &          AEAb1derx(1,lll,kkk,iii,1,2))
7181               call matvec2(auxmat(1,1),Ub2(1,j),
7182      &          AEAb2derx(1,lll,kkk,iii,1,2))
7183               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7184      &          AEAb1derx(1,lll,kkk,iii,2,2))
7185               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7186      &          AEAb2derx(1,lll,kkk,iii,2,2))
7187             enddo
7188           enddo
7189         enddo
7190         ENDIF
7191 C End vectors
7192       else
7193 C Antiparallel orientation of the two CA-CA-CA frames.
7194         if (i.gt.1) then
7195           iti=itortyp(itype(i))
7196         else
7197           iti=ntortyp+1
7198         endif
7199         itk1=itortyp(itype(k+1))
7200         itl=itortyp(itype(l))
7201         itj=itortyp(itype(j))
7202         if (j.lt.nres-1) then
7203           itj1=itortyp(itype(j+1))
7204         else
7205           itj1=ntortyp+1
7206         endif
7207 C A2 kernel(j-1)T A1T
7208         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7209      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7210      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7211 C Following matrices are needed only for 6-th order cumulants
7212         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7213      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7214         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7215      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7216      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7217         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7218      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7219      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7220      &   ADtEAderx(1,1,1,1,1,1))
7221         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7222      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7223      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7224      &   ADtEA1derx(1,1,1,1,1,1))
7225         ENDIF
7226 C End 6-th order cumulants
7227         call transpose2(EUgder(1,1,k),auxmat(1,1))
7228         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7229         call transpose2(EUg(1,1,k),auxmat(1,1))
7230         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7231         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7232         do iii=1,2
7233           do kkk=1,5
7234             do lll=1,3
7235               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7236      &          EAEAderx(1,1,lll,kkk,iii,1))
7237             enddo
7238           enddo
7239         enddo
7240 C A2T kernel(i+1)T A1
7241         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7242      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7243      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7244 C Following matrices are needed only for 6-th order cumulants
7245         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7246      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7247         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7248      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7249      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7250         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7251      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7252      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7253      &   ADtEAderx(1,1,1,1,1,2))
7254         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7255      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7256      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7257      &   ADtEA1derx(1,1,1,1,1,2))
7258         ENDIF
7259 C End 6-th order cumulants
7260         call transpose2(EUgder(1,1,j),auxmat(1,1))
7261         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7262         call transpose2(EUg(1,1,j),auxmat(1,1))
7263         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7264         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7265         do iii=1,2
7266           do kkk=1,5
7267             do lll=1,3
7268               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7269      &          EAEAderx(1,1,lll,kkk,iii,2))
7270             enddo
7271           enddo
7272         enddo
7273 C AEAb1 and AEAb2
7274 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7275 C They are needed only when the fifth- or the sixth-order cumulants are
7276 C indluded.
7277         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7278      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7279         call transpose2(AEA(1,1,1),auxmat(1,1))
7280         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7281         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7282         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7283         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7284         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7285         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7286         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7287         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7288         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7289         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7290         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7291         call transpose2(AEA(1,1,2),auxmat(1,1))
7292         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7293         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7294         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7295         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7296         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7297         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7298         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7299         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7300         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7301         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7302         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7303 C Calculate the Cartesian derivatives of the vectors.
7304         do iii=1,2
7305           do kkk=1,5
7306             do lll=1,3
7307               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7308               call matvec2(auxmat(1,1),b1(1,iti),
7309      &          AEAb1derx(1,lll,kkk,iii,1,1))
7310               call matvec2(auxmat(1,1),Ub2(1,i),
7311      &          AEAb2derx(1,lll,kkk,iii,1,1))
7312               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7313      &          AEAb1derx(1,lll,kkk,iii,2,1))
7314               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7315      &          AEAb2derx(1,lll,kkk,iii,2,1))
7316               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7317               call matvec2(auxmat(1,1),b1(1,itl),
7318      &          AEAb1derx(1,lll,kkk,iii,1,2))
7319               call matvec2(auxmat(1,1),Ub2(1,l),
7320      &          AEAb2derx(1,lll,kkk,iii,1,2))
7321               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7322      &          AEAb1derx(1,lll,kkk,iii,2,2))
7323               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7324      &          AEAb2derx(1,lll,kkk,iii,2,2))
7325             enddo
7326           enddo
7327         enddo
7328         ENDIF
7329 C End vectors
7330       endif
7331       return
7332       end
7333 C---------------------------------------------------------------------------
7334       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7335      &  KK,KKderg,AKA,AKAderg,AKAderx)
7336       implicit none
7337       integer nderg
7338       logical transp
7339       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7340      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7341      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7342       integer iii,kkk,lll
7343       integer jjj,mmm
7344       logical lprn
7345       common /kutas/ lprn
7346       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7347       do iii=1,nderg
7348         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7349      &    AKAderg(1,1,iii))
7350       enddo
7351 cd      if (lprn) write (2,*) 'In kernel'
7352       do kkk=1,5
7353 cd        if (lprn) write (2,*) 'kkk=',kkk
7354         do lll=1,3
7355           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7356      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7357 cd          if (lprn) then
7358 cd            write (2,*) 'lll=',lll
7359 cd            write (2,*) 'iii=1'
7360 cd            do jjj=1,2
7361 cd              write (2,'(3(2f10.5),5x)')
7362 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7363 cd            enddo
7364 cd          endif
7365           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7366      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7367 cd          if (lprn) then
7368 cd            write (2,*) 'lll=',lll
7369 cd            write (2,*) 'iii=2'
7370 cd            do jjj=1,2
7371 cd              write (2,'(3(2f10.5),5x)')
7372 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7373 cd            enddo
7374 cd          endif
7375         enddo
7376       enddo
7377       return
7378       end
7379 C---------------------------------------------------------------------------
7380       double precision function eello4(i,j,k,l,jj,kk)
7381       implicit real*8 (a-h,o-z)
7382       include 'DIMENSIONS'
7383       include 'COMMON.IOUNITS'
7384       include 'COMMON.CHAIN'
7385       include 'COMMON.DERIV'
7386       include 'COMMON.INTERACT'
7387       include 'COMMON.CONTACTS'
7388       include 'COMMON.TORSION'
7389       include 'COMMON.VAR'
7390       include 'COMMON.GEO'
7391       double precision pizda(2,2),ggg1(3),ggg2(3)
7392 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7393 cd        eello4=0.0d0
7394 cd        return
7395 cd      endif
7396 cd      print *,'eello4:',i,j,k,l,jj,kk
7397 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7398 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7399 cold      eij=facont_hb(jj,i)
7400 cold      ekl=facont_hb(kk,k)
7401 cold      ekont=eij*ekl
7402       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7403 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7404       gcorr_loc(k-1)=gcorr_loc(k-1)
7405      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7406       if (l.eq.j+1) then
7407         gcorr_loc(l-1)=gcorr_loc(l-1)
7408      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7409       else
7410         gcorr_loc(j-1)=gcorr_loc(j-1)
7411      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7412       endif
7413       do iii=1,2
7414         do kkk=1,5
7415           do lll=1,3
7416             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7417      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7418 cd            derx(lll,kkk,iii)=0.0d0
7419           enddo
7420         enddo
7421       enddo
7422 cd      gcorr_loc(l-1)=0.0d0
7423 cd      gcorr_loc(j-1)=0.0d0
7424 cd      gcorr_loc(k-1)=0.0d0
7425 cd      eel4=1.0d0
7426 cd      write (iout,*)'Contacts have occurred for peptide groups',
7427 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7428 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7429       if (j.lt.nres-1) then
7430         j1=j+1
7431         j2=j-1
7432       else
7433         j1=j-1
7434         j2=j-2
7435       endif
7436       if (l.lt.nres-1) then
7437         l1=l+1
7438         l2=l-1
7439       else
7440         l1=l-1
7441         l2=l-2
7442       endif
7443       do ll=1,3
7444 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7445 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7446         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7447         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7448 cgrad        ghalf=0.5d0*ggg1(ll)
7449         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7450         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7451         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7452         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7453         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7454         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7455 cgrad        ghalf=0.5d0*ggg2(ll)
7456         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7457         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7458         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7459         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7460         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7461         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7462       enddo
7463 cgrad      do m=i+1,j-1
7464 cgrad        do ll=1,3
7465 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7466 cgrad        enddo
7467 cgrad      enddo
7468 cgrad      do m=k+1,l-1
7469 cgrad        do ll=1,3
7470 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7471 cgrad        enddo
7472 cgrad      enddo
7473 cgrad      do m=i+2,j2
7474 cgrad        do ll=1,3
7475 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7476 cgrad        enddo
7477 cgrad      enddo
7478 cgrad      do m=k+2,l2
7479 cgrad        do ll=1,3
7480 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7481 cgrad        enddo
7482 cgrad      enddo
7483 cd      do iii=1,nres-3
7484 cd        write (2,*) iii,gcorr_loc(iii)
7485 cd      enddo
7486       eello4=ekont*eel4
7487 cd      write (2,*) 'ekont',ekont
7488 cd      write (iout,*) 'eello4',ekont*eel4
7489       return
7490       end
7491 C---------------------------------------------------------------------------
7492       double precision function eello5(i,j,k,l,jj,kk)
7493       implicit real*8 (a-h,o-z)
7494       include 'DIMENSIONS'
7495       include 'COMMON.IOUNITS'
7496       include 'COMMON.CHAIN'
7497       include 'COMMON.DERIV'
7498       include 'COMMON.INTERACT'
7499       include 'COMMON.CONTACTS'
7500       include 'COMMON.TORSION'
7501       include 'COMMON.VAR'
7502       include 'COMMON.GEO'
7503       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7504       double precision ggg1(3),ggg2(3)
7505 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7506 C                                                                              C
7507 C                            Parallel chains                                   C
7508 C                                                                              C
7509 C          o             o                   o             o                   C
7510 C         /l\           / \             \   / \           / \   /              C
7511 C        /   \         /   \             \ /   \         /   \ /               C
7512 C       j| o |l1       | o |              o| o |         | o |o                C
7513 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7514 C      \i/   \         /   \ /             /   \         /   \                 C
7515 C       o    k1             o                                                  C
7516 C         (I)          (II)                (III)          (IV)                 C
7517 C                                                                              C
7518 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7519 C                                                                              C
7520 C                            Antiparallel chains                               C
7521 C                                                                              C
7522 C          o             o                   o             o                   C
7523 C         /j\           / \             \   / \           / \   /              C
7524 C        /   \         /   \             \ /   \         /   \ /               C
7525 C      j1| o |l        | o |              o| o |         | o |o                C
7526 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7527 C      \i/   \         /   \ /             /   \         /   \                 C
7528 C       o     k1            o                                                  C
7529 C         (I)          (II)                (III)          (IV)                 C
7530 C                                                                              C
7531 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7532 C                                                                              C
7533 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7534 C                                                                              C
7535 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7536 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7537 cd        eello5=0.0d0
7538 cd        return
7539 cd      endif
7540 cd      write (iout,*)
7541 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7542 cd     &   ' and',k,l
7543       itk=itortyp(itype(k))
7544       itl=itortyp(itype(l))
7545       itj=itortyp(itype(j))
7546       eello5_1=0.0d0
7547       eello5_2=0.0d0
7548       eello5_3=0.0d0
7549       eello5_4=0.0d0
7550 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7551 cd     &   eel5_3_num,eel5_4_num)
7552       do iii=1,2
7553         do kkk=1,5
7554           do lll=1,3
7555             derx(lll,kkk,iii)=0.0d0
7556           enddo
7557         enddo
7558       enddo
7559 cd      eij=facont_hb(jj,i)
7560 cd      ekl=facont_hb(kk,k)
7561 cd      ekont=eij*ekl
7562 cd      write (iout,*)'Contacts have occurred for peptide groups',
7563 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7564 cd      goto 1111
7565 C Contribution from the graph I.
7566 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7567 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7568       call transpose2(EUg(1,1,k),auxmat(1,1))
7569       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7570       vv(1)=pizda(1,1)-pizda(2,2)
7571       vv(2)=pizda(1,2)+pizda(2,1)
7572       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7573      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7574 C Explicit gradient in virtual-dihedral angles.
7575       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7576      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7577      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7578       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7579       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7580       vv(1)=pizda(1,1)-pizda(2,2)
7581       vv(2)=pizda(1,2)+pizda(2,1)
7582       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7583      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7584      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7585       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7586       vv(1)=pizda(1,1)-pizda(2,2)
7587       vv(2)=pizda(1,2)+pizda(2,1)
7588       if (l.eq.j+1) then
7589         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7590      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7591      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7592       else
7593         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7594      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7595      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7596       endif
7597 C Cartesian gradient
7598       do iii=1,2
7599         do kkk=1,5
7600           do lll=1,3
7601             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7602      &        pizda(1,1))
7603             vv(1)=pizda(1,1)-pizda(2,2)
7604             vv(2)=pizda(1,2)+pizda(2,1)
7605             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7606      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7607      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7608           enddo
7609         enddo
7610       enddo
7611 c      goto 1112
7612 c1111  continue
7613 C Contribution from graph II
7614       call transpose2(EE(1,1,itk),auxmat(1,1))
7615       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7616       vv(1)=pizda(1,1)+pizda(2,2)
7617       vv(2)=pizda(2,1)-pizda(1,2)
7618       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7619      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7620 C Explicit gradient in virtual-dihedral angles.
7621       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7622      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7623       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7624       vv(1)=pizda(1,1)+pizda(2,2)
7625       vv(2)=pizda(2,1)-pizda(1,2)
7626       if (l.eq.j+1) then
7627         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7628      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7629      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7630       else
7631         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7632      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7633      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7634       endif
7635 C Cartesian gradient
7636       do iii=1,2
7637         do kkk=1,5
7638           do lll=1,3
7639             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7640      &        pizda(1,1))
7641             vv(1)=pizda(1,1)+pizda(2,2)
7642             vv(2)=pizda(2,1)-pizda(1,2)
7643             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7644      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7645      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7646           enddo
7647         enddo
7648       enddo
7649 cd      goto 1112
7650 cd1111  continue
7651       if (l.eq.j+1) then
7652 cd        goto 1110
7653 C Parallel orientation
7654 C Contribution from graph III
7655         call transpose2(EUg(1,1,l),auxmat(1,1))
7656         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7657         vv(1)=pizda(1,1)-pizda(2,2)
7658         vv(2)=pizda(1,2)+pizda(2,1)
7659         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7660      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7661 C Explicit gradient in virtual-dihedral angles.
7662         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7663      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7664      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7665         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7666         vv(1)=pizda(1,1)-pizda(2,2)
7667         vv(2)=pizda(1,2)+pizda(2,1)
7668         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7669      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7670      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7671         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7672         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7673         vv(1)=pizda(1,1)-pizda(2,2)
7674         vv(2)=pizda(1,2)+pizda(2,1)
7675         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7676      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7677      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7678 C Cartesian gradient
7679         do iii=1,2
7680           do kkk=1,5
7681             do lll=1,3
7682               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7683      &          pizda(1,1))
7684               vv(1)=pizda(1,1)-pizda(2,2)
7685               vv(2)=pizda(1,2)+pizda(2,1)
7686               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7687      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7688      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7689             enddo
7690           enddo
7691         enddo
7692 cd        goto 1112
7693 C Contribution from graph IV
7694 cd1110    continue
7695         call transpose2(EE(1,1,itl),auxmat(1,1))
7696         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7697         vv(1)=pizda(1,1)+pizda(2,2)
7698         vv(2)=pizda(2,1)-pizda(1,2)
7699         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7700      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7701 C Explicit gradient in virtual-dihedral angles.
7702         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7703      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7704         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7705         vv(1)=pizda(1,1)+pizda(2,2)
7706         vv(2)=pizda(2,1)-pizda(1,2)
7707         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7708      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7709      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7710 C Cartesian gradient
7711         do iii=1,2
7712           do kkk=1,5
7713             do lll=1,3
7714               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7715      &          pizda(1,1))
7716               vv(1)=pizda(1,1)+pizda(2,2)
7717               vv(2)=pizda(2,1)-pizda(1,2)
7718               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7719      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7720      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7721             enddo
7722           enddo
7723         enddo
7724       else
7725 C Antiparallel orientation
7726 C Contribution from graph III
7727 c        goto 1110
7728         call transpose2(EUg(1,1,j),auxmat(1,1))
7729         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7730         vv(1)=pizda(1,1)-pizda(2,2)
7731         vv(2)=pizda(1,2)+pizda(2,1)
7732         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7733      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7734 C Explicit gradient in virtual-dihedral angles.
7735         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7736      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7737      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7738         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7739         vv(1)=pizda(1,1)-pizda(2,2)
7740         vv(2)=pizda(1,2)+pizda(2,1)
7741         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7742      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7743      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7744         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7745         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7746         vv(1)=pizda(1,1)-pizda(2,2)
7747         vv(2)=pizda(1,2)+pizda(2,1)
7748         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7749      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7750      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7751 C Cartesian gradient
7752         do iii=1,2
7753           do kkk=1,5
7754             do lll=1,3
7755               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7756      &          pizda(1,1))
7757               vv(1)=pizda(1,1)-pizda(2,2)
7758               vv(2)=pizda(1,2)+pizda(2,1)
7759               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7760      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7761      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7762             enddo
7763           enddo
7764         enddo
7765 cd        goto 1112
7766 C Contribution from graph IV
7767 1110    continue
7768         call transpose2(EE(1,1,itj),auxmat(1,1))
7769         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7770         vv(1)=pizda(1,1)+pizda(2,2)
7771         vv(2)=pizda(2,1)-pizda(1,2)
7772         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7773      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7774 C Explicit gradient in virtual-dihedral angles.
7775         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7776      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7777         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7778         vv(1)=pizda(1,1)+pizda(2,2)
7779         vv(2)=pizda(2,1)-pizda(1,2)
7780         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7781      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7782      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7783 C Cartesian gradient
7784         do iii=1,2
7785           do kkk=1,5
7786             do lll=1,3
7787               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7788      &          pizda(1,1))
7789               vv(1)=pizda(1,1)+pizda(2,2)
7790               vv(2)=pizda(2,1)-pizda(1,2)
7791               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7792      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7793      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7794             enddo
7795           enddo
7796         enddo
7797       endif
7798 1112  continue
7799       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7800 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7801 cd        write (2,*) 'ijkl',i,j,k,l
7802 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7803 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7804 cd      endif
7805 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7806 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7807 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7808 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7809       if (j.lt.nres-1) then
7810         j1=j+1
7811         j2=j-1
7812       else
7813         j1=j-1
7814         j2=j-2
7815       endif
7816       if (l.lt.nres-1) then
7817         l1=l+1
7818         l2=l-1
7819       else
7820         l1=l-1
7821         l2=l-2
7822       endif
7823 cd      eij=1.0d0
7824 cd      ekl=1.0d0
7825 cd      ekont=1.0d0
7826 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7827 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7828 C        summed up outside the subrouine as for the other subroutines
7829 C        handling long-range interactions. The old code is commented out
7830 C        with "cgrad" to keep track of changes.
7831       do ll=1,3
7832 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7833 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7834         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7835         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7836 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7837 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7838 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7839 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7840 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7841 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7842 c     &   gradcorr5ij,
7843 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7844 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7845 cgrad        ghalf=0.5d0*ggg1(ll)
7846 cd        ghalf=0.0d0
7847         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7848         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7849         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7850         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7851         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7852         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7853 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7854 cgrad        ghalf=0.5d0*ggg2(ll)
7855 cd        ghalf=0.0d0
7856         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7857         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7858         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7859         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7860         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7861         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7862       enddo
7863 cd      goto 1112
7864 cgrad      do m=i+1,j-1
7865 cgrad        do ll=1,3
7866 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7867 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7868 cgrad        enddo
7869 cgrad      enddo
7870 cgrad      do m=k+1,l-1
7871 cgrad        do ll=1,3
7872 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7873 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7874 cgrad        enddo
7875 cgrad      enddo
7876 c1112  continue
7877 cgrad      do m=i+2,j2
7878 cgrad        do ll=1,3
7879 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7880 cgrad        enddo
7881 cgrad      enddo
7882 cgrad      do m=k+2,l2
7883 cgrad        do ll=1,3
7884 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7885 cgrad        enddo
7886 cgrad      enddo
7887 cd      do iii=1,nres-3
7888 cd        write (2,*) iii,g_corr5_loc(iii)
7889 cd      enddo
7890       eello5=ekont*eel5
7891 cd      write (2,*) 'ekont',ekont
7892 cd      write (iout,*) 'eello5',ekont*eel5
7893       return
7894       end
7895 c--------------------------------------------------------------------------
7896       double precision function eello6(i,j,k,l,jj,kk)
7897       implicit real*8 (a-h,o-z)
7898       include 'DIMENSIONS'
7899       include 'COMMON.IOUNITS'
7900       include 'COMMON.CHAIN'
7901       include 'COMMON.DERIV'
7902       include 'COMMON.INTERACT'
7903       include 'COMMON.CONTACTS'
7904       include 'COMMON.TORSION'
7905       include 'COMMON.VAR'
7906       include 'COMMON.GEO'
7907       include 'COMMON.FFIELD'
7908       double precision ggg1(3),ggg2(3)
7909 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7910 cd        eello6=0.0d0
7911 cd        return
7912 cd      endif
7913 cd      write (iout,*)
7914 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7915 cd     &   ' and',k,l
7916       eello6_1=0.0d0
7917       eello6_2=0.0d0
7918       eello6_3=0.0d0
7919       eello6_4=0.0d0
7920       eello6_5=0.0d0
7921       eello6_6=0.0d0
7922 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7923 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7924       do iii=1,2
7925         do kkk=1,5
7926           do lll=1,3
7927             derx(lll,kkk,iii)=0.0d0
7928           enddo
7929         enddo
7930       enddo
7931 cd      eij=facont_hb(jj,i)
7932 cd      ekl=facont_hb(kk,k)
7933 cd      ekont=eij*ekl
7934 cd      eij=1.0d0
7935 cd      ekl=1.0d0
7936 cd      ekont=1.0d0
7937       if (l.eq.j+1) then
7938         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7939         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7940         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7941         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7942         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7943         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7944       else
7945         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7946         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7947         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7948         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7949         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7950           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7951         else
7952           eello6_5=0.0d0
7953         endif
7954         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7955       endif
7956 C If turn contributions are considered, they will be handled separately.
7957       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7958 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
7959 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
7960 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
7961 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
7962 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
7963 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
7964 cd      goto 1112
7965       if (j.lt.nres-1) then
7966         j1=j+1
7967         j2=j-1
7968       else
7969         j1=j-1
7970         j2=j-2
7971       endif
7972       if (l.lt.nres-1) then
7973         l1=l+1
7974         l2=l-1
7975       else
7976         l1=l-1
7977         l2=l-2
7978       endif
7979       do ll=1,3
7980 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
7981 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
7982 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7983 cgrad        ghalf=0.5d0*ggg1(ll)
7984 cd        ghalf=0.0d0
7985         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
7986         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
7987         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
7988         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7989         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
7990         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7991         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
7992         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
7993 cgrad        ghalf=0.5d0*ggg2(ll)
7994 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7995 cd        ghalf=0.0d0
7996         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
7997         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7998         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
7999         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8000         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8001         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8002       enddo
8003 cd      goto 1112
8004 cgrad      do m=i+1,j-1
8005 cgrad        do ll=1,3
8006 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8007 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8008 cgrad        enddo
8009 cgrad      enddo
8010 cgrad      do m=k+1,l-1
8011 cgrad        do ll=1,3
8012 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8013 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8014 cgrad        enddo
8015 cgrad      enddo
8016 cgrad1112  continue
8017 cgrad      do m=i+2,j2
8018 cgrad        do ll=1,3
8019 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8020 cgrad        enddo
8021 cgrad      enddo
8022 cgrad      do m=k+2,l2
8023 cgrad        do ll=1,3
8024 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8025 cgrad        enddo
8026 cgrad      enddo
8027 cd      do iii=1,nres-3
8028 cd        write (2,*) iii,g_corr6_loc(iii)
8029 cd      enddo
8030       eello6=ekont*eel6
8031 cd      write (2,*) 'ekont',ekont
8032 cd      write (iout,*) 'eello6',ekont*eel6
8033       return
8034       end
8035 c--------------------------------------------------------------------------
8036       double precision function eello6_graph1(i,j,k,l,imat,swap)
8037       implicit real*8 (a-h,o-z)
8038       include 'DIMENSIONS'
8039       include 'COMMON.IOUNITS'
8040       include 'COMMON.CHAIN'
8041       include 'COMMON.DERIV'
8042       include 'COMMON.INTERACT'
8043       include 'COMMON.CONTACTS'
8044       include 'COMMON.TORSION'
8045       include 'COMMON.VAR'
8046       include 'COMMON.GEO'
8047       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8048       logical swap
8049       logical lprn
8050       common /kutas/ lprn
8051 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8052 C
8053 C      Parallel       Antiparallel
8054 C
8055 C          o             o
8056 C         /l\           /j\
8057 C        /   \         /   \
8058 C       /| o |         | o |\
8059 C     \ j|/k\|  /   \  |/k\|l /
8060 C      \ /   \ /     \ /   \ /
8061 C       o     o       o     o
8062 C       i             i
8063 C
8064 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8065       itk=itortyp(itype(k))
8066       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8067       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8068       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8069       call transpose2(EUgC(1,1,k),auxmat(1,1))
8070       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8071       vv1(1)=pizda1(1,1)-pizda1(2,2)
8072       vv1(2)=pizda1(1,2)+pizda1(2,1)
8073       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8074       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8075       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8076       s5=scalar2(vv(1),Dtobr2(1,i))
8077 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8078       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8079       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8080      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8081      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8082      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8083      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8084      & +scalar2(vv(1),Dtobr2der(1,i)))
8085       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8086       vv1(1)=pizda1(1,1)-pizda1(2,2)
8087       vv1(2)=pizda1(1,2)+pizda1(2,1)
8088       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8089       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8090       if (l.eq.j+1) then
8091         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8092      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8093      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8094      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8095      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8096       else
8097         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8098      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8099      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8100      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8101      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8102       endif
8103       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8104       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8105       vv1(1)=pizda1(1,1)-pizda1(2,2)
8106       vv1(2)=pizda1(1,2)+pizda1(2,1)
8107       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8108      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8109      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8110      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8111       do iii=1,2
8112         if (swap) then
8113           ind=3-iii
8114         else
8115           ind=iii
8116         endif
8117         do kkk=1,5
8118           do lll=1,3
8119             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8120             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8121             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8122             call transpose2(EUgC(1,1,k),auxmat(1,1))
8123             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8124      &        pizda1(1,1))
8125             vv1(1)=pizda1(1,1)-pizda1(2,2)
8126             vv1(2)=pizda1(1,2)+pizda1(2,1)
8127             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8128             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8129      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8130             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8131      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8132             s5=scalar2(vv(1),Dtobr2(1,i))
8133             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8134           enddo
8135         enddo
8136       enddo
8137       return
8138       end
8139 c----------------------------------------------------------------------------
8140       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8141       implicit real*8 (a-h,o-z)
8142       include 'DIMENSIONS'
8143       include 'COMMON.IOUNITS'
8144       include 'COMMON.CHAIN'
8145       include 'COMMON.DERIV'
8146       include 'COMMON.INTERACT'
8147       include 'COMMON.CONTACTS'
8148       include 'COMMON.TORSION'
8149       include 'COMMON.VAR'
8150       include 'COMMON.GEO'
8151       logical swap
8152       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8153      & auxvec1(2),auxvec2(1),auxmat1(2,2)
8154       logical lprn
8155       common /kutas/ lprn
8156 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8157 C                                                                              C
8158 C      Parallel       Antiparallel                                             C
8159 C                                                                              C
8160 C          o             o                                                     C
8161 C     \   /l\           /j\   /                                                C
8162 C      \ /   \         /   \ /                                                 C
8163 C       o| o |         | o |o                                                  C
8164 C     \ j|/k\|      \  |/k\|l                                                  C
8165 C      \ /   \       \ /   \                                                   C
8166 C       o             o                                                        C
8167 C       i             i                                                        C
8168 C                                                                              C
8169 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8170 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8171 C AL 7/4/01 s1 would occur in the sixth-order moment,
8172 C           but not in a cluster cumulant
8173 #ifdef MOMENT
8174       s1=dip(1,jj,i)*dip(1,kk,k)
8175 #endif
8176       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8177       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8178       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8179       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8180       call transpose2(EUg(1,1,k),auxmat(1,1))
8181       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8182       vv(1)=pizda(1,1)-pizda(2,2)
8183       vv(2)=pizda(1,2)+pizda(2,1)
8184       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8185 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8186 #ifdef MOMENT
8187       eello6_graph2=-(s1+s2+s3+s4)
8188 #else
8189       eello6_graph2=-(s2+s3+s4)
8190 #endif
8191 c      eello6_graph2=-s3
8192 C Derivatives in gamma(i-1)
8193       if (i.gt.1) then
8194 #ifdef MOMENT
8195         s1=dipderg(1,jj,i)*dip(1,kk,k)
8196 #endif
8197         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8198         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8199         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8200         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8201 #ifdef MOMENT
8202         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8203 #else
8204         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8205 #endif
8206 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8207       endif
8208 C Derivatives in gamma(k-1)
8209 #ifdef MOMENT
8210       s1=dip(1,jj,i)*dipderg(1,kk,k)
8211 #endif
8212       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8213       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8214       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8215       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8216       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8217       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8218       vv(1)=pizda(1,1)-pizda(2,2)
8219       vv(2)=pizda(1,2)+pizda(2,1)
8220       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8221 #ifdef MOMENT
8222       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8223 #else
8224       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8225 #endif
8226 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8227 C Derivatives in gamma(j-1) or gamma(l-1)
8228       if (j.gt.1) then
8229 #ifdef MOMENT
8230         s1=dipderg(3,jj,i)*dip(1,kk,k)
8231 #endif
8232         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8233         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8234         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8235         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8236         vv(1)=pizda(1,1)-pizda(2,2)
8237         vv(2)=pizda(1,2)+pizda(2,1)
8238         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8239 #ifdef MOMENT
8240         if (swap) then
8241           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8242         else
8243           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8244         endif
8245 #endif
8246         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8247 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8248       endif
8249 C Derivatives in gamma(l-1) or gamma(j-1)
8250       if (l.gt.1) then
8251 #ifdef MOMENT
8252         s1=dip(1,jj,i)*dipderg(3,kk,k)
8253 #endif
8254         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8255         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8256         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8257         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8258         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8259         vv(1)=pizda(1,1)-pizda(2,2)
8260         vv(2)=pizda(1,2)+pizda(2,1)
8261         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8262 #ifdef MOMENT
8263         if (swap) then
8264           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8265         else
8266           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8267         endif
8268 #endif
8269         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8270 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8271       endif
8272 C Cartesian derivatives.
8273       if (lprn) then
8274         write (2,*) 'In eello6_graph2'
8275         do iii=1,2
8276           write (2,*) 'iii=',iii
8277           do kkk=1,5
8278             write (2,*) 'kkk=',kkk
8279             do jjj=1,2
8280               write (2,'(3(2f10.5),5x)')
8281      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8282             enddo
8283           enddo
8284         enddo
8285       endif
8286       do iii=1,2
8287         do kkk=1,5
8288           do lll=1,3
8289 #ifdef MOMENT
8290             if (iii.eq.1) then
8291               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8292             else
8293               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8294             endif
8295 #endif
8296             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8297      &        auxvec(1))
8298             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8299             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8300      &        auxvec(1))
8301             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8302             call transpose2(EUg(1,1,k),auxmat(1,1))
8303             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8304      &        pizda(1,1))
8305             vv(1)=pizda(1,1)-pizda(2,2)
8306             vv(2)=pizda(1,2)+pizda(2,1)
8307             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8308 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8309 #ifdef MOMENT
8310             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8311 #else
8312             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8313 #endif
8314             if (swap) then
8315               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8316             else
8317               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8318             endif
8319           enddo
8320         enddo
8321       enddo
8322       return
8323       end
8324 c----------------------------------------------------------------------------
8325       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8326       implicit real*8 (a-h,o-z)
8327       include 'DIMENSIONS'
8328       include 'COMMON.IOUNITS'
8329       include 'COMMON.CHAIN'
8330       include 'COMMON.DERIV'
8331       include 'COMMON.INTERACT'
8332       include 'COMMON.CONTACTS'
8333       include 'COMMON.TORSION'
8334       include 'COMMON.VAR'
8335       include 'COMMON.GEO'
8336       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8337       logical swap
8338 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8339 C                                                                              C
8340 C      Parallel       Antiparallel                                             C
8341 C                                                                              C
8342 C          o             o                                                     C
8343 C         /l\   /   \   /j\                                                    C
8344 C        /   \ /     \ /   \                                                   C
8345 C       /| o |o       o| o |\                                                  C
8346 C       j|/k\|  /      |/k\|l /                                                C
8347 C        /   \ /       /   \ /                                                 C
8348 C       /     o       /     o                                                  C
8349 C       i             i                                                        C
8350 C                                                                              C
8351 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8352 C
8353 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8354 C           energy moment and not to the cluster cumulant.
8355       iti=itortyp(itype(i))
8356       if (j.lt.nres-1) then
8357         itj1=itortyp(itype(j+1))
8358       else
8359         itj1=ntortyp+1
8360       endif
8361       itk=itortyp(itype(k))
8362       itk1=itortyp(itype(k+1))
8363       if (l.lt.nres-1) then
8364         itl1=itortyp(itype(l+1))
8365       else
8366         itl1=ntortyp+1
8367       endif
8368 #ifdef MOMENT
8369       s1=dip(4,jj,i)*dip(4,kk,k)
8370 #endif
8371       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8372       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8373       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8374       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8375       call transpose2(EE(1,1,itk),auxmat(1,1))
8376       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8377       vv(1)=pizda(1,1)+pizda(2,2)
8378       vv(2)=pizda(2,1)-pizda(1,2)
8379       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8380 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8381 cd     & "sum",-(s2+s3+s4)
8382 #ifdef MOMENT
8383       eello6_graph3=-(s1+s2+s3+s4)
8384 #else
8385       eello6_graph3=-(s2+s3+s4)
8386 #endif
8387 c      eello6_graph3=-s4
8388 C Derivatives in gamma(k-1)
8389       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8390       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8391       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8392       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8393 C Derivatives in gamma(l-1)
8394       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8395       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8396       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8397       vv(1)=pizda(1,1)+pizda(2,2)
8398       vv(2)=pizda(2,1)-pizda(1,2)
8399       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8400       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8401 C Cartesian derivatives.
8402       do iii=1,2
8403         do kkk=1,5
8404           do lll=1,3
8405 #ifdef MOMENT
8406             if (iii.eq.1) then
8407               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8408             else
8409               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8410             endif
8411 #endif
8412             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8413      &        auxvec(1))
8414             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8415             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8416      &        auxvec(1))
8417             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8418             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8419      &        pizda(1,1))
8420             vv(1)=pizda(1,1)+pizda(2,2)
8421             vv(2)=pizda(2,1)-pizda(1,2)
8422             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8423 #ifdef MOMENT
8424             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8425 #else
8426             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8427 #endif
8428             if (swap) then
8429               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8430             else
8431               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8432             endif
8433 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8434           enddo
8435         enddo
8436       enddo
8437       return
8438       end
8439 c----------------------------------------------------------------------------
8440       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8441       implicit real*8 (a-h,o-z)
8442       include 'DIMENSIONS'
8443       include 'COMMON.IOUNITS'
8444       include 'COMMON.CHAIN'
8445       include 'COMMON.DERIV'
8446       include 'COMMON.INTERACT'
8447       include 'COMMON.CONTACTS'
8448       include 'COMMON.TORSION'
8449       include 'COMMON.VAR'
8450       include 'COMMON.GEO'
8451       include 'COMMON.FFIELD'
8452       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8453      & auxvec1(2),auxmat1(2,2)
8454       logical swap
8455 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8456 C                                                                              C
8457 C      Parallel       Antiparallel                                             C
8458 C                                                                              C
8459 C          o             o                                                     C
8460 C         /l\   /   \   /j\                                                    C
8461 C        /   \ /     \ /   \                                                   C
8462 C       /| o |o       o| o |\                                                  C
8463 C     \ j|/k\|      \  |/k\|l                                                  C
8464 C      \ /   \       \ /   \                                                   C
8465 C       o     \       o     \                                                  C
8466 C       i             i                                                        C
8467 C                                                                              C
8468 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8469 C
8470 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8471 C           energy moment and not to the cluster cumulant.
8472 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8473       iti=itortyp(itype(i))
8474       itj=itortyp(itype(j))
8475       if (j.lt.nres-1) then
8476         itj1=itortyp(itype(j+1))
8477       else
8478         itj1=ntortyp+1
8479       endif
8480       itk=itortyp(itype(k))
8481       if (k.lt.nres-1) then
8482         itk1=itortyp(itype(k+1))
8483       else
8484         itk1=ntortyp+1
8485       endif
8486       itl=itortyp(itype(l))
8487       if (l.lt.nres-1) then
8488         itl1=itortyp(itype(l+1))
8489       else
8490         itl1=ntortyp+1
8491       endif
8492 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8493 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8494 cd     & ' itl',itl,' itl1',itl1
8495 #ifdef MOMENT
8496       if (imat.eq.1) then
8497         s1=dip(3,jj,i)*dip(3,kk,k)
8498       else
8499         s1=dip(2,jj,j)*dip(2,kk,l)
8500       endif
8501 #endif
8502       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8503       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8504       if (j.eq.l+1) then
8505         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8506         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8507       else
8508         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8509         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8510       endif
8511       call transpose2(EUg(1,1,k),auxmat(1,1))
8512       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8513       vv(1)=pizda(1,1)-pizda(2,2)
8514       vv(2)=pizda(2,1)+pizda(1,2)
8515       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8516 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8517 #ifdef MOMENT
8518       eello6_graph4=-(s1+s2+s3+s4)
8519 #else
8520       eello6_graph4=-(s2+s3+s4)
8521 #endif
8522 C Derivatives in gamma(i-1)
8523       if (i.gt.1) then
8524 #ifdef MOMENT
8525         if (imat.eq.1) then
8526           s1=dipderg(2,jj,i)*dip(3,kk,k)
8527         else
8528           s1=dipderg(4,jj,j)*dip(2,kk,l)
8529         endif
8530 #endif
8531         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8532         if (j.eq.l+1) then
8533           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8534           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8535         else
8536           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8537           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8538         endif
8539         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8540         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8541 cd          write (2,*) 'turn6 derivatives'
8542 #ifdef MOMENT
8543           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8544 #else
8545           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8546 #endif
8547         else
8548 #ifdef MOMENT
8549           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8550 #else
8551           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8552 #endif
8553         endif
8554       endif
8555 C Derivatives in gamma(k-1)
8556 #ifdef MOMENT
8557       if (imat.eq.1) then
8558         s1=dip(3,jj,i)*dipderg(2,kk,k)
8559       else
8560         s1=dip(2,jj,j)*dipderg(4,kk,l)
8561       endif
8562 #endif
8563       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8564       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8565       if (j.eq.l+1) then
8566         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8567         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8568       else
8569         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8570         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8571       endif
8572       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8573       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8574       vv(1)=pizda(1,1)-pizda(2,2)
8575       vv(2)=pizda(2,1)+pizda(1,2)
8576       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8577       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8578 #ifdef MOMENT
8579         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8580 #else
8581         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8582 #endif
8583       else
8584 #ifdef MOMENT
8585         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8586 #else
8587         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8588 #endif
8589       endif
8590 C Derivatives in gamma(j-1) or gamma(l-1)
8591       if (l.eq.j+1 .and. l.gt.1) then
8592         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8593         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8594         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8595         vv(1)=pizda(1,1)-pizda(2,2)
8596         vv(2)=pizda(2,1)+pizda(1,2)
8597         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8598         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8599       else if (j.gt.1) then
8600         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8601         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8602         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8603         vv(1)=pizda(1,1)-pizda(2,2)
8604         vv(2)=pizda(2,1)+pizda(1,2)
8605         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8606         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8607           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8608         else
8609           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8610         endif
8611       endif
8612 C Cartesian derivatives.
8613       do iii=1,2
8614         do kkk=1,5
8615           do lll=1,3
8616 #ifdef MOMENT
8617             if (iii.eq.1) then
8618               if (imat.eq.1) then
8619                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8620               else
8621                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8622               endif
8623             else
8624               if (imat.eq.1) then
8625                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8626               else
8627                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8628               endif
8629             endif
8630 #endif
8631             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8632      &        auxvec(1))
8633             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8634             if (j.eq.l+1) then
8635               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8636      &          b1(1,itj1),auxvec(1))
8637               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8638             else
8639               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8640      &          b1(1,itl1),auxvec(1))
8641               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8642             endif
8643             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8644      &        pizda(1,1))
8645             vv(1)=pizda(1,1)-pizda(2,2)
8646             vv(2)=pizda(2,1)+pizda(1,2)
8647             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8648             if (swap) then
8649               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8650 #ifdef MOMENT
8651                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8652      &             -(s1+s2+s4)
8653 #else
8654                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8655      &             -(s2+s4)
8656 #endif
8657                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8658               else
8659 #ifdef MOMENT
8660                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8661 #else
8662                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8663 #endif
8664                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8665               endif
8666             else
8667 #ifdef MOMENT
8668               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8669 #else
8670               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8671 #endif
8672               if (l.eq.j+1) then
8673                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8674               else
8675                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8676               endif
8677             endif
8678           enddo
8679         enddo
8680       enddo
8681       return
8682       end
8683 c----------------------------------------------------------------------------
8684       double precision function eello_turn6(i,jj,kk)
8685       implicit real*8 (a-h,o-z)
8686       include 'DIMENSIONS'
8687       include 'COMMON.IOUNITS'
8688       include 'COMMON.CHAIN'
8689       include 'COMMON.DERIV'
8690       include 'COMMON.INTERACT'
8691       include 'COMMON.CONTACTS'
8692       include 'COMMON.TORSION'
8693       include 'COMMON.VAR'
8694       include 'COMMON.GEO'
8695       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8696      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8697      &  ggg1(3),ggg2(3)
8698       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8699      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8700 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8701 C           the respective energy moment and not to the cluster cumulant.
8702       s1=0.0d0
8703       s8=0.0d0
8704       s13=0.0d0
8705 c
8706       eello_turn6=0.0d0
8707       j=i+4
8708       k=i+1
8709       l=i+3
8710       iti=itortyp(itype(i))
8711       itk=itortyp(itype(k))
8712       itk1=itortyp(itype(k+1))
8713       itl=itortyp(itype(l))
8714       itj=itortyp(itype(j))
8715 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8716 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8717 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8718 cd        eello6=0.0d0
8719 cd        return
8720 cd      endif
8721 cd      write (iout,*)
8722 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8723 cd     &   ' and',k,l
8724 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8725       do iii=1,2
8726         do kkk=1,5
8727           do lll=1,3
8728             derx_turn(lll,kkk,iii)=0.0d0
8729           enddo
8730         enddo
8731       enddo
8732 cd      eij=1.0d0
8733 cd      ekl=1.0d0
8734 cd      ekont=1.0d0
8735       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8736 cd      eello6_5=0.0d0
8737 cd      write (2,*) 'eello6_5',eello6_5
8738 #ifdef MOMENT
8739       call transpose2(AEA(1,1,1),auxmat(1,1))
8740       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8741       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8742       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8743 #endif
8744       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8745       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8746       s2 = scalar2(b1(1,itk),vtemp1(1))
8747 #ifdef MOMENT
8748       call transpose2(AEA(1,1,2),atemp(1,1))
8749       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8750       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8751       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8752 #endif
8753       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8754       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8755       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8756 #ifdef MOMENT
8757       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8758       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8759       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8760       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8761       ss13 = scalar2(b1(1,itk),vtemp4(1))
8762       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8763 #endif
8764 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8765 c      s1=0.0d0
8766 c      s2=0.0d0
8767 c      s8=0.0d0
8768 c      s12=0.0d0
8769 c      s13=0.0d0
8770       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8771 C Derivatives in gamma(i+2)
8772       s1d =0.0d0
8773       s8d =0.0d0
8774 #ifdef MOMENT
8775       call transpose2(AEA(1,1,1),auxmatd(1,1))
8776       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8777       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8778       call transpose2(AEAderg(1,1,2),atempd(1,1))
8779       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8780       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8781 #endif
8782       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8783       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8784       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8785 c      s1d=0.0d0
8786 c      s2d=0.0d0
8787 c      s8d=0.0d0
8788 c      s12d=0.0d0
8789 c      s13d=0.0d0
8790       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8791 C Derivatives in gamma(i+3)
8792 #ifdef MOMENT
8793       call transpose2(AEA(1,1,1),auxmatd(1,1))
8794       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8795       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8796       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8797 #endif
8798       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8799       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8800       s2d = scalar2(b1(1,itk),vtemp1d(1))
8801 #ifdef MOMENT
8802       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8803       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8804 #endif
8805       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8806 #ifdef MOMENT
8807       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8808       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8809       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8810 #endif
8811 c      s1d=0.0d0
8812 c      s2d=0.0d0
8813 c      s8d=0.0d0
8814 c      s12d=0.0d0
8815 c      s13d=0.0d0
8816 #ifdef MOMENT
8817       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8818      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8819 #else
8820       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8821      &               -0.5d0*ekont*(s2d+s12d)
8822 #endif
8823 C Derivatives in gamma(i+4)
8824       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8825       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8826       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8827 #ifdef MOMENT
8828       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8829       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8830       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8831 #endif
8832 c      s1d=0.0d0
8833 c      s2d=0.0d0
8834 c      s8d=0.0d0
8835 C      s12d=0.0d0
8836 c      s13d=0.0d0
8837 #ifdef MOMENT
8838       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8839 #else
8840       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8841 #endif
8842 C Derivatives in gamma(i+5)
8843 #ifdef MOMENT
8844       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8845       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8846       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8847 #endif
8848       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8849       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8850       s2d = scalar2(b1(1,itk),vtemp1d(1))
8851 #ifdef MOMENT
8852       call transpose2(AEA(1,1,2),atempd(1,1))
8853       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8854       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8855 #endif
8856       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8857       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8858 #ifdef MOMENT
8859       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8860       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8861       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8862 #endif
8863 c      s1d=0.0d0
8864 c      s2d=0.0d0
8865 c      s8d=0.0d0
8866 c      s12d=0.0d0
8867 c      s13d=0.0d0
8868 #ifdef MOMENT
8869       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8870      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8871 #else
8872       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8873      &               -0.5d0*ekont*(s2d+s12d)
8874 #endif
8875 C Cartesian derivatives
8876       do iii=1,2
8877         do kkk=1,5
8878           do lll=1,3
8879 #ifdef MOMENT
8880             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8881             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8882             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8883 #endif
8884             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8885             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8886      &          vtemp1d(1))
8887             s2d = scalar2(b1(1,itk),vtemp1d(1))
8888 #ifdef MOMENT
8889             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8890             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8891             s8d = -(atempd(1,1)+atempd(2,2))*
8892      &           scalar2(cc(1,1,itl),vtemp2(1))
8893 #endif
8894             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8895      &           auxmatd(1,1))
8896             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8897             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8898 c      s1d=0.0d0
8899 c      s2d=0.0d0
8900 c      s8d=0.0d0
8901 c      s12d=0.0d0
8902 c      s13d=0.0d0
8903 #ifdef MOMENT
8904             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8905      &        - 0.5d0*(s1d+s2d)
8906 #else
8907             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8908      &        - 0.5d0*s2d
8909 #endif
8910 #ifdef MOMENT
8911             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8912      &        - 0.5d0*(s8d+s12d)
8913 #else
8914             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8915      &        - 0.5d0*s12d
8916 #endif
8917           enddo
8918         enddo
8919       enddo
8920 #ifdef MOMENT
8921       do kkk=1,5
8922         do lll=1,3
8923           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8924      &      achuj_tempd(1,1))
8925           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8926           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8927           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8928           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8929           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8930      &      vtemp4d(1))
8931           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8932           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8933           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8934         enddo
8935       enddo
8936 #endif
8937 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8938 cd     &  16*eel_turn6_num
8939 cd      goto 1112
8940       if (j.lt.nres-1) then
8941         j1=j+1
8942         j2=j-1
8943       else
8944         j1=j-1
8945         j2=j-2
8946       endif
8947       if (l.lt.nres-1) then
8948         l1=l+1
8949         l2=l-1
8950       else
8951         l1=l-1
8952         l2=l-2
8953       endif
8954       do ll=1,3
8955 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
8956 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
8957 cgrad        ghalf=0.5d0*ggg1(ll)
8958 cd        ghalf=0.0d0
8959         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
8960         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
8961         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
8962      &    +ekont*derx_turn(ll,2,1)
8963         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8964         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
8965      &    +ekont*derx_turn(ll,4,1)
8966         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8967         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
8968         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
8969 cgrad        ghalf=0.5d0*ggg2(ll)
8970 cd        ghalf=0.0d0
8971         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
8972      &    +ekont*derx_turn(ll,2,2)
8973         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8974         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
8975      &    +ekont*derx_turn(ll,4,2)
8976         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8977         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
8978         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
8979       enddo
8980 cd      goto 1112
8981 cgrad      do m=i+1,j-1
8982 cgrad        do ll=1,3
8983 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8984 cgrad        enddo
8985 cgrad      enddo
8986 cgrad      do m=k+1,l-1
8987 cgrad        do ll=1,3
8988 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8989 cgrad        enddo
8990 cgrad      enddo
8991 cgrad1112  continue
8992 cgrad      do m=i+2,j2
8993 cgrad        do ll=1,3
8994 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8995 cgrad        enddo
8996 cgrad      enddo
8997 cgrad      do m=k+2,l2
8998 cgrad        do ll=1,3
8999 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9000 cgrad        enddo
9001 cgrad      enddo
9002 cd      do iii=1,nres-3
9003 cd        write (2,*) iii,g_corr6_loc(iii)
9004 cd      enddo
9005       eello_turn6=ekont*eel_turn6
9006 cd      write (2,*) 'ekont',ekont
9007 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9008       return
9009       end
9010
9011 C-----------------------------------------------------------------------------
9012       double precision function scalar(u,v)
9013 !DIR$ INLINEALWAYS scalar
9014 #ifndef OSF
9015 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9016 #endif
9017       implicit none
9018       double precision u(3),v(3)
9019 cd      double precision sc
9020 cd      integer i
9021 cd      sc=0.0d0
9022 cd      do i=1,3
9023 cd        sc=sc+u(i)*v(i)
9024 cd      enddo
9025 cd      scalar=sc
9026
9027       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9028       return
9029       end
9030 crc-------------------------------------------------
9031       SUBROUTINE MATVEC2(A1,V1,V2)
9032 !DIR$ INLINEALWAYS MATVEC2
9033 #ifndef OSF
9034 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9035 #endif
9036       implicit real*8 (a-h,o-z)
9037       include 'DIMENSIONS'
9038       DIMENSION A1(2,2),V1(2),V2(2)
9039 c      DO 1 I=1,2
9040 c        VI=0.0
9041 c        DO 3 K=1,2
9042 c    3     VI=VI+A1(I,K)*V1(K)
9043 c        Vaux(I)=VI
9044 c    1 CONTINUE
9045
9046       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9047       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9048
9049       v2(1)=vaux1
9050       v2(2)=vaux2
9051       END
9052 C---------------------------------------
9053       SUBROUTINE MATMAT2(A1,A2,A3)
9054 #ifndef OSF
9055 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9056 #endif
9057       implicit real*8 (a-h,o-z)
9058       include 'DIMENSIONS'
9059       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9060 c      DIMENSION AI3(2,2)
9061 c        DO  J=1,2
9062 c          A3IJ=0.0
9063 c          DO K=1,2
9064 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9065 c          enddo
9066 c          A3(I,J)=A3IJ
9067 c       enddo
9068 c      enddo
9069
9070       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9071       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9072       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9073       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9074
9075       A3(1,1)=AI3_11
9076       A3(2,1)=AI3_21
9077       A3(1,2)=AI3_12
9078       A3(2,2)=AI3_22
9079       END
9080
9081 c-------------------------------------------------------------------------
9082       double precision function scalar2(u,v)
9083 !DIR$ INLINEALWAYS scalar2
9084       implicit none
9085       double precision u(2),v(2)
9086       double precision sc
9087       integer i
9088       scalar2=u(1)*v(1)+u(2)*v(2)
9089       return
9090       end
9091
9092 C-----------------------------------------------------------------------------
9093
9094       subroutine transpose2(a,at)
9095 !DIR$ INLINEALWAYS transpose2
9096 #ifndef OSF
9097 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9098 #endif
9099       implicit none
9100       double precision a(2,2),at(2,2)
9101       at(1,1)=a(1,1)
9102       at(1,2)=a(2,1)
9103       at(2,1)=a(1,2)
9104       at(2,2)=a(2,2)
9105       return
9106       end
9107 c--------------------------------------------------------------------------
9108       subroutine transpose(n,a,at)
9109       implicit none
9110       integer n,i,j
9111       double precision a(n,n),at(n,n)
9112       do i=1,n
9113         do j=1,n
9114           at(j,i)=a(i,j)
9115         enddo
9116       enddo
9117       return
9118       end
9119 C---------------------------------------------------------------------------
9120       subroutine prodmat3(a1,a2,kk,transp,prod)
9121 !DIR$ INLINEALWAYS prodmat3
9122 #ifndef OSF
9123 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9124 #endif
9125       implicit none
9126       integer i,j
9127       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9128       logical transp
9129 crc      double precision auxmat(2,2),prod_(2,2)
9130
9131       if (transp) then
9132 crc        call transpose2(kk(1,1),auxmat(1,1))
9133 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9134 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9135
9136            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9137      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9138            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9139      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9140            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9141      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9142            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9143      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9144
9145       else
9146 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9147 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9148
9149            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9150      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9151            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9152      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9153            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9154      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9155            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9156      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9157
9158       endif
9159 c      call transpose2(a2(1,1),a2t(1,1))
9160
9161 crc      print *,transp
9162 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9163 crc      print *,((prod(i,j),i=1,2),j=1,2)
9164
9165       return
9166       end
9167