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      & 'EHPB=  ',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=iabs(itype(i))
1141         itypi1=iabs(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=iabs(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=iabs(itype(i))
1318         itypi1=iabs(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=iabs(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=iabs(itype(i))
1435         itypi1=iabs(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=iabs(itype(i))
1571         itypi1=iabs(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=iabs(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=iabs(itype(i))
1730         itypi1=iabs(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=iabs(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=iabs(itype(i))
2050         itypi1=iabs(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=iabs(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=iabs(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=iabs(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 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4270 c     &    dhpb(i),dhpb1(i),forcon(i)
4271 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4272 C    distance and angle dependent SS bond potential.
4273         if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and. iabs(itype(jjj
4274      &)).eq.1) then
4275           call ssbond_ene(iii,jjj,eij)
4276           ehpb=ehpb+2*eij
4277 cd          write (iout,*) "eij",eij
4278         else if (ii.gt.nres .and. jj.gt.nres) then
4279 c Restraints from contact prediction
4280           dd=dist(ii,jj)
4281           if (dhpb1(i).gt.0.0d0) then
4282             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4283             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4284 c            write (iout,*) "beta nmr",
4285 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4286           else
4287             dd=dist(ii,jj)
4288             rdis=dd-dhpb(i)
4289 C Get the force constant corresponding to this distance.
4290             waga=forcon(i)
4291 C Calculate the contribution to energy.
4292             ehpb=ehpb+waga*rdis*rdis
4293 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
4294 C
4295 C Evaluate gradient.
4296 C
4297             fac=waga*rdis/dd
4298           endif
4299           do j=1,3
4300             ggg(j)=fac*(c(j,jj)-c(j,ii))
4301           enddo
4302           do j=1,3
4303             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4304             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4305           enddo
4306           do k=1,3
4307             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4308             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4309           enddo
4310         else
4311 C Calculate the distance between the two points and its difference from the
4312 C target distance.
4313           dd=dist(ii,jj)
4314           if (dhpb1(i).gt.0.0d0) then
4315             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4316             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4317 c            write (iout,*) "alph nmr",
4318 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4319           else
4320             rdis=dd-dhpb(i)
4321 C Get the force constant corresponding to this distance.
4322             waga=forcon(i)
4323 C Calculate the contribution to energy.
4324             ehpb=ehpb+waga*rdis*rdis
4325 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
4326 C
4327 C Evaluate gradient.
4328 C
4329             fac=waga*rdis/dd
4330           endif
4331 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4332 cd   &   ' waga=',waga,' fac=',fac
4333             do j=1,3
4334               ggg(j)=fac*(c(j,jj)-c(j,ii))
4335             enddo
4336 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4337 C If this is a SC-SC distance, we need to calculate the contributions to the
4338 C Cartesian gradient in the SC vectors (ghpbx).
4339           if (iii.lt.ii) then
4340           do j=1,3
4341             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4342             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4343           enddo
4344           endif
4345 cgrad        do j=iii,jjj-1
4346 cgrad          do k=1,3
4347 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4348 cgrad          enddo
4349 cgrad        enddo
4350           do k=1,3
4351             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4352             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4353           enddo
4354         endif
4355       enddo
4356       ehpb=0.5D0*ehpb
4357       return
4358       end
4359 C--------------------------------------------------------------------------
4360       subroutine ssbond_ene(i,j,eij)
4361 C
4362 C Calculate the distance and angle dependent SS-bond potential energy
4363 C using a free-energy function derived based on RHF/6-31G** ab initio
4364 C calculations of diethyl disulfide.
4365 C
4366 C A. Liwo and U. Kozlowska, 11/24/03
4367 C
4368       implicit real*8 (a-h,o-z)
4369       include 'DIMENSIONS'
4370       include 'COMMON.SBRIDGE'
4371       include 'COMMON.CHAIN'
4372       include 'COMMON.DERIV'
4373       include 'COMMON.LOCAL'
4374       include 'COMMON.INTERACT'
4375       include 'COMMON.VAR'
4376       include 'COMMON.IOUNITS'
4377       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4378       itypi=iabs(itype(i))
4379       xi=c(1,nres+i)
4380       yi=c(2,nres+i)
4381       zi=c(3,nres+i)
4382       dxi=dc_norm(1,nres+i)
4383       dyi=dc_norm(2,nres+i)
4384       dzi=dc_norm(3,nres+i)
4385 c      dsci_inv=dsc_inv(itypi)
4386       dsci_inv=vbld_inv(nres+i)
4387       itypj=iabs(itype(j))
4388 c      dscj_inv=dsc_inv(itypj)
4389       dscj_inv=vbld_inv(nres+j)
4390       xj=c(1,nres+j)-xi
4391       yj=c(2,nres+j)-yi
4392       zj=c(3,nres+j)-zi
4393       dxj=dc_norm(1,nres+j)
4394       dyj=dc_norm(2,nres+j)
4395       dzj=dc_norm(3,nres+j)
4396       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4397       rij=dsqrt(rrij)
4398       erij(1)=xj*rij
4399       erij(2)=yj*rij
4400       erij(3)=zj*rij
4401       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4402       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4403       om12=dxi*dxj+dyi*dyj+dzi*dzj
4404       do k=1,3
4405         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4406         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4407       enddo
4408       rij=1.0d0/rij
4409       deltad=rij-d0cm
4410       deltat1=1.0d0-om1
4411       deltat2=1.0d0+om2
4412       deltat12=om2-om1+2.0d0
4413       cosphi=om12-om1*om2
4414       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4415      &  +akct*deltad*deltat12
4416      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4417 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4418 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4419 c     &  " deltat12",deltat12," eij",eij
4420       ed=2*akcm*deltad+akct*deltat12
4421       pom1=akct*deltad
4422       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4423       eom1=-2*akth*deltat1-pom1-om2*pom2
4424       eom2= 2*akth*deltat2+pom1-om1*pom2
4425       eom12=pom2
4426       do k=1,3
4427         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4428         ghpbx(k,i)=ghpbx(k,i)-ggk
4429      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4430      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4431         ghpbx(k,j)=ghpbx(k,j)+ggk
4432      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4433      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4434         ghpbc(k,i)=ghpbc(k,i)-ggk
4435         ghpbc(k,j)=ghpbc(k,j)+ggk
4436       enddo
4437 C
4438 C Calculate the components of the gradient in DC and X
4439 C
4440 cgrad      do k=i,j-1
4441 cgrad        do l=1,3
4442 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4443 cgrad        enddo
4444 cgrad      enddo
4445       return
4446       end
4447 C--------------------------------------------------------------------------
4448       subroutine ebond(estr)
4449 c
4450 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4451 c
4452       implicit real*8 (a-h,o-z)
4453       include 'DIMENSIONS'
4454       include 'COMMON.LOCAL'
4455       include 'COMMON.GEO'
4456       include 'COMMON.INTERACT'
4457       include 'COMMON.DERIV'
4458       include 'COMMON.VAR'
4459       include 'COMMON.CHAIN'
4460       include 'COMMON.IOUNITS'
4461       include 'COMMON.NAMES'
4462       include 'COMMON.FFIELD'
4463       include 'COMMON.CONTROL'
4464       include 'COMMON.SETUP'
4465       double precision u(3),ud(3)
4466       estr=0.0d0
4467       do i=ibondp_start,ibondp_end
4468         diff = vbld(i)-vbldp0
4469 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4470         estr=estr+diff*diff
4471         do j=1,3
4472           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4473         enddo
4474 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4475       enddo
4476       estr=0.5d0*AKP*estr
4477 c
4478 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4479 c
4480       do i=ibond_start,ibond_end
4481         iti=iabs(itype(i))
4482         if (iti.ne.10) then
4483           nbi=nbondterm(iti)
4484           if (nbi.eq.1) then
4485             diff=vbld(i+nres)-vbldsc0(1,iti)
4486 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4487 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4488             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4489             do j=1,3
4490               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4491             enddo
4492           else
4493             do j=1,nbi
4494               diff=vbld(i+nres)-vbldsc0(j,iti)
4495               ud(j)=aksc(j,iti)*diff
4496               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4497             enddo
4498             uprod=u(1)
4499             do j=2,nbi
4500               uprod=uprod*u(j)
4501             enddo
4502             usum=0.0d0
4503             usumsqder=0.0d0
4504             do j=1,nbi
4505               uprod1=1.0d0
4506               uprod2=1.0d0
4507               do k=1,nbi
4508                 if (k.ne.j) then
4509                   uprod1=uprod1*u(k)
4510                   uprod2=uprod2*u(k)*u(k)
4511                 endif
4512               enddo
4513               usum=usum+uprod1
4514               usumsqder=usumsqder+ud(j)*uprod2
4515             enddo
4516             estr=estr+uprod/usum
4517             do j=1,3
4518              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4519             enddo
4520           endif
4521         endif
4522       enddo
4523       return
4524       end
4525 #ifdef CRYST_THETA
4526 C--------------------------------------------------------------------------
4527       subroutine ebend(etheta)
4528 C
4529 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4530 C angles gamma and its derivatives in consecutive thetas and gammas.
4531 C
4532       implicit real*8 (a-h,o-z)
4533       include 'DIMENSIONS'
4534       include 'COMMON.LOCAL'
4535       include 'COMMON.GEO'
4536       include 'COMMON.INTERACT'
4537       include 'COMMON.DERIV'
4538       include 'COMMON.VAR'
4539       include 'COMMON.CHAIN'
4540       include 'COMMON.IOUNITS'
4541       include 'COMMON.NAMES'
4542       include 'COMMON.FFIELD'
4543       include 'COMMON.CONTROL'
4544       common /calcthet/ term1,term2,termm,diffak,ratak,
4545      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4546      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4547       double precision y(2),z(2)
4548       delta=0.02d0*pi
4549 c      time11=dexp(-2*time)
4550 c      time12=1.0d0
4551       etheta=0.0D0
4552 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4553       do i=ithet_start,ithet_end
4554 C Zero the energy function and its derivative at 0 or pi.
4555         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4556         it=iabs(itype(i-1))
4557         if (i.gt.3) then
4558 #ifdef OSF
4559           phii=phi(i)
4560           if (phii.ne.phii) phii=150.0
4561 #else
4562           phii=phi(i)
4563 #endif
4564           y(1)=dcos(phii)
4565           y(2)=dsin(phii)
4566         else
4567           y(1)=0.0D0
4568           y(2)=0.0D0
4569         endif
4570         if (i.lt.nres) then
4571 #ifdef OSF
4572           phii1=phi(i+1)
4573           if (phii1.ne.phii1) phii1=150.0
4574           phii1=pinorm(phii1)
4575           z(1)=cos(phii1)
4576 #else
4577           phii1=phi(i+1)
4578           z(1)=dcos(phii1)
4579 #endif
4580           z(2)=dsin(phii1)
4581         else
4582           z(1)=0.0D0
4583           z(2)=0.0D0
4584         endif
4585 C Calculate the "mean" value of theta from the part of the distribution
4586 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4587 C In following comments this theta will be referred to as t_c.
4588         thet_pred_mean=0.0d0
4589         do k=1,2
4590           athetk=athet(k,it)
4591           bthetk=bthet(k,it)
4592           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4593         enddo
4594         dthett=thet_pred_mean*ssd
4595         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4596 C Derivatives of the "mean" values in gamma1 and gamma2.
4597         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
4598         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
4599         if (theta(i).gt.pi-delta) then
4600           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4601      &         E_tc0)
4602           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4603           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4604           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4605      &        E_theta)
4606           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4607      &        E_tc)
4608         else if (theta(i).lt.delta) then
4609           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4610           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4611           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4612      &        E_theta)
4613           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4614           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4615      &        E_tc)
4616         else
4617           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4618      &        E_theta,E_tc)
4619         endif
4620         etheta=etheta+ethetai
4621         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4622      &      'ebend',i,ethetai
4623         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4624         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4625         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4626       enddo
4627 C Ufff.... We've done all this!!!
4628       return
4629       end
4630 C---------------------------------------------------------------------------
4631       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4632      &     E_tc)
4633       implicit real*8 (a-h,o-z)
4634       include 'DIMENSIONS'
4635       include 'COMMON.LOCAL'
4636       include 'COMMON.IOUNITS'
4637       common /calcthet/ term1,term2,termm,diffak,ratak,
4638      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4639      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4640 C Calculate the contributions to both Gaussian lobes.
4641 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4642 C The "polynomial part" of the "standard deviation" of this part of
4643 C the distribution.
4644         sig=polthet(3,it)
4645         do j=2,0,-1
4646           sig=sig*thet_pred_mean+polthet(j,it)
4647         enddo
4648 C Derivative of the "interior part" of the "standard deviation of the"
4649 C gamma-dependent Gaussian lobe in t_c.
4650         sigtc=3*polthet(3,it)
4651         do j=2,1,-1
4652           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4653         enddo
4654         sigtc=sig*sigtc
4655 C Set the parameters of both Gaussian lobes of the distribution.
4656 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4657         fac=sig*sig+sigc0(it)
4658         sigcsq=fac+fac
4659         sigc=1.0D0/sigcsq
4660 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4661         sigsqtc=-4.0D0*sigcsq*sigtc
4662 c       print *,i,sig,sigtc,sigsqtc
4663 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4664         sigtc=-sigtc/(fac*fac)
4665 C Following variable is sigma(t_c)**(-2)
4666         sigcsq=sigcsq*sigcsq
4667         sig0i=sig0(it)
4668         sig0inv=1.0D0/sig0i**2
4669         delthec=thetai-thet_pred_mean
4670         delthe0=thetai-theta0i
4671         term1=-0.5D0*sigcsq*delthec*delthec
4672         term2=-0.5D0*sig0inv*delthe0*delthe0
4673 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4674 C NaNs in taking the logarithm. We extract the largest exponent which is added
4675 C to the energy (this being the log of the distribution) at the end of energy
4676 C term evaluation for this virtual-bond angle.
4677         if (term1.gt.term2) then
4678           termm=term1
4679           term2=dexp(term2-termm)
4680           term1=1.0d0
4681         else
4682           termm=term2
4683           term1=dexp(term1-termm)
4684           term2=1.0d0
4685         endif
4686 C The ratio between the gamma-independent and gamma-dependent lobes of
4687 C the distribution is a Gaussian function of thet_pred_mean too.
4688         diffak=gthet(2,it)-thet_pred_mean
4689         ratak=diffak/gthet(3,it)**2
4690         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4691 C Let's differentiate it in thet_pred_mean NOW.
4692         aktc=ak*ratak
4693 C Now put together the distribution terms to make complete distribution.
4694         termexp=term1+ak*term2
4695         termpre=sigc+ak*sig0i
4696 C Contribution of the bending energy from this theta is just the -log of
4697 C the sum of the contributions from the two lobes and the pre-exponential
4698 C factor. Simple enough, isn't it?
4699         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4700 C NOW the derivatives!!!
4701 C 6/6/97 Take into account the deformation.
4702         E_theta=(delthec*sigcsq*term1
4703      &       +ak*delthe0*sig0inv*term2)/termexp
4704         E_tc=((sigtc+aktc*sig0i)/termpre
4705      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4706      &       aktc*term2)/termexp)
4707       return
4708       end
4709 c-----------------------------------------------------------------------------
4710       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4711       implicit real*8 (a-h,o-z)
4712       include 'DIMENSIONS'
4713       include 'COMMON.LOCAL'
4714       include 'COMMON.IOUNITS'
4715       common /calcthet/ term1,term2,termm,diffak,ratak,
4716      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4717      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4718       delthec=thetai-thet_pred_mean
4719       delthe0=thetai-theta0i
4720 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4721       t3 = thetai-thet_pred_mean
4722       t6 = t3**2
4723       t9 = term1
4724       t12 = t3*sigcsq
4725       t14 = t12+t6*sigsqtc
4726       t16 = 1.0d0
4727       t21 = thetai-theta0i
4728       t23 = t21**2
4729       t26 = term2
4730       t27 = t21*t26
4731       t32 = termexp
4732       t40 = t32**2
4733       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4734      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4735      & *(-t12*t9-ak*sig0inv*t27)
4736       return
4737       end
4738 #else
4739 C--------------------------------------------------------------------------
4740       subroutine ebend(etheta)
4741 C
4742 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4743 C angles gamma and its derivatives in consecutive thetas and gammas.
4744 C ab initio-derived potentials from
4745 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4746 C
4747       implicit real*8 (a-h,o-z)
4748       include 'DIMENSIONS'
4749       include 'COMMON.LOCAL'
4750       include 'COMMON.GEO'
4751       include 'COMMON.INTERACT'
4752       include 'COMMON.DERIV'
4753       include 'COMMON.VAR'
4754       include 'COMMON.CHAIN'
4755       include 'COMMON.IOUNITS'
4756       include 'COMMON.NAMES'
4757       include 'COMMON.FFIELD'
4758       include 'COMMON.CONTROL'
4759       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4760      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4761      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4762      & sinph1ph2(maxdouble,maxdouble)
4763       logical lprn /.false./, lprn1 /.false./
4764       etheta=0.0D0
4765       do i=ithet_start,ithet_end
4766         dethetai=0.0d0
4767         dephii=0.0d0
4768         dephii1=0.0d0
4769         theti2=0.5d0*theta(i)
4770         ityp2=ithetyp(iabs(itype(i-1)))
4771         do k=1,nntheterm
4772           coskt(k)=dcos(k*theti2)
4773           sinkt(k)=dsin(k*theti2)
4774         enddo
4775         if (i.gt.3) then
4776 #ifdef OSF
4777           phii=phi(i)
4778           if (phii.ne.phii) phii=150.0
4779 #else
4780           phii=phi(i)
4781 #endif
4782           ityp1=ithetyp(iabs(itype(i-2)))
4783           do k=1,nsingle
4784             cosph1(k)=dcos(k*phii)
4785             sinph1(k)=dsin(k*phii)
4786           enddo
4787         else
4788           phii=0.0d0
4789           ityp1=nthetyp+1
4790           do k=1,nsingle
4791             cosph1(k)=0.0d0
4792             sinph1(k)=0.0d0
4793           enddo
4794         endif
4795         if (i.lt.nres) then
4796 #ifdef OSF
4797           phii1=phi(i+1)
4798           if (phii1.ne.phii1) phii1=150.0
4799           phii1=pinorm(phii1)
4800 #else
4801           phii1=phi(i+1)
4802 #endif
4803           ityp3=ithetyp(iabs(itype(i)))
4804           do k=1,nsingle
4805             cosph2(k)=dcos(k*phii1)
4806             sinph2(k)=dsin(k*phii1)
4807           enddo
4808         else
4809           phii1=0.0d0
4810           ityp3=nthetyp+1
4811           do k=1,nsingle
4812             cosph2(k)=0.0d0
4813             sinph2(k)=0.0d0
4814           enddo
4815         endif
4816         ethetai=aa0thet(ityp1,ityp2,ityp3)
4817         do k=1,ndouble
4818           do l=1,k-1
4819             ccl=cosph1(l)*cosph2(k-l)
4820             ssl=sinph1(l)*sinph2(k-l)
4821             scl=sinph1(l)*cosph2(k-l)
4822             csl=cosph1(l)*sinph2(k-l)
4823             cosph1ph2(l,k)=ccl-ssl
4824             cosph1ph2(k,l)=ccl+ssl
4825             sinph1ph2(l,k)=scl+csl
4826             sinph1ph2(k,l)=scl-csl
4827           enddo
4828         enddo
4829         if (lprn) then
4830         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4831      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4832         write (iout,*) "coskt and sinkt"
4833         do k=1,nntheterm
4834           write (iout,*) k,coskt(k),sinkt(k)
4835         enddo
4836         endif
4837         do k=1,ntheterm
4838           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4839           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4840      &      *coskt(k)
4841           if (lprn)
4842      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4843      &     " ethetai",ethetai
4844         enddo
4845         if (lprn) then
4846         write (iout,*) "cosph and sinph"
4847         do k=1,nsingle
4848           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4849         enddo
4850         write (iout,*) "cosph1ph2 and sinph2ph2"
4851         do k=2,ndouble
4852           do l=1,k-1
4853             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4854      &         sinph1ph2(l,k),sinph1ph2(k,l)
4855           enddo
4856         enddo
4857         write(iout,*) "ethetai",ethetai
4858         endif
4859         do m=1,ntheterm2
4860           do k=1,nsingle
4861             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4862      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4863      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4864      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4865             ethetai=ethetai+sinkt(m)*aux
4866             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4867             dephii=dephii+k*sinkt(m)*(
4868      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4869      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4870             dephii1=dephii1+k*sinkt(m)*(
4871      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4872      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4873             if (lprn)
4874      &      write (iout,*) "m",m," k",k," bbthet",
4875      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4876      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4877      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4878      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4879           enddo
4880         enddo
4881         if (lprn)
4882      &  write(iout,*) "ethetai",ethetai
4883         do m=1,ntheterm3
4884           do k=2,ndouble
4885             do l=1,k-1
4886               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4887      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4888      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4889      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4890               ethetai=ethetai+sinkt(m)*aux
4891               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4892               dephii=dephii+l*sinkt(m)*(
4893      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4894      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4895      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4896      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4897               dephii1=dephii1+(k-l)*sinkt(m)*(
4898      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4899      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4900      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
4901      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4902               if (lprn) then
4903               write (iout,*) "m",m," k",k," l",l," ffthet",
4904      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
4905      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
4906      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
4907      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4908               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4909      &            cosph1ph2(k,l)*sinkt(m),
4910      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4911               endif
4912             enddo
4913           enddo
4914         enddo
4915 10      continue
4916         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4917      &   i,theta(i)*rad2deg,phii*rad2deg,
4918      &   phii1*rad2deg,ethetai
4919         etheta=etheta+ethetai
4920         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4921         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4922         gloc(nphi+i-2,icg)=wang*dethetai
4923       enddo
4924       return
4925       end
4926 #endif
4927 #ifdef CRYST_SC
4928 c-----------------------------------------------------------------------------
4929       subroutine esc(escloc)
4930 C Calculate the local energy of a side chain and its derivatives in the
4931 C corresponding virtual-bond valence angles THETA and the spherical angles
4932 C ALPHA and OMEGA.
4933       implicit real*8 (a-h,o-z)
4934       include 'DIMENSIONS'
4935       include 'COMMON.GEO'
4936       include 'COMMON.LOCAL'
4937       include 'COMMON.VAR'
4938       include 'COMMON.INTERACT'
4939       include 'COMMON.DERIV'
4940       include 'COMMON.CHAIN'
4941       include 'COMMON.IOUNITS'
4942       include 'COMMON.NAMES'
4943       include 'COMMON.FFIELD'
4944       include 'COMMON.CONTROL'
4945       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4946      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4947       common /sccalc/ time11,time12,time112,theti,it,nlobit
4948       delta=0.02d0*pi
4949       escloc=0.0D0
4950 c     write (iout,'(a)') 'ESC'
4951       do i=loc_start,loc_end
4952         it=itype(i)
4953         if (it.eq.10) goto 1
4954         nlobit=nlob(iabs(it))
4955 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4956 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4957         theti=theta(i+1)-pipol
4958         x(1)=dtan(theti)
4959         x(2)=alph(i)
4960         x(3)=omeg(i)
4961
4962         if (x(2).gt.pi-delta) then
4963           xtemp(1)=x(1)
4964           xtemp(2)=pi-delta
4965           xtemp(3)=x(3)
4966           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4967           xtemp(2)=pi
4968           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4969           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4970      &        escloci,dersc(2))
4971           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4972      &        ddersc0(1),dersc(1))
4973           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4974      &        ddersc0(3),dersc(3))
4975           xtemp(2)=pi-delta
4976           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4977           xtemp(2)=pi
4978           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4979           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4980      &            dersc0(2),esclocbi,dersc02)
4981           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4982      &            dersc12,dersc01)
4983           call splinthet(x(2),0.5d0*delta,ss,ssd)
4984           dersc0(1)=dersc01
4985           dersc0(2)=dersc02
4986           dersc0(3)=0.0d0
4987           do k=1,3
4988             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4989           enddo
4990           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4991 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4992 c    &             esclocbi,ss,ssd
4993           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4994 c         escloci=esclocbi
4995 c         write (iout,*) escloci
4996         else if (x(2).lt.delta) then
4997           xtemp(1)=x(1)
4998           xtemp(2)=delta
4999           xtemp(3)=x(3)
5000           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5001           xtemp(2)=0.0d0
5002           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5003           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5004      &        escloci,dersc(2))
5005           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5006      &        ddersc0(1),dersc(1))
5007           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5008      &        ddersc0(3),dersc(3))
5009           xtemp(2)=delta
5010           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5011           xtemp(2)=0.0d0
5012           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5013           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5014      &            dersc0(2),esclocbi,dersc02)
5015           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5016      &            dersc12,dersc01)
5017           dersc0(1)=dersc01
5018           dersc0(2)=dersc02
5019           dersc0(3)=0.0d0
5020           call splinthet(x(2),0.5d0*delta,ss,ssd)
5021           do k=1,3
5022             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5023           enddo
5024           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5025 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5026 c    &             esclocbi,ss,ssd
5027           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5028 c         write (iout,*) escloci
5029         else
5030           call enesc(x,escloci,dersc,ddummy,.false.)
5031         endif
5032
5033         escloc=escloc+escloci
5034         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5035      &     'escloc',i,escloci
5036 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5037
5038         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5039      &   wscloc*dersc(1)
5040         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5041         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5042     1   continue
5043       enddo
5044       return
5045       end
5046 C---------------------------------------------------------------------------
5047       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5048       implicit real*8 (a-h,o-z)
5049       include 'DIMENSIONS'
5050       include 'COMMON.GEO'
5051       include 'COMMON.LOCAL'
5052       include 'COMMON.IOUNITS'
5053       common /sccalc/ time11,time12,time112,theti,it,nlobit
5054       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5055       double precision contr(maxlob,-1:1)
5056       logical mixed
5057 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5058         escloc_i=0.0D0
5059         do j=1,3
5060           dersc(j)=0.0D0
5061           if (mixed) ddersc(j)=0.0d0
5062         enddo
5063         x3=x(3)
5064
5065 C Because of periodicity of the dependence of the SC energy in omega we have
5066 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5067 C To avoid underflows, first compute & store the exponents.
5068
5069         do iii=-1,1
5070
5071           x(3)=x3+iii*dwapi
5072
5073           do j=1,nlobit
5074             do k=1,3
5075               z(k)=x(k)-censc(k,j,it)
5076             enddo
5077             do k=1,3
5078               Axk=0.0D0
5079               do l=1,3
5080                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5081               enddo
5082               Ax(k,j,iii)=Axk
5083             enddo
5084             expfac=0.0D0
5085             do k=1,3
5086               expfac=expfac+Ax(k,j,iii)*z(k)
5087             enddo
5088             contr(j,iii)=expfac
5089           enddo ! j
5090
5091         enddo ! iii
5092
5093         x(3)=x3
5094 C As in the case of ebend, we want to avoid underflows in exponentiation and
5095 C subsequent NaNs and INFs in energy calculation.
5096 C Find the largest exponent
5097         emin=contr(1,-1)
5098         do iii=-1,1
5099           do j=1,nlobit
5100             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5101           enddo
5102         enddo
5103         emin=0.5D0*emin
5104 cd      print *,'it=',it,' emin=',emin
5105
5106 C Compute the contribution to SC energy and derivatives
5107         do iii=-1,1
5108
5109           do j=1,nlobit
5110 #ifdef OSF
5111             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
5112             if(adexp.ne.adexp) adexp=1.0
5113             expfac=dexp(adexp)
5114 #else
5115             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5116 #endif
5117 cd          print *,'j=',j,' expfac=',expfac
5118             escloc_i=escloc_i+expfac
5119             do k=1,3
5120               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5121             enddo
5122             if (mixed) then
5123               do k=1,3,2
5124                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5125      &            +gaussc(k,2,j,it))*expfac
5126               enddo
5127             endif
5128           enddo
5129
5130         enddo ! iii
5131
5132         dersc(1)=dersc(1)/cos(theti)**2
5133         ddersc(1)=ddersc(1)/cos(theti)**2
5134         ddersc(3)=ddersc(3)
5135
5136         escloci=-(dlog(escloc_i)-emin)
5137         do j=1,3
5138           dersc(j)=dersc(j)/escloc_i
5139         enddo
5140         if (mixed) then
5141           do j=1,3,2
5142             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5143           enddo
5144         endif
5145       return
5146       end
5147 C------------------------------------------------------------------------------
5148       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5149       implicit real*8 (a-h,o-z)
5150       include 'DIMENSIONS'
5151       include 'COMMON.GEO'
5152       include 'COMMON.LOCAL'
5153       include 'COMMON.IOUNITS'
5154       common /sccalc/ time11,time12,time112,theti,it,nlobit
5155       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5156       double precision contr(maxlob)
5157       logical mixed
5158
5159       escloc_i=0.0D0
5160
5161       do j=1,3
5162         dersc(j)=0.0D0
5163       enddo
5164
5165       do j=1,nlobit
5166         do k=1,2
5167           z(k)=x(k)-censc(k,j,it)
5168         enddo
5169         z(3)=dwapi
5170         do k=1,3
5171           Axk=0.0D0
5172           do l=1,3
5173             Axk=Axk+gaussc(l,k,j,it)*z(l)
5174           enddo
5175           Ax(k,j)=Axk
5176         enddo
5177         expfac=0.0D0
5178         do k=1,3
5179           expfac=expfac+Ax(k,j)*z(k)
5180         enddo
5181         contr(j)=expfac
5182       enddo ! j
5183
5184 C As in the case of ebend, we want to avoid underflows in exponentiation and
5185 C subsequent NaNs and INFs in energy calculation.
5186 C Find the largest exponent
5187       emin=contr(1)
5188       do j=1,nlobit
5189         if (emin.gt.contr(j)) emin=contr(j)
5190       enddo
5191       emin=0.5D0*emin
5192
5193 C Compute the contribution to SC energy and derivatives
5194
5195       dersc12=0.0d0
5196       do j=1,nlobit
5197         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5198         escloc_i=escloc_i+expfac
5199         do k=1,2
5200           dersc(k)=dersc(k)+Ax(k,j)*expfac
5201         enddo
5202         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5203      &            +gaussc(1,2,j,it))*expfac
5204         dersc(3)=0.0d0
5205       enddo
5206
5207       dersc(1)=dersc(1)/cos(theti)**2
5208       dersc12=dersc12/cos(theti)**2
5209       escloci=-(dlog(escloc_i)-emin)
5210       do j=1,2
5211         dersc(j)=dersc(j)/escloc_i
5212       enddo
5213       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5214       return
5215       end
5216 #else
5217 c----------------------------------------------------------------------------------
5218       subroutine esc(escloc)
5219 C Calculate the local energy of a side chain and its derivatives in the
5220 C corresponding virtual-bond valence angles THETA and the spherical angles
5221 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5222 C added by Urszula Kozlowska. 07/11/2007
5223 C
5224       implicit real*8 (a-h,o-z)
5225       include 'DIMENSIONS'
5226       include 'COMMON.GEO'
5227       include 'COMMON.LOCAL'
5228       include 'COMMON.VAR'
5229       include 'COMMON.SCROT'
5230       include 'COMMON.INTERACT'
5231       include 'COMMON.DERIV'
5232       include 'COMMON.CHAIN'
5233       include 'COMMON.IOUNITS'
5234       include 'COMMON.NAMES'
5235       include 'COMMON.FFIELD'
5236       include 'COMMON.CONTROL'
5237       include 'COMMON.VECTORS'
5238       double precision x_prime(3),y_prime(3),z_prime(3)
5239      &    , sumene,dsc_i,dp2_i,x(65),
5240      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5241      &    de_dxx,de_dyy,de_dzz,de_dt
5242       double precision s1_t,s1_6_t,s2_t,s2_6_t
5243       double precision
5244      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5245      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5246      & dt_dCi(3),dt_dCi1(3)
5247       common /sccalc/ time11,time12,time112,theti,it,nlobit
5248       delta=0.02d0*pi
5249       escloc=0.0D0
5250       do i=loc_start,loc_end
5251         costtab(i+1) =dcos(theta(i+1))
5252         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5253         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5254         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5255         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5256         cosfac=dsqrt(cosfac2)
5257         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5258         sinfac=dsqrt(sinfac2)
5259         it=itype(i)
5260         if (it.eq.10) goto 1
5261 c
5262 C  Compute the axes of tghe local cartesian coordinates system; store in
5263 c   x_prime, y_prime and z_prime
5264 c
5265         do j=1,3
5266           x_prime(j) = 0.00
5267           y_prime(j) = 0.00
5268           z_prime(j) = 0.00
5269         enddo
5270 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5271 C     &   dc_norm(3,i+nres)
5272         do j = 1,3
5273           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5274           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5275         enddo
5276         do j = 1,3
5277           z_prime(j) = -uz(j,i-1)
5278         enddo
5279 c       write (2,*) "i",i
5280 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5281 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5282 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5283 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5284 c      & " xy",scalar(x_prime(1),y_prime(1)),
5285 c      & " xz",scalar(x_prime(1),z_prime(1)),
5286 c      & " yy",scalar(y_prime(1),y_prime(1)),
5287 c      & " yz",scalar(y_prime(1),z_prime(1)),
5288 c      & " zz",scalar(z_prime(1),z_prime(1))
5289 c
5290 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5291 C to local coordinate system. Store in xx, yy, zz.
5292 c
5293         xx=0.0d0
5294         yy=0.0d0
5295         zz=0.0d0
5296         do j = 1,3
5297           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5298           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5299           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5300         enddo
5301
5302         xxtab(i)=xx
5303         yytab(i)=yy
5304         zztab(i)=zz
5305 C
5306 C Compute the energy of the ith side cbain
5307 C
5308 c        write (2,*) "xx",xx," yy",yy," zz",zz
5309         it=itype(i)
5310         do j = 1,65
5311           x(j) = sc_parmin(j,it)
5312         enddo
5313 #ifdef CHECK_COORD
5314 Cc diagnostics - remove later
5315         xx1 = dcos(alph(2))
5316         yy1 = dsin(alph(2))*dcos(omeg(2))
5317         zz1 = -dsin(alph(2))*dsin(omeg(2))
5318         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5319      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5320      &    xx1,yy1,zz1
5321 C,"  --- ", xx_w,yy_w,zz_w
5322 c end diagnostics
5323 #endif
5324         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5325      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5326      &   + x(10)*yy*zz
5327         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5328      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5329      & + x(20)*yy*zz
5330         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5331      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5332      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5333      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5334      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5335      &  +x(40)*xx*yy*zz
5336         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5337      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5338      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5339      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5340      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5341      &  +x(60)*xx*yy*zz
5342         dsc_i   = 0.743d0+x(61)
5343         dp2_i   = 1.9d0+x(62)
5344         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5345      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5346         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5347      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5348         s1=(1+x(63))/(0.1d0 + dscp1)
5349         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5350         s2=(1+x(65))/(0.1d0 + dscp2)
5351         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5352         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5353      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5354 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5355 c     &   sumene4,
5356 c     &   dscp1,dscp2,sumene
5357 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5358         escloc = escloc + sumene
5359 c        write (2,*) "i",i," escloc",sumene,escloc
5360 #ifdef DEBUG
5361 C
5362 C This section to check the numerical derivatives of the energy of ith side
5363 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5364 C #define DEBUG in the code to turn it on.
5365 C
5366         write (2,*) "sumene               =",sumene
5367         aincr=1.0d-7
5368         xxsave=xx
5369         xx=xx+aincr
5370         write (2,*) xx,yy,zz
5371         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5372         de_dxx_num=(sumenep-sumene)/aincr
5373         xx=xxsave
5374         write (2,*) "xx+ sumene from enesc=",sumenep
5375         yysave=yy
5376         yy=yy+aincr
5377         write (2,*) xx,yy,zz
5378         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5379         de_dyy_num=(sumenep-sumene)/aincr
5380         yy=yysave
5381         write (2,*) "yy+ sumene from enesc=",sumenep
5382         zzsave=zz
5383         zz=zz+aincr
5384         write (2,*) xx,yy,zz
5385         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5386         de_dzz_num=(sumenep-sumene)/aincr
5387         zz=zzsave
5388         write (2,*) "zz+ sumene from enesc=",sumenep
5389         costsave=cost2tab(i+1)
5390         sintsave=sint2tab(i+1)
5391         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5392         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5393         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5394         de_dt_num=(sumenep-sumene)/aincr
5395         write (2,*) " t+ sumene from enesc=",sumenep
5396         cost2tab(i+1)=costsave
5397         sint2tab(i+1)=sintsave
5398 C End of diagnostics section.
5399 #endif
5400 C
5401 C Compute the gradient of esc
5402 C
5403         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5404         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5405         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5406         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5407         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5408         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5409         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5410         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5411         pom1=(sumene3*sint2tab(i+1)+sumene1)
5412      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5413         pom2=(sumene4*cost2tab(i+1)+sumene2)
5414      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5415         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5416         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5417      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5418      &  +x(40)*yy*zz
5419         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5420         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5421      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5422      &  +x(60)*yy*zz
5423         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5424      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5425      &        +(pom1+pom2)*pom_dx
5426 #ifdef DEBUG
5427         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5428 #endif
5429 C
5430         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5431         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5432      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5433      &  +x(40)*xx*zz
5434         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5435         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5436      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5437      &  +x(59)*zz**2 +x(60)*xx*zz
5438         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5439      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5440      &        +(pom1-pom2)*pom_dy
5441 #ifdef DEBUG
5442         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5443 #endif
5444 C
5445         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5446      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5447      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5448      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5449      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5450      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5451      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5452      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5453 #ifdef DEBUG
5454         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5455 #endif
5456 C
5457         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5458      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5459      &  +pom1*pom_dt1+pom2*pom_dt2
5460 #ifdef DEBUG
5461         write(2,*), "de_dt = ", de_dt,de_dt_num
5462 #endif
5463 c
5464 C
5465        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5466        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5467        cosfac2xx=cosfac2*xx
5468        sinfac2yy=sinfac2*yy
5469        do k = 1,3
5470          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5471      &      vbld_inv(i+1)
5472          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5473      &      vbld_inv(i)
5474          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5475          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5476 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5477 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5478 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5479 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5480          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5481          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5482          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5483          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5484          dZZ_Ci1(k)=0.0d0
5485          dZZ_Ci(k)=0.0d0
5486          do j=1,3
5487            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5488            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5489          enddo
5490
5491          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5492          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5493          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5494 c
5495          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5496          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5497        enddo
5498
5499        do k=1,3
5500          dXX_Ctab(k,i)=dXX_Ci(k)
5501          dXX_C1tab(k,i)=dXX_Ci1(k)
5502          dYY_Ctab(k,i)=dYY_Ci(k)
5503          dYY_C1tab(k,i)=dYY_Ci1(k)
5504          dZZ_Ctab(k,i)=dZZ_Ci(k)
5505          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5506          dXX_XYZtab(k,i)=dXX_XYZ(k)
5507          dYY_XYZtab(k,i)=dYY_XYZ(k)
5508          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5509        enddo
5510
5511        do k = 1,3
5512 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5513 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5514 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5515 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5516 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5517 c     &    dt_dci(k)
5518 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5519 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5520          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5521      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5522          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5523      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5524          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5525      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5526        enddo
5527 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5528 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5529
5530 C to check gradient call subroutine check_grad
5531
5532     1 continue
5533       enddo
5534       return
5535       end
5536 c------------------------------------------------------------------------------
5537       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5538       implicit none
5539       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5540      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5541       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5542      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5543      &   + x(10)*yy*zz
5544       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5545      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5546      & + x(20)*yy*zz
5547       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5548      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5549      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5550      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5551      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5552      &  +x(40)*xx*yy*zz
5553       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5554      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5555      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5556      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5557      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5558      &  +x(60)*xx*yy*zz
5559       dsc_i   = 0.743d0+x(61)
5560       dp2_i   = 1.9d0+x(62)
5561       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5562      &          *(xx*cost2+yy*sint2))
5563       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5564      &          *(xx*cost2-yy*sint2))
5565       s1=(1+x(63))/(0.1d0 + dscp1)
5566       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5567       s2=(1+x(65))/(0.1d0 + dscp2)
5568       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5569       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5570      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5571       enesc=sumene
5572       return
5573       end
5574 #endif
5575 c------------------------------------------------------------------------------
5576       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5577 C
5578 C This procedure calculates two-body contact function g(rij) and its derivative:
5579 C
5580 C           eps0ij                                     !       x < -1
5581 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5582 C            0                                         !       x > 1
5583 C
5584 C where x=(rij-r0ij)/delta
5585 C
5586 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5587 C
5588       implicit none
5589       double precision rij,r0ij,eps0ij,fcont,fprimcont
5590       double precision x,x2,x4,delta
5591 c     delta=0.02D0*r0ij
5592 c      delta=0.2D0*r0ij
5593       x=(rij-r0ij)/delta
5594       if (x.lt.-1.0D0) then
5595         fcont=eps0ij
5596         fprimcont=0.0D0
5597       else if (x.le.1.0D0) then
5598         x2=x*x
5599         x4=x2*x2
5600         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5601         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5602       else
5603         fcont=0.0D0
5604         fprimcont=0.0D0
5605       endif
5606       return
5607       end
5608 c------------------------------------------------------------------------------
5609       subroutine splinthet(theti,delta,ss,ssder)
5610       implicit real*8 (a-h,o-z)
5611       include 'DIMENSIONS'
5612       include 'COMMON.VAR'
5613       include 'COMMON.GEO'
5614       thetup=pi-delta
5615       thetlow=delta
5616       if (theti.gt.pipol) then
5617         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5618       else
5619         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5620         ssder=-ssder
5621       endif
5622       return
5623       end
5624 c------------------------------------------------------------------------------
5625       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5626       implicit none
5627       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5628       double precision ksi,ksi2,ksi3,a1,a2,a3
5629       a1=fprim0*delta/(f1-f0)
5630       a2=3.0d0-2.0d0*a1
5631       a3=a1-2.0d0
5632       ksi=(x-x0)/delta
5633       ksi2=ksi*ksi
5634       ksi3=ksi2*ksi
5635       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5636       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5637       return
5638       end
5639 c------------------------------------------------------------------------------
5640       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5641       implicit none
5642       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5643       double precision ksi,ksi2,ksi3,a1,a2,a3
5644       ksi=(x-x0)/delta
5645       ksi2=ksi*ksi
5646       ksi3=ksi2*ksi
5647       a1=fprim0x*delta
5648       a2=3*(f1x-f0x)-2*fprim0x*delta
5649       a3=fprim0x*delta-2*(f1x-f0x)
5650       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5651       return
5652       end
5653 C-----------------------------------------------------------------------------
5654 #ifdef CRYST_TOR
5655 C-----------------------------------------------------------------------------
5656       subroutine etor(etors,edihcnstr)
5657       implicit real*8 (a-h,o-z)
5658       include 'DIMENSIONS'
5659       include 'COMMON.VAR'
5660       include 'COMMON.GEO'
5661       include 'COMMON.LOCAL'
5662       include 'COMMON.TORSION'
5663       include 'COMMON.INTERACT'
5664       include 'COMMON.DERIV'
5665       include 'COMMON.CHAIN'
5666       include 'COMMON.NAMES'
5667       include 'COMMON.IOUNITS'
5668       include 'COMMON.FFIELD'
5669       include 'COMMON.TORCNSTR'
5670       include 'COMMON.CONTROL'
5671       logical lprn
5672 C Set lprn=.true. for debugging
5673       lprn=.false.
5674 c      lprn=.true.
5675       etors=0.0D0
5676       do i=iphi_start,iphi_end
5677       etors_ii=0.0D0
5678         itori=itortyp(itype(i-2))
5679         itori1=itortyp(itype(i-1))
5680         phii=phi(i)
5681         gloci=0.0D0
5682 C Proline-Proline pair is a special case...
5683         if (itori.eq.3 .and. itori1.eq.3) then
5684           if (phii.gt.-dwapi3) then
5685             cosphi=dcos(3*phii)
5686             fac=1.0D0/(1.0D0-cosphi)
5687             etorsi=v1(1,3,3)*fac
5688             etorsi=etorsi+etorsi
5689             etors=etors+etorsi-v1(1,3,3)
5690             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5691             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5692           endif
5693           do j=1,3
5694             v1ij=v1(j+1,itori,itori1)
5695             v2ij=v2(j+1,itori,itori1)
5696             cosphi=dcos(j*phii)
5697             sinphi=dsin(j*phii)
5698             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5699             if (energy_dec) etors_ii=etors_ii+
5700      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5701             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5702           enddo
5703         else
5704           do j=1,nterm_old
5705             v1ij=v1(j,itori,itori1)
5706             v2ij=v2(j,itori,itori1)
5707             cosphi=dcos(j*phii)
5708             sinphi=dsin(j*phii)
5709             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5710             if (energy_dec) etors_ii=etors_ii+
5711      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5712             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5713           enddo
5714         endif
5715         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5716      &        'etor',i,etors_ii
5717         if (lprn)
5718      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5719      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5720      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5721         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5722         write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5723       enddo
5724 ! 6/20/98 - dihedral angle constraints
5725       edihcnstr=0.0d0
5726       do i=1,ndih_constr
5727         itori=idih_constr(i)
5728         phii=phi(itori)
5729         difi=phii-phi0(i)
5730         if (difi.gt.drange(i)) then
5731           difi=difi-drange(i)
5732           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5733           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5734         else if (difi.lt.-drange(i)) then
5735           difi=difi+drange(i)
5736           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5737           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5738         endif
5739 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5740 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5741       enddo
5742 !      write (iout,*) 'edihcnstr',edihcnstr
5743       return
5744       end
5745 c------------------------------------------------------------------------------
5746       subroutine etor_d(etors_d)
5747       etors_d=0.0d0
5748       return
5749       end
5750 c----------------------------------------------------------------------------
5751 #else
5752       subroutine etor(etors,edihcnstr)
5753       implicit real*8 (a-h,o-z)
5754       include 'DIMENSIONS'
5755       include 'COMMON.VAR'
5756       include 'COMMON.GEO'
5757       include 'COMMON.LOCAL'
5758       include 'COMMON.TORSION'
5759       include 'COMMON.INTERACT'
5760       include 'COMMON.DERIV'
5761       include 'COMMON.CHAIN'
5762       include 'COMMON.NAMES'
5763       include 'COMMON.IOUNITS'
5764       include 'COMMON.FFIELD'
5765       include 'COMMON.TORCNSTR'
5766       include 'COMMON.CONTROL'
5767       logical lprn
5768 C Set lprn=.true. for debugging
5769       lprn=.false.
5770 c     lprn=.true.
5771       etors=0.0D0
5772       do i=iphi_start,iphi_end
5773       etors_ii=0.0D0
5774         itori=itortyp(itype(i-2))
5775         itori1=itortyp(itype(i-1))
5776         phii=phi(i)
5777         gloci=0.0D0
5778 C Regular cosine and sine terms
5779         do j=1,nterm(itori,itori1)
5780           v1ij=v1(j,itori,itori1)
5781           v2ij=v2(j,itori,itori1)
5782           cosphi=dcos(j*phii)
5783           sinphi=dsin(j*phii)
5784           etors=etors+v1ij*cosphi+v2ij*sinphi
5785           if (energy_dec) etors_ii=etors_ii+
5786      &                v1ij*cosphi+v2ij*sinphi
5787           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5788         enddo
5789 C Lorentz terms
5790 C                         v1
5791 C  E = SUM ----------------------------------- - v1
5792 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5793 C
5794         cosphi=dcos(0.5d0*phii)
5795         sinphi=dsin(0.5d0*phii)
5796         do j=1,nlor(itori,itori1)
5797           vl1ij=vlor1(j,itori,itori1)
5798           vl2ij=vlor2(j,itori,itori1)
5799           vl3ij=vlor3(j,itori,itori1)
5800           pom=vl2ij*cosphi+vl3ij*sinphi
5801           pom1=1.0d0/(pom*pom+1.0d0)
5802           etors=etors+vl1ij*pom1
5803           if (energy_dec) etors_ii=etors_ii+
5804      &                vl1ij*pom1
5805           pom=-pom*pom1*pom1
5806           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5807         enddo
5808 C Subtract the constant term
5809         etors=etors-v0(itori,itori1)
5810           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5811      &         'etor',i,etors_ii-v0(itori,itori1)
5812         if (lprn)
5813      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5814      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5815      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5816         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5817 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5818       enddo
5819 ! 6/20/98 - dihedral angle constraints
5820       edihcnstr=0.0d0
5821 c      do i=1,ndih_constr
5822       do i=idihconstr_start,idihconstr_end
5823         itori=idih_constr(i)
5824         phii=phi(itori)
5825         difi=pinorm(phii-phi0(i))
5826         if (difi.gt.drange(i)) then
5827           difi=difi-drange(i)
5828           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5829           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5830         else if (difi.lt.-drange(i)) then
5831           difi=difi+drange(i)
5832           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5833           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5834         else
5835           difi=0.0
5836         endif
5837 c        write (iout,*) "gloci", gloc(i-3,icg)
5838 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5839 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5840 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5841       enddo
5842 cd       write (iout,*) 'edihcnstr',edihcnstr
5843       return
5844       end
5845 c----------------------------------------------------------------------------
5846       subroutine etor_d(etors_d)
5847 C 6/23/01 Compute double torsional energy
5848       implicit real*8 (a-h,o-z)
5849       include 'DIMENSIONS'
5850       include 'COMMON.VAR'
5851       include 'COMMON.GEO'
5852       include 'COMMON.LOCAL'
5853       include 'COMMON.TORSION'
5854       include 'COMMON.INTERACT'
5855       include 'COMMON.DERIV'
5856       include 'COMMON.CHAIN'
5857       include 'COMMON.NAMES'
5858       include 'COMMON.IOUNITS'
5859       include 'COMMON.FFIELD'
5860       include 'COMMON.TORCNSTR'
5861       logical lprn
5862 C Set lprn=.true. for debugging
5863       lprn=.false.
5864 c     lprn=.true.
5865       etors_d=0.0D0
5866       do i=iphid_start,iphid_end
5867         itori=itortyp(itype(i-2))
5868         itori1=itortyp(itype(i-1))
5869         itori2=itortyp(itype(i))
5870         phii=phi(i)
5871         phii1=phi(i+1)
5872         gloci1=0.0D0
5873         gloci2=0.0D0
5874         do j=1,ntermd_1(itori,itori1,itori2)
5875           v1cij=v1c(1,j,itori,itori1,itori2)
5876           v1sij=v1s(1,j,itori,itori1,itori2)
5877           v2cij=v1c(2,j,itori,itori1,itori2)
5878           v2sij=v1s(2,j,itori,itori1,itori2)
5879           cosphi1=dcos(j*phii)
5880           sinphi1=dsin(j*phii)
5881           cosphi2=dcos(j*phii1)
5882           sinphi2=dsin(j*phii1)
5883           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5884      &     v2cij*cosphi2+v2sij*sinphi2
5885           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5886           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5887         enddo
5888         do k=2,ntermd_2(itori,itori1,itori2)
5889           do l=1,k-1
5890             v1cdij = v2c(k,l,itori,itori1,itori2)
5891             v2cdij = v2c(l,k,itori,itori1,itori2)
5892             v1sdij = v2s(k,l,itori,itori1,itori2)
5893             v2sdij = v2s(l,k,itori,itori1,itori2)
5894             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5895             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5896             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5897             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5898             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5899      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5900             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5901      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5902             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5903      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5904           enddo
5905         enddo
5906         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5907         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5908 c        write (iout,*) "gloci", gloc(i-3,icg)
5909       enddo
5910       return
5911       end
5912 #endif
5913 c------------------------------------------------------------------------------
5914       subroutine eback_sc_corr(esccor)
5915 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5916 c        conformational states; temporarily implemented as differences
5917 c        between UNRES torsional potentials (dependent on three types of
5918 c        residues) and the torsional potentials dependent on all 20 types
5919 c        of residues computed from AM1  energy surfaces of terminally-blocked
5920 c        amino-acid residues.
5921       implicit real*8 (a-h,o-z)
5922       include 'DIMENSIONS'
5923       include 'COMMON.VAR'
5924       include 'COMMON.GEO'
5925       include 'COMMON.LOCAL'
5926       include 'COMMON.TORSION'
5927       include 'COMMON.SCCOR'
5928       include 'COMMON.INTERACT'
5929       include 'COMMON.DERIV'
5930       include 'COMMON.CHAIN'
5931       include 'COMMON.NAMES'
5932       include 'COMMON.IOUNITS'
5933       include 'COMMON.FFIELD'
5934       include 'COMMON.CONTROL'
5935       logical lprn
5936 C Set lprn=.true. for debugging
5937       lprn=.false.
5938 c      lprn=.true.
5939 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
5940       esccor=0.0D0
5941       do i=itau_start,itau_end
5942         esccor_ii=0.0D0
5943         isccori=isccortyp(itype(i-2))
5944         isccori1=isccortyp(itype(i-1))
5945         phii=phi(i)
5946 cccc  Added 9 May 2012
5947 cc Tauangle is torsional engle depending on the value of first digit
5948 c(see comment below)
5949 cc Omicron is flat angle depending on the value of first digit
5950 c(see comment below)
5951
5952
5953         do intertyp=1,3 !intertyp
5954 cc Added 09 May 2012 (Adasko)
5955 cc  Intertyp means interaction type of backbone mainchain correlation:
5956 c   1 = SC...Ca...Ca...Ca
5957 c   2 = Ca...Ca...Ca...SC
5958 c   3 = SC...Ca...Ca...SCi
5959         gloci=0.0D0
5960         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5961      &      (itype(i-1).eq.10).or.(itype(i-2).eq.21).or.
5962      &      (itype(i-1).eq.21)))
5963      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5964      &     .or.(itype(i-2).eq.21)))
5965      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5966      &      (itype(i-1).eq.21)))) cycle
5967         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle
5968         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21))
5969      & cycle
5970         do j=1,nterm_sccor(isccori,isccori1)
5971           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5972           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5973           cosphi=dcos(j*tauangle(intertyp,i))
5974           sinphi=dsin(j*tauangle(intertyp,i))
5975           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5976           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5977         enddo
5978         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5979 c        write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
5980 c     &gloc_sc(intertyp,i-3,icg)
5981         if (lprn)
5982      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5983      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5984      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
5985      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
5986         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5987        enddo !intertyp
5988       enddo
5989 c        do i=1,nres
5990 c        write (iout,*) "W@T@F",  gloc_sc(1,i,icg),gloc(i,icg)
5991 c        enddo
5992       return
5993       end
5994 c----------------------------------------------------------------------------
5995       subroutine multibody(ecorr)
5996 C This subroutine calculates multi-body contributions to energy following
5997 C the idea of Skolnick et al. If side chains I and J make a contact and
5998 C at the same time side chains I+1 and J+1 make a contact, an extra
5999 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6000       implicit real*8 (a-h,o-z)
6001       include 'DIMENSIONS'
6002       include 'COMMON.IOUNITS'
6003       include 'COMMON.DERIV'
6004       include 'COMMON.INTERACT'
6005       include 'COMMON.CONTACTS'
6006       double precision gx(3),gx1(3)
6007       logical lprn
6008
6009 C Set lprn=.true. for debugging
6010       lprn=.false.
6011
6012       if (lprn) then
6013         write (iout,'(a)') 'Contact function values:'
6014         do i=nnt,nct-2
6015           write (iout,'(i2,20(1x,i2,f10.5))')
6016      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6017         enddo
6018       endif
6019       ecorr=0.0D0
6020       do i=nnt,nct
6021         do j=1,3
6022           gradcorr(j,i)=0.0D0
6023           gradxorr(j,i)=0.0D0
6024         enddo
6025       enddo
6026       do i=nnt,nct-2
6027
6028         DO ISHIFT = 3,4
6029
6030         i1=i+ishift
6031         num_conti=num_cont(i)
6032         num_conti1=num_cont(i1)
6033         do jj=1,num_conti
6034           j=jcont(jj,i)
6035           do kk=1,num_conti1
6036             j1=jcont(kk,i1)
6037             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6038 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6039 cd   &                   ' ishift=',ishift
6040 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6041 C The system gains extra energy.
6042               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6043             endif   ! j1==j+-ishift
6044           enddo     ! kk
6045         enddo       ! jj
6046
6047         ENDDO ! ISHIFT
6048
6049       enddo         ! i
6050       return
6051       end
6052 c------------------------------------------------------------------------------
6053       double precision function esccorr(i,j,k,l,jj,kk)
6054       implicit real*8 (a-h,o-z)
6055       include 'DIMENSIONS'
6056       include 'COMMON.IOUNITS'
6057       include 'COMMON.DERIV'
6058       include 'COMMON.INTERACT'
6059       include 'COMMON.CONTACTS'
6060       double precision gx(3),gx1(3)
6061       logical lprn
6062       lprn=.false.
6063       eij=facont(jj,i)
6064       ekl=facont(kk,k)
6065 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6066 C Calculate the multi-body contribution to energy.
6067 C Calculate multi-body contributions to the gradient.
6068 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6069 cd   & k,l,(gacont(m,kk,k),m=1,3)
6070       do m=1,3
6071         gx(m) =ekl*gacont(m,jj,i)
6072         gx1(m)=eij*gacont(m,kk,k)
6073         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6074         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6075         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6076         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6077       enddo
6078       do m=i,j-1
6079         do ll=1,3
6080           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6081         enddo
6082       enddo
6083       do m=k,l-1
6084         do ll=1,3
6085           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6086         enddo
6087       enddo
6088       esccorr=-eij*ekl
6089       return
6090       end
6091 c------------------------------------------------------------------------------
6092       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6093 C This subroutine calculates multi-body contributions to hydrogen-bonding
6094       implicit real*8 (a-h,o-z)
6095       include 'DIMENSIONS'
6096       include 'COMMON.IOUNITS'
6097 #ifdef MPI
6098       include "mpif.h"
6099       parameter (max_cont=maxconts)
6100       parameter (max_dim=26)
6101       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6102       double precision zapas(max_dim,maxconts,max_fg_procs),
6103      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6104       common /przechowalnia/ zapas
6105       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6106      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6107 #endif
6108       include 'COMMON.SETUP'
6109       include 'COMMON.FFIELD'
6110       include 'COMMON.DERIV'
6111       include 'COMMON.INTERACT'
6112       include 'COMMON.CONTACTS'
6113       include 'COMMON.CONTROL'
6114       include 'COMMON.LOCAL'
6115       double precision gx(3),gx1(3),time00
6116       logical lprn,ldone
6117
6118 C Set lprn=.true. for debugging
6119       lprn=.false.
6120 #ifdef MPI
6121       n_corr=0
6122       n_corr1=0
6123       if (nfgtasks.le.1) goto 30
6124       if (lprn) then
6125         write (iout,'(a)') 'Contact function values before RECEIVE:'
6126         do i=nnt,nct-2
6127           write (iout,'(2i3,50(1x,i2,f5.2))')
6128      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6129      &    j=1,num_cont_hb(i))
6130         enddo
6131       endif
6132       call flush(iout)
6133       do i=1,ntask_cont_from
6134         ncont_recv(i)=0
6135       enddo
6136       do i=1,ntask_cont_to
6137         ncont_sent(i)=0
6138       enddo
6139 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6140 c     & ntask_cont_to
6141 C Make the list of contacts to send to send to other procesors
6142 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6143 c      call flush(iout)
6144       do i=iturn3_start,iturn3_end
6145 c        write (iout,*) "make contact list turn3",i," num_cont",
6146 c     &    num_cont_hb(i)
6147         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6148       enddo
6149       do i=iturn4_start,iturn4_end
6150 c        write (iout,*) "make contact list turn4",i," num_cont",
6151 c     &   num_cont_hb(i)
6152         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6153       enddo
6154       do ii=1,nat_sent
6155         i=iat_sent(ii)
6156 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6157 c     &    num_cont_hb(i)
6158         do j=1,num_cont_hb(i)
6159         do k=1,4
6160           jjc=jcont_hb(j,i)
6161           iproc=iint_sent_local(k,jjc,ii)
6162 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6163           if (iproc.gt.0) then
6164             ncont_sent(iproc)=ncont_sent(iproc)+1
6165             nn=ncont_sent(iproc)
6166             zapas(1,nn,iproc)=i
6167             zapas(2,nn,iproc)=jjc
6168             zapas(3,nn,iproc)=facont_hb(j,i)
6169             zapas(4,nn,iproc)=ees0p(j,i)
6170             zapas(5,nn,iproc)=ees0m(j,i)
6171             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6172             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6173             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6174             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6175             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6176             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6177             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6178             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6179             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6180             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6181             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6182             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6183             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6184             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6185             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6186             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6187             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6188             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6189             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6190             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6191             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6192           endif
6193         enddo
6194         enddo
6195       enddo
6196       if (lprn) then
6197       write (iout,*)
6198      &  "Numbers of contacts to be sent to other processors",
6199      &  (ncont_sent(i),i=1,ntask_cont_to)
6200       write (iout,*) "Contacts sent"
6201       do ii=1,ntask_cont_to
6202         nn=ncont_sent(ii)
6203         iproc=itask_cont_to(ii)
6204         write (iout,*) nn," contacts to processor",iproc,
6205      &   " of CONT_TO_COMM group"
6206         do i=1,nn
6207           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6208         enddo
6209       enddo
6210       call flush(iout)
6211       endif
6212       CorrelType=477
6213       CorrelID=fg_rank+1
6214       CorrelType1=478
6215       CorrelID1=nfgtasks+fg_rank+1
6216       ireq=0
6217 C Receive the numbers of needed contacts from other processors
6218       do ii=1,ntask_cont_from
6219         iproc=itask_cont_from(ii)
6220         ireq=ireq+1
6221         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6222      &    FG_COMM,req(ireq),IERR)
6223       enddo
6224 c      write (iout,*) "IRECV ended"
6225 c      call flush(iout)
6226 C Send the number of contacts needed by other processors
6227       do ii=1,ntask_cont_to
6228         iproc=itask_cont_to(ii)
6229         ireq=ireq+1
6230         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6231      &    FG_COMM,req(ireq),IERR)
6232       enddo
6233 c      write (iout,*) "ISEND ended"
6234 c      write (iout,*) "number of requests (nn)",ireq
6235       call flush(iout)
6236       if (ireq.gt.0)
6237      &  call MPI_Waitall(ireq,req,status_array,ierr)
6238 c      write (iout,*)
6239 c     &  "Numbers of contacts to be received from other processors",
6240 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6241 c      call flush(iout)
6242 C Receive contacts
6243       ireq=0
6244       do ii=1,ntask_cont_from
6245         iproc=itask_cont_from(ii)
6246         nn=ncont_recv(ii)
6247 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6248 c     &   " of CONT_TO_COMM group"
6249         call flush(iout)
6250         if (nn.gt.0) then
6251           ireq=ireq+1
6252           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6253      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6254 c          write (iout,*) "ireq,req",ireq,req(ireq)
6255         endif
6256       enddo
6257 C Send the contacts to processors that need them
6258       do ii=1,ntask_cont_to
6259         iproc=itask_cont_to(ii)
6260         nn=ncont_sent(ii)
6261 c        write (iout,*) nn," contacts to processor",iproc,
6262 c     &   " of CONT_TO_COMM group"
6263         if (nn.gt.0) then
6264           ireq=ireq+1
6265           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6266      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6267 c          write (iout,*) "ireq,req",ireq,req(ireq)
6268 c          do i=1,nn
6269 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6270 c          enddo
6271         endif
6272       enddo
6273 c      write (iout,*) "number of requests (contacts)",ireq
6274 c      write (iout,*) "req",(req(i),i=1,4)
6275 c      call flush(iout)
6276       if (ireq.gt.0)
6277      & call MPI_Waitall(ireq,req,status_array,ierr)
6278       do iii=1,ntask_cont_from
6279         iproc=itask_cont_from(iii)
6280         nn=ncont_recv(iii)
6281         if (lprn) then
6282         write (iout,*) "Received",nn," contacts from processor",iproc,
6283      &   " of CONT_FROM_COMM group"
6284         call flush(iout)
6285         do i=1,nn
6286           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6287         enddo
6288         call flush(iout)
6289         endif
6290         do i=1,nn
6291           ii=zapas_recv(1,i,iii)
6292 c Flag the received contacts to prevent double-counting
6293           jj=-zapas_recv(2,i,iii)
6294 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6295 c          call flush(iout)
6296           nnn=num_cont_hb(ii)+1
6297           num_cont_hb(ii)=nnn
6298           jcont_hb(nnn,ii)=jj
6299           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6300           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6301           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6302           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6303           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6304           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6305           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6306           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6307           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6308           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6309           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6310           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6311           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6312           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6313           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6314           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6315           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6316           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6317           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6318           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6319           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6320           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6321           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6322           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6323         enddo
6324       enddo
6325       call flush(iout)
6326       if (lprn) then
6327         write (iout,'(a)') 'Contact function values after receive:'
6328         do i=nnt,nct-2
6329           write (iout,'(2i3,50(1x,i3,f5.2))')
6330      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6331      &    j=1,num_cont_hb(i))
6332         enddo
6333         call flush(iout)
6334       endif
6335    30 continue
6336 #endif
6337       if (lprn) then
6338         write (iout,'(a)') 'Contact function values:'
6339         do i=nnt,nct-2
6340           write (iout,'(2i3,50(1x,i3,f5.2))')
6341      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6342      &    j=1,num_cont_hb(i))
6343         enddo
6344       endif
6345       ecorr=0.0D0
6346 C Remove the loop below after debugging !!!
6347       do i=nnt,nct
6348         do j=1,3
6349           gradcorr(j,i)=0.0D0
6350           gradxorr(j,i)=0.0D0
6351         enddo
6352       enddo
6353 C Calculate the local-electrostatic correlation terms
6354       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6355         i1=i+1
6356         num_conti=num_cont_hb(i)
6357         num_conti1=num_cont_hb(i+1)
6358         do jj=1,num_conti
6359           j=jcont_hb(jj,i)
6360           jp=iabs(j)
6361           do kk=1,num_conti1
6362             j1=jcont_hb(kk,i1)
6363             jp1=iabs(j1)
6364 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6365 c     &         ' jj=',jj,' kk=',kk
6366             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6367      &          .or. j.lt.0 .and. j1.gt.0) .and.
6368      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6369 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6370 C The system gains extra energy.
6371               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6372               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6373      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6374               n_corr=n_corr+1
6375             else if (j1.eq.j) then
6376 C Contacts I-J and I-(J+1) occur simultaneously.
6377 C The system loses extra energy.
6378 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6379             endif
6380           enddo ! kk
6381           do kk=1,num_conti
6382             j1=jcont_hb(kk,i)
6383 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6384 c    &         ' jj=',jj,' kk=',kk
6385             if (j1.eq.j+1) then
6386 C Contacts I-J and (I+1)-J occur simultaneously.
6387 C The system loses extra energy.
6388 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6389             endif ! j1==j+1
6390           enddo ! kk
6391         enddo ! jj
6392       enddo ! i
6393       return
6394       end
6395 c------------------------------------------------------------------------------
6396       subroutine add_hb_contact(ii,jj,itask)
6397       implicit real*8 (a-h,o-z)
6398       include "DIMENSIONS"
6399       include "COMMON.IOUNITS"
6400       integer max_cont
6401       integer max_dim
6402       parameter (max_cont=maxconts)
6403       parameter (max_dim=26)
6404       include "COMMON.CONTACTS"
6405       double precision zapas(max_dim,maxconts,max_fg_procs),
6406      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6407       common /przechowalnia/ zapas
6408       integer i,j,ii,jj,iproc,itask(4),nn
6409 c      write (iout,*) "itask",itask
6410       do i=1,2
6411         iproc=itask(i)
6412         if (iproc.gt.0) then
6413           do j=1,num_cont_hb(ii)
6414             jjc=jcont_hb(j,ii)
6415 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6416             if (jjc.eq.jj) then
6417               ncont_sent(iproc)=ncont_sent(iproc)+1
6418               nn=ncont_sent(iproc)
6419               zapas(1,nn,iproc)=ii
6420               zapas(2,nn,iproc)=jjc
6421               zapas(3,nn,iproc)=facont_hb(j,ii)
6422               zapas(4,nn,iproc)=ees0p(j,ii)
6423               zapas(5,nn,iproc)=ees0m(j,ii)
6424               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6425               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6426               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6427               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6428               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6429               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6430               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6431               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6432               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6433               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6434               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6435               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6436               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6437               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6438               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6439               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6440               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6441               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6442               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6443               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6444               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6445               exit
6446             endif
6447           enddo
6448         endif
6449       enddo
6450       return
6451       end
6452 c------------------------------------------------------------------------------
6453       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6454      &  n_corr1)
6455 C This subroutine calculates multi-body contributions to hydrogen-bonding
6456       implicit real*8 (a-h,o-z)
6457       include 'DIMENSIONS'
6458       include 'COMMON.IOUNITS'
6459 #ifdef MPI
6460       include "mpif.h"
6461       parameter (max_cont=maxconts)
6462       parameter (max_dim=70)
6463       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6464       double precision zapas(max_dim,maxconts,max_fg_procs),
6465      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6466       common /przechowalnia/ zapas
6467       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6468      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6469 #endif
6470       include 'COMMON.SETUP'
6471       include 'COMMON.FFIELD'
6472       include 'COMMON.DERIV'
6473       include 'COMMON.LOCAL'
6474       include 'COMMON.INTERACT'
6475       include 'COMMON.CONTACTS'
6476       include 'COMMON.CHAIN'
6477       include 'COMMON.CONTROL'
6478       double precision gx(3),gx1(3)
6479       integer num_cont_hb_old(maxres)
6480       logical lprn,ldone
6481       double precision eello4,eello5,eelo6,eello_turn6
6482       external eello4,eello5,eello6,eello_turn6
6483 C Set lprn=.true. for debugging
6484       lprn=.false.
6485       eturn6=0.0d0
6486 #ifdef MPI
6487       do i=1,nres
6488         num_cont_hb_old(i)=num_cont_hb(i)
6489       enddo
6490       n_corr=0
6491       n_corr1=0
6492       if (nfgtasks.le.1) goto 30
6493       if (lprn) then
6494         write (iout,'(a)') 'Contact function values before RECEIVE:'
6495         do i=nnt,nct-2
6496           write (iout,'(2i3,50(1x,i2,f5.2))')
6497      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6498      &    j=1,num_cont_hb(i))
6499         enddo
6500       endif
6501       call flush(iout)
6502       do i=1,ntask_cont_from
6503         ncont_recv(i)=0
6504       enddo
6505       do i=1,ntask_cont_to
6506         ncont_sent(i)=0
6507       enddo
6508 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6509 c     & ntask_cont_to
6510 C Make the list of contacts to send to send to other procesors
6511       do i=iturn3_start,iturn3_end
6512 c        write (iout,*) "make contact list turn3",i," num_cont",
6513 c     &    num_cont_hb(i)
6514         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6515       enddo
6516       do i=iturn4_start,iturn4_end
6517 c        write (iout,*) "make contact list turn4",i," num_cont",
6518 c     &   num_cont_hb(i)
6519         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6520       enddo
6521       do ii=1,nat_sent
6522         i=iat_sent(ii)
6523 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6524 c     &    num_cont_hb(i)
6525         do j=1,num_cont_hb(i)
6526         do k=1,4
6527           jjc=jcont_hb(j,i)
6528           iproc=iint_sent_local(k,jjc,ii)
6529 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6530           if (iproc.ne.0) then
6531             ncont_sent(iproc)=ncont_sent(iproc)+1
6532             nn=ncont_sent(iproc)
6533             zapas(1,nn,iproc)=i
6534             zapas(2,nn,iproc)=jjc
6535             zapas(3,nn,iproc)=d_cont(j,i)
6536             ind=3
6537             do kk=1,3
6538               ind=ind+1
6539               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6540             enddo
6541             do kk=1,2
6542               do ll=1,2
6543                 ind=ind+1
6544                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6545               enddo
6546             enddo
6547             do jj=1,5
6548               do kk=1,3
6549                 do ll=1,2
6550                   do mm=1,2
6551                     ind=ind+1
6552                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6553                   enddo
6554                 enddo
6555               enddo
6556             enddo
6557           endif
6558         enddo
6559         enddo
6560       enddo
6561       if (lprn) then
6562       write (iout,*)
6563      &  "Numbers of contacts to be sent to other processors",
6564      &  (ncont_sent(i),i=1,ntask_cont_to)
6565       write (iout,*) "Contacts sent"
6566       do ii=1,ntask_cont_to
6567         nn=ncont_sent(ii)
6568         iproc=itask_cont_to(ii)
6569         write (iout,*) nn," contacts to processor",iproc,
6570      &   " of CONT_TO_COMM group"
6571         do i=1,nn
6572           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6573         enddo
6574       enddo
6575       call flush(iout)
6576       endif
6577       CorrelType=477
6578       CorrelID=fg_rank+1
6579       CorrelType1=478
6580       CorrelID1=nfgtasks+fg_rank+1
6581       ireq=0
6582 C Receive the numbers of needed contacts from other processors
6583       do ii=1,ntask_cont_from
6584         iproc=itask_cont_from(ii)
6585         ireq=ireq+1
6586         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6587      &    FG_COMM,req(ireq),IERR)
6588       enddo
6589 c      write (iout,*) "IRECV ended"
6590 c      call flush(iout)
6591 C Send the number of contacts needed by other processors
6592       do ii=1,ntask_cont_to
6593         iproc=itask_cont_to(ii)
6594         ireq=ireq+1
6595         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6596      &    FG_COMM,req(ireq),IERR)
6597       enddo
6598 c      write (iout,*) "ISEND ended"
6599 c      write (iout,*) "number of requests (nn)",ireq
6600       call flush(iout)
6601       if (ireq.gt.0)
6602      &  call MPI_Waitall(ireq,req,status_array,ierr)
6603 c      write (iout,*)
6604 c     &  "Numbers of contacts to be received from other processors",
6605 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6606 c      call flush(iout)
6607 C Receive contacts
6608       ireq=0
6609       do ii=1,ntask_cont_from
6610         iproc=itask_cont_from(ii)
6611         nn=ncont_recv(ii)
6612 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6613 c     &   " of CONT_TO_COMM group"
6614         call flush(iout)
6615         if (nn.gt.0) then
6616           ireq=ireq+1
6617           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6618      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6619 c          write (iout,*) "ireq,req",ireq,req(ireq)
6620         endif
6621       enddo
6622 C Send the contacts to processors that need them
6623       do ii=1,ntask_cont_to
6624         iproc=itask_cont_to(ii)
6625         nn=ncont_sent(ii)
6626 c        write (iout,*) nn," contacts to processor",iproc,
6627 c     &   " of CONT_TO_COMM group"
6628         if (nn.gt.0) then
6629           ireq=ireq+1
6630           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6631      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6632 c          write (iout,*) "ireq,req",ireq,req(ireq)
6633 c          do i=1,nn
6634 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6635 c          enddo
6636         endif
6637       enddo
6638 c      write (iout,*) "number of requests (contacts)",ireq
6639 c      write (iout,*) "req",(req(i),i=1,4)
6640 c      call flush(iout)
6641       if (ireq.gt.0)
6642      & call MPI_Waitall(ireq,req,status_array,ierr)
6643       do iii=1,ntask_cont_from
6644         iproc=itask_cont_from(iii)
6645         nn=ncont_recv(iii)
6646         if (lprn) then
6647         write (iout,*) "Received",nn," contacts from processor",iproc,
6648      &   " of CONT_FROM_COMM group"
6649         call flush(iout)
6650         do i=1,nn
6651           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6652         enddo
6653         call flush(iout)
6654         endif
6655         do i=1,nn
6656           ii=zapas_recv(1,i,iii)
6657 c Flag the received contacts to prevent double-counting
6658           jj=-zapas_recv(2,i,iii)
6659 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6660 c          call flush(iout)
6661           nnn=num_cont_hb(ii)+1
6662           num_cont_hb(ii)=nnn
6663           jcont_hb(nnn,ii)=jj
6664           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6665           ind=3
6666           do kk=1,3
6667             ind=ind+1
6668             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6669           enddo
6670           do kk=1,2
6671             do ll=1,2
6672               ind=ind+1
6673               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6674             enddo
6675           enddo
6676           do jj=1,5
6677             do kk=1,3
6678               do ll=1,2
6679                 do mm=1,2
6680                   ind=ind+1
6681                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6682                 enddo
6683               enddo
6684             enddo
6685           enddo
6686         enddo
6687       enddo
6688       call flush(iout)
6689       if (lprn) then
6690         write (iout,'(a)') 'Contact function values after receive:'
6691         do i=nnt,nct-2
6692           write (iout,'(2i3,50(1x,i3,5f6.3))')
6693      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6694      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6695         enddo
6696         call flush(iout)
6697       endif
6698    30 continue
6699 #endif
6700       if (lprn) then
6701         write (iout,'(a)') 'Contact function values:'
6702         do i=nnt,nct-2
6703           write (iout,'(2i3,50(1x,i2,5f6.3))')
6704      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6705      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6706         enddo
6707       endif
6708       ecorr=0.0D0
6709       ecorr5=0.0d0
6710       ecorr6=0.0d0
6711 C Remove the loop below after debugging !!!
6712       do i=nnt,nct
6713         do j=1,3
6714           gradcorr(j,i)=0.0D0
6715           gradxorr(j,i)=0.0D0
6716         enddo
6717       enddo
6718 C Calculate the dipole-dipole interaction energies
6719       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6720       do i=iatel_s,iatel_e+1
6721         num_conti=num_cont_hb(i)
6722         do jj=1,num_conti
6723           j=jcont_hb(jj,i)
6724 #ifdef MOMENT
6725           call dipole(i,j,jj)
6726 #endif
6727         enddo
6728       enddo
6729       endif
6730 C Calculate the local-electrostatic correlation terms
6731 c                write (iout,*) "gradcorr5 in eello5 before loop"
6732 c                do iii=1,nres
6733 c                  write (iout,'(i5,3f10.5)')
6734 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6735 c                enddo
6736       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6737 c        write (iout,*) "corr loop i",i
6738         i1=i+1
6739         num_conti=num_cont_hb(i)
6740         num_conti1=num_cont_hb(i+1)
6741         do jj=1,num_conti
6742           j=jcont_hb(jj,i)
6743           jp=iabs(j)
6744           do kk=1,num_conti1
6745             j1=jcont_hb(kk,i1)
6746             jp1=iabs(j1)
6747 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6748 c     &         ' jj=',jj,' kk=',kk
6749 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6750             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6751      &          .or. j.lt.0 .and. j1.gt.0) .and.
6752      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6753 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6754 C The system gains extra energy.
6755               n_corr=n_corr+1
6756               sqd1=dsqrt(d_cont(jj,i))
6757               sqd2=dsqrt(d_cont(kk,i1))
6758               sred_geom = sqd1*sqd2
6759               IF (sred_geom.lt.cutoff_corr) THEN
6760                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6761      &            ekont,fprimcont)
6762 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6763 cd     &         ' jj=',jj,' kk=',kk
6764                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6765                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6766                 do l=1,3
6767                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6768                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6769                 enddo
6770                 n_corr1=n_corr1+1
6771 cd               write (iout,*) 'sred_geom=',sred_geom,
6772 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6773 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6774 cd               write (iout,*) "g_contij",g_contij
6775 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6776 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6777                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6778                 if (wcorr4.gt.0.0d0)
6779      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6780                   if (energy_dec.and.wcorr4.gt.0.0d0)
6781      1                 write (iout,'(a6,4i5,0pf7.3)')
6782      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6783 c                write (iout,*) "gradcorr5 before eello5"
6784 c                do iii=1,nres
6785 c                  write (iout,'(i5,3f10.5)')
6786 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6787 c                enddo
6788                 if (wcorr5.gt.0.0d0)
6789      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6790 c                write (iout,*) "gradcorr5 after eello5"
6791 c                do iii=1,nres
6792 c                  write (iout,'(i5,3f10.5)')
6793 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6794 c                enddo
6795                   if (energy_dec.and.wcorr5.gt.0.0d0)
6796      1                 write (iout,'(a6,4i5,0pf7.3)')
6797      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6798 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6799 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6800                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6801      &               .or. wturn6.eq.0.0d0))then
6802 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6803                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6804                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6805      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6806 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6807 cd     &            'ecorr6=',ecorr6
6808 cd                write (iout,'(4e15.5)') sred_geom,
6809 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6810 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6811 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6812                 else if (wturn6.gt.0.0d0
6813      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6814 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6815                   eturn6=eturn6+eello_turn6(i,jj,kk)
6816                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6817      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6818 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6819                 endif
6820               ENDIF
6821 1111          continue
6822             endif
6823           enddo ! kk
6824         enddo ! jj
6825       enddo ! i
6826       do i=1,nres
6827         num_cont_hb(i)=num_cont_hb_old(i)
6828       enddo
6829 c                write (iout,*) "gradcorr5 in eello5"
6830 c                do iii=1,nres
6831 c                  write (iout,'(i5,3f10.5)')
6832 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6833 c                enddo
6834       return
6835       end
6836 c------------------------------------------------------------------------------
6837       subroutine add_hb_contact_eello(ii,jj,itask)
6838       implicit real*8 (a-h,o-z)
6839       include "DIMENSIONS"
6840       include "COMMON.IOUNITS"
6841       integer max_cont
6842       integer max_dim
6843       parameter (max_cont=maxconts)
6844       parameter (max_dim=70)
6845       include "COMMON.CONTACTS"
6846       double precision zapas(max_dim,maxconts,max_fg_procs),
6847      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6848       common /przechowalnia/ zapas
6849       integer i,j,ii,jj,iproc,itask(4),nn
6850 c      write (iout,*) "itask",itask
6851       do i=1,2
6852         iproc=itask(i)
6853         if (iproc.gt.0) then
6854           do j=1,num_cont_hb(ii)
6855             jjc=jcont_hb(j,ii)
6856 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6857             if (jjc.eq.jj) then
6858               ncont_sent(iproc)=ncont_sent(iproc)+1
6859               nn=ncont_sent(iproc)
6860               zapas(1,nn,iproc)=ii
6861               zapas(2,nn,iproc)=jjc
6862               zapas(3,nn,iproc)=d_cont(j,ii)
6863               ind=3
6864               do kk=1,3
6865                 ind=ind+1
6866                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6867               enddo
6868               do kk=1,2
6869                 do ll=1,2
6870                   ind=ind+1
6871                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6872                 enddo
6873               enddo
6874               do jj=1,5
6875                 do kk=1,3
6876                   do ll=1,2
6877                     do mm=1,2
6878                       ind=ind+1
6879                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6880                     enddo
6881                   enddo
6882                 enddo
6883               enddo
6884               exit
6885             endif
6886           enddo
6887         endif
6888       enddo
6889       return
6890       end
6891 c------------------------------------------------------------------------------
6892       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6893       implicit real*8 (a-h,o-z)
6894       include 'DIMENSIONS'
6895       include 'COMMON.IOUNITS'
6896       include 'COMMON.DERIV'
6897       include 'COMMON.INTERACT'
6898       include 'COMMON.CONTACTS'
6899       double precision gx(3),gx1(3)
6900       logical lprn
6901       lprn=.false.
6902       eij=facont_hb(jj,i)
6903       ekl=facont_hb(kk,k)
6904       ees0pij=ees0p(jj,i)
6905       ees0pkl=ees0p(kk,k)
6906       ees0mij=ees0m(jj,i)
6907       ees0mkl=ees0m(kk,k)
6908       ekont=eij*ekl
6909       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6910 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6911 C Following 4 lines for diagnostics.
6912 cd    ees0pkl=0.0D0
6913 cd    ees0pij=1.0D0
6914 cd    ees0mkl=0.0D0
6915 cd    ees0mij=1.0D0
6916 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6917 c     & 'Contacts ',i,j,
6918 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6919 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6920 c     & 'gradcorr_long'
6921 C Calculate the multi-body contribution to energy.
6922 c      ecorr=ecorr+ekont*ees
6923 C Calculate multi-body contributions to the gradient.
6924       coeffpees0pij=coeffp*ees0pij
6925       coeffmees0mij=coeffm*ees0mij
6926       coeffpees0pkl=coeffp*ees0pkl
6927       coeffmees0mkl=coeffm*ees0mkl
6928       do ll=1,3
6929 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6930         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6931      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6932      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6933         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6934      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6935      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6936 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6937         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6938      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6939      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6940         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6941      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6942      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6943         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6944      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6945      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6946         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6947         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6948         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6949      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6950      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6951         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6952         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6953 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6954       enddo
6955 c      write (iout,*)
6956 cgrad      do m=i+1,j-1
6957 cgrad        do ll=1,3
6958 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6959 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6960 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6961 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6962 cgrad        enddo
6963 cgrad      enddo
6964 cgrad      do m=k+1,l-1
6965 cgrad        do ll=1,3
6966 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6967 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6968 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6969 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6970 cgrad        enddo
6971 cgrad      enddo
6972 c      write (iout,*) "ehbcorr",ekont*ees
6973       ehbcorr=ekont*ees
6974       return
6975       end
6976 #ifdef MOMENT
6977 C---------------------------------------------------------------------------
6978       subroutine dipole(i,j,jj)
6979       implicit real*8 (a-h,o-z)
6980       include 'DIMENSIONS'
6981       include 'COMMON.IOUNITS'
6982       include 'COMMON.CHAIN'
6983       include 'COMMON.FFIELD'
6984       include 'COMMON.DERIV'
6985       include 'COMMON.INTERACT'
6986       include 'COMMON.CONTACTS'
6987       include 'COMMON.TORSION'
6988       include 'COMMON.VAR'
6989       include 'COMMON.GEO'
6990       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6991      &  auxmat(2,2)
6992       iti1 = itortyp(itype(i+1))
6993       if (j.lt.nres-1) then
6994         itj1 = itortyp(itype(j+1))
6995       else
6996         itj1=ntortyp+1
6997       endif
6998       do iii=1,2
6999         dipi(iii,1)=Ub2(iii,i)
7000         dipderi(iii)=Ub2der(iii,i)
7001         dipi(iii,2)=b1(iii,iti1)
7002         dipj(iii,1)=Ub2(iii,j)
7003         dipderj(iii)=Ub2der(iii,j)
7004         dipj(iii,2)=b1(iii,itj1)
7005       enddo
7006       kkk=0
7007       do iii=1,2
7008         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7009         do jjj=1,2
7010           kkk=kkk+1
7011           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7012         enddo
7013       enddo
7014       do kkk=1,5
7015         do lll=1,3
7016           mmm=0
7017           do iii=1,2
7018             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7019      &        auxvec(1))
7020             do jjj=1,2
7021               mmm=mmm+1
7022               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7023             enddo
7024           enddo
7025         enddo
7026       enddo
7027       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7028       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7029       do iii=1,2
7030         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7031       enddo
7032       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7033       do iii=1,2
7034         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7035       enddo
7036       return
7037       end
7038 #endif
7039 C---------------------------------------------------------------------------
7040       subroutine calc_eello(i,j,k,l,jj,kk)
7041 C
7042 C This subroutine computes matrices and vectors needed to calculate
7043 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7044 C
7045       implicit real*8 (a-h,o-z)
7046       include 'DIMENSIONS'
7047       include 'COMMON.IOUNITS'
7048       include 'COMMON.CHAIN'
7049       include 'COMMON.DERIV'
7050       include 'COMMON.INTERACT'
7051       include 'COMMON.CONTACTS'
7052       include 'COMMON.TORSION'
7053       include 'COMMON.VAR'
7054       include 'COMMON.GEO'
7055       include 'COMMON.FFIELD'
7056       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7057      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7058       logical lprn
7059       common /kutas/ lprn
7060 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7061 cd     & ' jj=',jj,' kk=',kk
7062 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7063 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7064 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7065       do iii=1,2
7066         do jjj=1,2
7067           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7068           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7069         enddo
7070       enddo
7071       call transpose2(aa1(1,1),aa1t(1,1))
7072       call transpose2(aa2(1,1),aa2t(1,1))
7073       do kkk=1,5
7074         do lll=1,3
7075           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7076      &      aa1tder(1,1,lll,kkk))
7077           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7078      &      aa2tder(1,1,lll,kkk))
7079         enddo
7080       enddo
7081       if (l.eq.j+1) then
7082 C parallel orientation of the two CA-CA-CA frames.
7083         if (i.gt.1) then
7084           iti=itortyp(itype(i))
7085         else
7086           iti=ntortyp+1
7087         endif
7088         itk1=itortyp(itype(k+1))
7089         itj=itortyp(itype(j))
7090         if (l.lt.nres-1) then
7091           itl1=itortyp(itype(l+1))
7092         else
7093           itl1=ntortyp+1
7094         endif
7095 C A1 kernel(j+1) A2T
7096 cd        do iii=1,2
7097 cd          write (iout,'(3f10.5,5x,3f10.5)')
7098 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7099 cd        enddo
7100         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7101      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7102      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7103 C Following matrices are needed only for 6-th order cumulants
7104         IF (wcorr6.gt.0.0d0) THEN
7105         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7106      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7107      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7108         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7109      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7110      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7111      &   ADtEAderx(1,1,1,1,1,1))
7112         lprn=.false.
7113         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7114      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7115      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7116      &   ADtEA1derx(1,1,1,1,1,1))
7117         ENDIF
7118 C End 6-th order cumulants
7119 cd        lprn=.false.
7120 cd        if (lprn) then
7121 cd        write (2,*) 'In calc_eello6'
7122 cd        do iii=1,2
7123 cd          write (2,*) 'iii=',iii
7124 cd          do kkk=1,5
7125 cd            write (2,*) 'kkk=',kkk
7126 cd            do jjj=1,2
7127 cd              write (2,'(3(2f10.5),5x)')
7128 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7129 cd            enddo
7130 cd          enddo
7131 cd        enddo
7132 cd        endif
7133         call transpose2(EUgder(1,1,k),auxmat(1,1))
7134         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7135         call transpose2(EUg(1,1,k),auxmat(1,1))
7136         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7137         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7138         do iii=1,2
7139           do kkk=1,5
7140             do lll=1,3
7141               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7142      &          EAEAderx(1,1,lll,kkk,iii,1))
7143             enddo
7144           enddo
7145         enddo
7146 C A1T kernel(i+1) A2
7147         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7148      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7149      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7150 C Following matrices are needed only for 6-th order cumulants
7151         IF (wcorr6.gt.0.0d0) THEN
7152         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7153      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7154      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7155         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7156      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7157      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7158      &   ADtEAderx(1,1,1,1,1,2))
7159         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7160      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7161      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7162      &   ADtEA1derx(1,1,1,1,1,2))
7163         ENDIF
7164 C End 6-th order cumulants
7165         call transpose2(EUgder(1,1,l),auxmat(1,1))
7166         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7167         call transpose2(EUg(1,1,l),auxmat(1,1))
7168         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7169         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7170         do iii=1,2
7171           do kkk=1,5
7172             do lll=1,3
7173               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7174      &          EAEAderx(1,1,lll,kkk,iii,2))
7175             enddo
7176           enddo
7177         enddo
7178 C AEAb1 and AEAb2
7179 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7180 C They are needed only when the fifth- or the sixth-order cumulants are
7181 C indluded.
7182         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7183         call transpose2(AEA(1,1,1),auxmat(1,1))
7184         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7185         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7186         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7187         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7188         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7189         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7190         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7191         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7192         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7193         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7194         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7195         call transpose2(AEA(1,1,2),auxmat(1,1))
7196         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7197         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7198         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7199         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7200         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7201         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7202         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7203         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7204         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7205         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7206         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7207 C Calculate the Cartesian derivatives of the vectors.
7208         do iii=1,2
7209           do kkk=1,5
7210             do lll=1,3
7211               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7212               call matvec2(auxmat(1,1),b1(1,iti),
7213      &          AEAb1derx(1,lll,kkk,iii,1,1))
7214               call matvec2(auxmat(1,1),Ub2(1,i),
7215      &          AEAb2derx(1,lll,kkk,iii,1,1))
7216               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7217      &          AEAb1derx(1,lll,kkk,iii,2,1))
7218               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7219      &          AEAb2derx(1,lll,kkk,iii,2,1))
7220               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7221               call matvec2(auxmat(1,1),b1(1,itj),
7222      &          AEAb1derx(1,lll,kkk,iii,1,2))
7223               call matvec2(auxmat(1,1),Ub2(1,j),
7224      &          AEAb2derx(1,lll,kkk,iii,1,2))
7225               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7226      &          AEAb1derx(1,lll,kkk,iii,2,2))
7227               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7228      &          AEAb2derx(1,lll,kkk,iii,2,2))
7229             enddo
7230           enddo
7231         enddo
7232         ENDIF
7233 C End vectors
7234       else
7235 C Antiparallel orientation of the two CA-CA-CA frames.
7236         if (i.gt.1) then
7237           iti=itortyp(itype(i))
7238         else
7239           iti=ntortyp+1
7240         endif
7241         itk1=itortyp(itype(k+1))
7242         itl=itortyp(itype(l))
7243         itj=itortyp(itype(j))
7244         if (j.lt.nres-1) then
7245           itj1=itortyp(itype(j+1))
7246         else
7247           itj1=ntortyp+1
7248         endif
7249 C A2 kernel(j-1)T A1T
7250         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7251      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7252      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7253 C Following matrices are needed only for 6-th order cumulants
7254         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7255      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7256         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7257      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7258      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7259         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7260      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7261      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7262      &   ADtEAderx(1,1,1,1,1,1))
7263         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7264      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7265      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7266      &   ADtEA1derx(1,1,1,1,1,1))
7267         ENDIF
7268 C End 6-th order cumulants
7269         call transpose2(EUgder(1,1,k),auxmat(1,1))
7270         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7271         call transpose2(EUg(1,1,k),auxmat(1,1))
7272         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7273         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7274         do iii=1,2
7275           do kkk=1,5
7276             do lll=1,3
7277               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7278      &          EAEAderx(1,1,lll,kkk,iii,1))
7279             enddo
7280           enddo
7281         enddo
7282 C A2T kernel(i+1)T A1
7283         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7284      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7285      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7286 C Following matrices are needed only for 6-th order cumulants
7287         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7288      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7289         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7290      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7291      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7292         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7293      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7294      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7295      &   ADtEAderx(1,1,1,1,1,2))
7296         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7297      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7298      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7299      &   ADtEA1derx(1,1,1,1,1,2))
7300         ENDIF
7301 C End 6-th order cumulants
7302         call transpose2(EUgder(1,1,j),auxmat(1,1))
7303         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7304         call transpose2(EUg(1,1,j),auxmat(1,1))
7305         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7306         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7307         do iii=1,2
7308           do kkk=1,5
7309             do lll=1,3
7310               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7311      &          EAEAderx(1,1,lll,kkk,iii,2))
7312             enddo
7313           enddo
7314         enddo
7315 C AEAb1 and AEAb2
7316 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7317 C They are needed only when the fifth- or the sixth-order cumulants are
7318 C indluded.
7319         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7320      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7321         call transpose2(AEA(1,1,1),auxmat(1,1))
7322         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7323         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7324         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7325         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7326         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7327         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7328         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7329         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7330         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7331         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7332         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7333         call transpose2(AEA(1,1,2),auxmat(1,1))
7334         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7335         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7336         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7337         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7338         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7339         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7340         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7341         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7342         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7343         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7344         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7345 C Calculate the Cartesian derivatives of the vectors.
7346         do iii=1,2
7347           do kkk=1,5
7348             do lll=1,3
7349               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7350               call matvec2(auxmat(1,1),b1(1,iti),
7351      &          AEAb1derx(1,lll,kkk,iii,1,1))
7352               call matvec2(auxmat(1,1),Ub2(1,i),
7353      &          AEAb2derx(1,lll,kkk,iii,1,1))
7354               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7355      &          AEAb1derx(1,lll,kkk,iii,2,1))
7356               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7357      &          AEAb2derx(1,lll,kkk,iii,2,1))
7358               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7359               call matvec2(auxmat(1,1),b1(1,itl),
7360      &          AEAb1derx(1,lll,kkk,iii,1,2))
7361               call matvec2(auxmat(1,1),Ub2(1,l),
7362      &          AEAb2derx(1,lll,kkk,iii,1,2))
7363               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7364      &          AEAb1derx(1,lll,kkk,iii,2,2))
7365               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7366      &          AEAb2derx(1,lll,kkk,iii,2,2))
7367             enddo
7368           enddo
7369         enddo
7370         ENDIF
7371 C End vectors
7372       endif
7373       return
7374       end
7375 C---------------------------------------------------------------------------
7376       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7377      &  KK,KKderg,AKA,AKAderg,AKAderx)
7378       implicit none
7379       integer nderg
7380       logical transp
7381       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7382      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7383      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7384       integer iii,kkk,lll
7385       integer jjj,mmm
7386       logical lprn
7387       common /kutas/ lprn
7388       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7389       do iii=1,nderg
7390         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7391      &    AKAderg(1,1,iii))
7392       enddo
7393 cd      if (lprn) write (2,*) 'In kernel'
7394       do kkk=1,5
7395 cd        if (lprn) write (2,*) 'kkk=',kkk
7396         do lll=1,3
7397           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7398      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7399 cd          if (lprn) then
7400 cd            write (2,*) 'lll=',lll
7401 cd            write (2,*) 'iii=1'
7402 cd            do jjj=1,2
7403 cd              write (2,'(3(2f10.5),5x)')
7404 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7405 cd            enddo
7406 cd          endif
7407           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7408      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7409 cd          if (lprn) then
7410 cd            write (2,*) 'lll=',lll
7411 cd            write (2,*) 'iii=2'
7412 cd            do jjj=1,2
7413 cd              write (2,'(3(2f10.5),5x)')
7414 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7415 cd            enddo
7416 cd          endif
7417         enddo
7418       enddo
7419       return
7420       end
7421 C---------------------------------------------------------------------------
7422       double precision function eello4(i,j,k,l,jj,kk)
7423       implicit real*8 (a-h,o-z)
7424       include 'DIMENSIONS'
7425       include 'COMMON.IOUNITS'
7426       include 'COMMON.CHAIN'
7427       include 'COMMON.DERIV'
7428       include 'COMMON.INTERACT'
7429       include 'COMMON.CONTACTS'
7430       include 'COMMON.TORSION'
7431       include 'COMMON.VAR'
7432       include 'COMMON.GEO'
7433       double precision pizda(2,2),ggg1(3),ggg2(3)
7434 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7435 cd        eello4=0.0d0
7436 cd        return
7437 cd      endif
7438 cd      print *,'eello4:',i,j,k,l,jj,kk
7439 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7440 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7441 cold      eij=facont_hb(jj,i)
7442 cold      ekl=facont_hb(kk,k)
7443 cold      ekont=eij*ekl
7444       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7445 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7446       gcorr_loc(k-1)=gcorr_loc(k-1)
7447      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7448       if (l.eq.j+1) then
7449         gcorr_loc(l-1)=gcorr_loc(l-1)
7450      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7451       else
7452         gcorr_loc(j-1)=gcorr_loc(j-1)
7453      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7454       endif
7455       do iii=1,2
7456         do kkk=1,5
7457           do lll=1,3
7458             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7459      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7460 cd            derx(lll,kkk,iii)=0.0d0
7461           enddo
7462         enddo
7463       enddo
7464 cd      gcorr_loc(l-1)=0.0d0
7465 cd      gcorr_loc(j-1)=0.0d0
7466 cd      gcorr_loc(k-1)=0.0d0
7467 cd      eel4=1.0d0
7468 cd      write (iout,*)'Contacts have occurred for peptide groups',
7469 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7470 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7471       if (j.lt.nres-1) then
7472         j1=j+1
7473         j2=j-1
7474       else
7475         j1=j-1
7476         j2=j-2
7477       endif
7478       if (l.lt.nres-1) then
7479         l1=l+1
7480         l2=l-1
7481       else
7482         l1=l-1
7483         l2=l-2
7484       endif
7485       do ll=1,3
7486 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7487 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7488         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7489         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7490 cgrad        ghalf=0.5d0*ggg1(ll)
7491         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7492         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7493         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7494         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7495         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7496         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7497 cgrad        ghalf=0.5d0*ggg2(ll)
7498         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7499         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7500         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7501         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7502         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7503         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7504       enddo
7505 cgrad      do m=i+1,j-1
7506 cgrad        do ll=1,3
7507 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7508 cgrad        enddo
7509 cgrad      enddo
7510 cgrad      do m=k+1,l-1
7511 cgrad        do ll=1,3
7512 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7513 cgrad        enddo
7514 cgrad      enddo
7515 cgrad      do m=i+2,j2
7516 cgrad        do ll=1,3
7517 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7518 cgrad        enddo
7519 cgrad      enddo
7520 cgrad      do m=k+2,l2
7521 cgrad        do ll=1,3
7522 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7523 cgrad        enddo
7524 cgrad      enddo
7525 cd      do iii=1,nres-3
7526 cd        write (2,*) iii,gcorr_loc(iii)
7527 cd      enddo
7528       eello4=ekont*eel4
7529 cd      write (2,*) 'ekont',ekont
7530 cd      write (iout,*) 'eello4',ekont*eel4
7531       return
7532       end
7533 C---------------------------------------------------------------------------
7534       double precision function eello5(i,j,k,l,jj,kk)
7535       implicit real*8 (a-h,o-z)
7536       include 'DIMENSIONS'
7537       include 'COMMON.IOUNITS'
7538       include 'COMMON.CHAIN'
7539       include 'COMMON.DERIV'
7540       include 'COMMON.INTERACT'
7541       include 'COMMON.CONTACTS'
7542       include 'COMMON.TORSION'
7543       include 'COMMON.VAR'
7544       include 'COMMON.GEO'
7545       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7546       double precision ggg1(3),ggg2(3)
7547 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7548 C                                                                              C
7549 C                            Parallel chains                                   C
7550 C                                                                              C
7551 C          o             o                   o             o                   C
7552 C         /l\           / \             \   / \           / \   /              C
7553 C        /   \         /   \             \ /   \         /   \ /               C
7554 C       j| o |l1       | o |              o| o |         | o |o                C
7555 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7556 C      \i/   \         /   \ /             /   \         /   \                 C
7557 C       o    k1             o                                                  C
7558 C         (I)          (II)                (III)          (IV)                 C
7559 C                                                                              C
7560 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7561 C                                                                              C
7562 C                            Antiparallel chains                               C
7563 C                                                                              C
7564 C          o             o                   o             o                   C
7565 C         /j\           / \             \   / \           / \   /              C
7566 C        /   \         /   \             \ /   \         /   \ /               C
7567 C      j1| o |l        | o |              o| o |         | o |o                C
7568 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7569 C      \i/   \         /   \ /             /   \         /   \                 C
7570 C       o     k1            o                                                  C
7571 C         (I)          (II)                (III)          (IV)                 C
7572 C                                                                              C
7573 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7574 C                                                                              C
7575 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7576 C                                                                              C
7577 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7578 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7579 cd        eello5=0.0d0
7580 cd        return
7581 cd      endif
7582 cd      write (iout,*)
7583 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7584 cd     &   ' and',k,l
7585       itk=itortyp(itype(k))
7586       itl=itortyp(itype(l))
7587       itj=itortyp(itype(j))
7588       eello5_1=0.0d0
7589       eello5_2=0.0d0
7590       eello5_3=0.0d0
7591       eello5_4=0.0d0
7592 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7593 cd     &   eel5_3_num,eel5_4_num)
7594       do iii=1,2
7595         do kkk=1,5
7596           do lll=1,3
7597             derx(lll,kkk,iii)=0.0d0
7598           enddo
7599         enddo
7600       enddo
7601 cd      eij=facont_hb(jj,i)
7602 cd      ekl=facont_hb(kk,k)
7603 cd      ekont=eij*ekl
7604 cd      write (iout,*)'Contacts have occurred for peptide groups',
7605 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7606 cd      goto 1111
7607 C Contribution from the graph I.
7608 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7609 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7610       call transpose2(EUg(1,1,k),auxmat(1,1))
7611       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7612       vv(1)=pizda(1,1)-pizda(2,2)
7613       vv(2)=pizda(1,2)+pizda(2,1)
7614       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7615      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7616 C Explicit gradient in virtual-dihedral angles.
7617       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7618      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7619      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7620       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7621       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7622       vv(1)=pizda(1,1)-pizda(2,2)
7623       vv(2)=pizda(1,2)+pizda(2,1)
7624       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7625      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7626      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7627       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7628       vv(1)=pizda(1,1)-pizda(2,2)
7629       vv(2)=pizda(1,2)+pizda(2,1)
7630       if (l.eq.j+1) then
7631         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7632      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7633      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7634       else
7635         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7636      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7637      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7638       endif
7639 C Cartesian gradient
7640       do iii=1,2
7641         do kkk=1,5
7642           do lll=1,3
7643             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7644      &        pizda(1,1))
7645             vv(1)=pizda(1,1)-pizda(2,2)
7646             vv(2)=pizda(1,2)+pizda(2,1)
7647             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7648      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7649      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7650           enddo
7651         enddo
7652       enddo
7653 c      goto 1112
7654 c1111  continue
7655 C Contribution from graph II
7656       call transpose2(EE(1,1,itk),auxmat(1,1))
7657       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7658       vv(1)=pizda(1,1)+pizda(2,2)
7659       vv(2)=pizda(2,1)-pizda(1,2)
7660       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7661      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7662 C Explicit gradient in virtual-dihedral angles.
7663       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7664      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7665       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7666       vv(1)=pizda(1,1)+pizda(2,2)
7667       vv(2)=pizda(2,1)-pizda(1,2)
7668       if (l.eq.j+1) then
7669         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7670      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7671      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7672       else
7673         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7674      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7675      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7676       endif
7677 C Cartesian gradient
7678       do iii=1,2
7679         do kkk=1,5
7680           do lll=1,3
7681             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7682      &        pizda(1,1))
7683             vv(1)=pizda(1,1)+pizda(2,2)
7684             vv(2)=pizda(2,1)-pizda(1,2)
7685             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7686      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7687      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7688           enddo
7689         enddo
7690       enddo
7691 cd      goto 1112
7692 cd1111  continue
7693       if (l.eq.j+1) then
7694 cd        goto 1110
7695 C Parallel orientation
7696 C Contribution from graph III
7697         call transpose2(EUg(1,1,l),auxmat(1,1))
7698         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7699         vv(1)=pizda(1,1)-pizda(2,2)
7700         vv(2)=pizda(1,2)+pizda(2,1)
7701         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7702      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7703 C Explicit gradient in virtual-dihedral angles.
7704         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7705      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7706      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7707         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7708         vv(1)=pizda(1,1)-pizda(2,2)
7709         vv(2)=pizda(1,2)+pizda(2,1)
7710         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7711      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7712      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7713         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7714         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7715         vv(1)=pizda(1,1)-pizda(2,2)
7716         vv(2)=pizda(1,2)+pizda(2,1)
7717         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7718      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7719      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7720 C Cartesian gradient
7721         do iii=1,2
7722           do kkk=1,5
7723             do lll=1,3
7724               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7725      &          pizda(1,1))
7726               vv(1)=pizda(1,1)-pizda(2,2)
7727               vv(2)=pizda(1,2)+pizda(2,1)
7728               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7729      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7730      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7731             enddo
7732           enddo
7733         enddo
7734 cd        goto 1112
7735 C Contribution from graph IV
7736 cd1110    continue
7737         call transpose2(EE(1,1,itl),auxmat(1,1))
7738         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7739         vv(1)=pizda(1,1)+pizda(2,2)
7740         vv(2)=pizda(2,1)-pizda(1,2)
7741         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7742      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7743 C Explicit gradient in virtual-dihedral angles.
7744         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7745      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7746         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7747         vv(1)=pizda(1,1)+pizda(2,2)
7748         vv(2)=pizda(2,1)-pizda(1,2)
7749         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7750      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7751      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7752 C Cartesian gradient
7753         do iii=1,2
7754           do kkk=1,5
7755             do lll=1,3
7756               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7757      &          pizda(1,1))
7758               vv(1)=pizda(1,1)+pizda(2,2)
7759               vv(2)=pizda(2,1)-pizda(1,2)
7760               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7761      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7762      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7763             enddo
7764           enddo
7765         enddo
7766       else
7767 C Antiparallel orientation
7768 C Contribution from graph III
7769 c        goto 1110
7770         call transpose2(EUg(1,1,j),auxmat(1,1))
7771         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7772         vv(1)=pizda(1,1)-pizda(2,2)
7773         vv(2)=pizda(1,2)+pizda(2,1)
7774         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7775      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7776 C Explicit gradient in virtual-dihedral angles.
7777         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7778      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7779      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7780         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7781         vv(1)=pizda(1,1)-pizda(2,2)
7782         vv(2)=pizda(1,2)+pizda(2,1)
7783         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7784      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7785      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7786         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7787         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7788         vv(1)=pizda(1,1)-pizda(2,2)
7789         vv(2)=pizda(1,2)+pizda(2,1)
7790         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7791      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7792      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7793 C Cartesian gradient
7794         do iii=1,2
7795           do kkk=1,5
7796             do lll=1,3
7797               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7798      &          pizda(1,1))
7799               vv(1)=pizda(1,1)-pizda(2,2)
7800               vv(2)=pizda(1,2)+pizda(2,1)
7801               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7802      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7803      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7804             enddo
7805           enddo
7806         enddo
7807 cd        goto 1112
7808 C Contribution from graph IV
7809 1110    continue
7810         call transpose2(EE(1,1,itj),auxmat(1,1))
7811         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7812         vv(1)=pizda(1,1)+pizda(2,2)
7813         vv(2)=pizda(2,1)-pizda(1,2)
7814         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7815      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7816 C Explicit gradient in virtual-dihedral angles.
7817         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7818      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7819         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7820         vv(1)=pizda(1,1)+pizda(2,2)
7821         vv(2)=pizda(2,1)-pizda(1,2)
7822         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7823      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7824      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7825 C Cartesian gradient
7826         do iii=1,2
7827           do kkk=1,5
7828             do lll=1,3
7829               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7830      &          pizda(1,1))
7831               vv(1)=pizda(1,1)+pizda(2,2)
7832               vv(2)=pizda(2,1)-pizda(1,2)
7833               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7834      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7835      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7836             enddo
7837           enddo
7838         enddo
7839       endif
7840 1112  continue
7841       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7842 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7843 cd        write (2,*) 'ijkl',i,j,k,l
7844 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7845 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7846 cd      endif
7847 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7848 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7849 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7850 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7851       if (j.lt.nres-1) then
7852         j1=j+1
7853         j2=j-1
7854       else
7855         j1=j-1
7856         j2=j-2
7857       endif
7858       if (l.lt.nres-1) then
7859         l1=l+1
7860         l2=l-1
7861       else
7862         l1=l-1
7863         l2=l-2
7864       endif
7865 cd      eij=1.0d0
7866 cd      ekl=1.0d0
7867 cd      ekont=1.0d0
7868 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7869 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7870 C        summed up outside the subrouine as for the other subroutines
7871 C        handling long-range interactions. The old code is commented out
7872 C        with "cgrad" to keep track of changes.
7873       do ll=1,3
7874 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7875 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7876         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7877         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7878 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7879 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7880 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7881 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7882 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7883 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7884 c     &   gradcorr5ij,
7885 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7886 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7887 cgrad        ghalf=0.5d0*ggg1(ll)
7888 cd        ghalf=0.0d0
7889         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7890         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7891         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7892         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7893         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7894         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7895 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7896 cgrad        ghalf=0.5d0*ggg2(ll)
7897 cd        ghalf=0.0d0
7898         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7899         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7900         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7901         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7902         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7903         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7904       enddo
7905 cd      goto 1112
7906 cgrad      do m=i+1,j-1
7907 cgrad        do ll=1,3
7908 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7909 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7910 cgrad        enddo
7911 cgrad      enddo
7912 cgrad      do m=k+1,l-1
7913 cgrad        do ll=1,3
7914 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7915 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7916 cgrad        enddo
7917 cgrad      enddo
7918 c1112  continue
7919 cgrad      do m=i+2,j2
7920 cgrad        do ll=1,3
7921 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7922 cgrad        enddo
7923 cgrad      enddo
7924 cgrad      do m=k+2,l2
7925 cgrad        do ll=1,3
7926 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7927 cgrad        enddo
7928 cgrad      enddo
7929 cd      do iii=1,nres-3
7930 cd        write (2,*) iii,g_corr5_loc(iii)
7931 cd      enddo
7932       eello5=ekont*eel5
7933 cd      write (2,*) 'ekont',ekont
7934 cd      write (iout,*) 'eello5',ekont*eel5
7935       return
7936       end
7937 c--------------------------------------------------------------------------
7938       double precision function eello6(i,j,k,l,jj,kk)
7939       implicit real*8 (a-h,o-z)
7940       include 'DIMENSIONS'
7941       include 'COMMON.IOUNITS'
7942       include 'COMMON.CHAIN'
7943       include 'COMMON.DERIV'
7944       include 'COMMON.INTERACT'
7945       include 'COMMON.CONTACTS'
7946       include 'COMMON.TORSION'
7947       include 'COMMON.VAR'
7948       include 'COMMON.GEO'
7949       include 'COMMON.FFIELD'
7950       double precision ggg1(3),ggg2(3)
7951 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7952 cd        eello6=0.0d0
7953 cd        return
7954 cd      endif
7955 cd      write (iout,*)
7956 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7957 cd     &   ' and',k,l
7958       eello6_1=0.0d0
7959       eello6_2=0.0d0
7960       eello6_3=0.0d0
7961       eello6_4=0.0d0
7962       eello6_5=0.0d0
7963       eello6_6=0.0d0
7964 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7965 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7966       do iii=1,2
7967         do kkk=1,5
7968           do lll=1,3
7969             derx(lll,kkk,iii)=0.0d0
7970           enddo
7971         enddo
7972       enddo
7973 cd      eij=facont_hb(jj,i)
7974 cd      ekl=facont_hb(kk,k)
7975 cd      ekont=eij*ekl
7976 cd      eij=1.0d0
7977 cd      ekl=1.0d0
7978 cd      ekont=1.0d0
7979       if (l.eq.j+1) then
7980         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7981         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7982         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7983         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7984         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7985         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7986       else
7987         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7988         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7989         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7990         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7991         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7992           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7993         else
7994           eello6_5=0.0d0
7995         endif
7996         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7997       endif
7998 C If turn contributions are considered, they will be handled separately.
7999       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8000 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8001 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8002 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8003 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8004 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8005 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8006 cd      goto 1112
8007       if (j.lt.nres-1) then
8008         j1=j+1
8009         j2=j-1
8010       else
8011         j1=j-1
8012         j2=j-2
8013       endif
8014       if (l.lt.nres-1) then
8015         l1=l+1
8016         l2=l-1
8017       else
8018         l1=l-1
8019         l2=l-2
8020       endif
8021       do ll=1,3
8022 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8023 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8024 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8025 cgrad        ghalf=0.5d0*ggg1(ll)
8026 cd        ghalf=0.0d0
8027         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8028         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8029         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8030         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8031         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8032         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8033         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8034         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8035 cgrad        ghalf=0.5d0*ggg2(ll)
8036 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8037 cd        ghalf=0.0d0
8038         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8039         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8040         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8041         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8042         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8043         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8044       enddo
8045 cd      goto 1112
8046 cgrad      do m=i+1,j-1
8047 cgrad        do ll=1,3
8048 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8049 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8050 cgrad        enddo
8051 cgrad      enddo
8052 cgrad      do m=k+1,l-1
8053 cgrad        do ll=1,3
8054 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8055 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8056 cgrad        enddo
8057 cgrad      enddo
8058 cgrad1112  continue
8059 cgrad      do m=i+2,j2
8060 cgrad        do ll=1,3
8061 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8062 cgrad        enddo
8063 cgrad      enddo
8064 cgrad      do m=k+2,l2
8065 cgrad        do ll=1,3
8066 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8067 cgrad        enddo
8068 cgrad      enddo
8069 cd      do iii=1,nres-3
8070 cd        write (2,*) iii,g_corr6_loc(iii)
8071 cd      enddo
8072       eello6=ekont*eel6
8073 cd      write (2,*) 'ekont',ekont
8074 cd      write (iout,*) 'eello6',ekont*eel6
8075       return
8076       end
8077 c--------------------------------------------------------------------------
8078       double precision function eello6_graph1(i,j,k,l,imat,swap)
8079       implicit real*8 (a-h,o-z)
8080       include 'DIMENSIONS'
8081       include 'COMMON.IOUNITS'
8082       include 'COMMON.CHAIN'
8083       include 'COMMON.DERIV'
8084       include 'COMMON.INTERACT'
8085       include 'COMMON.CONTACTS'
8086       include 'COMMON.TORSION'
8087       include 'COMMON.VAR'
8088       include 'COMMON.GEO'
8089       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8090       logical swap
8091       logical lprn
8092       common /kutas/ lprn
8093 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8094 C
8095 C      Parallel       Antiparallel
8096 C
8097 C          o             o
8098 C         /l\           /j\
8099 C        /   \         /   \
8100 C       /| o |         | o |\
8101 C     \ j|/k\|  /   \  |/k\|l /
8102 C      \ /   \ /     \ /   \ /
8103 C       o     o       o     o
8104 C       i             i
8105 C
8106 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8107       itk=itortyp(itype(k))
8108       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8109       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8110       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8111       call transpose2(EUgC(1,1,k),auxmat(1,1))
8112       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8113       vv1(1)=pizda1(1,1)-pizda1(2,2)
8114       vv1(2)=pizda1(1,2)+pizda1(2,1)
8115       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8116       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8117       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8118       s5=scalar2(vv(1),Dtobr2(1,i))
8119 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8120       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8121       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8122      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8123      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8124      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8125      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8126      & +scalar2(vv(1),Dtobr2der(1,i)))
8127       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8128       vv1(1)=pizda1(1,1)-pizda1(2,2)
8129       vv1(2)=pizda1(1,2)+pizda1(2,1)
8130       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8131       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8132       if (l.eq.j+1) then
8133         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8134      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8135      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8136      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8137      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8138       else
8139         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8140      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8141      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8142      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8143      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8144       endif
8145       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8146       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8147       vv1(1)=pizda1(1,1)-pizda1(2,2)
8148       vv1(2)=pizda1(1,2)+pizda1(2,1)
8149       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8150      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8151      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8152      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8153       do iii=1,2
8154         if (swap) then
8155           ind=3-iii
8156         else
8157           ind=iii
8158         endif
8159         do kkk=1,5
8160           do lll=1,3
8161             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8162             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8163             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8164             call transpose2(EUgC(1,1,k),auxmat(1,1))
8165             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8166      &        pizda1(1,1))
8167             vv1(1)=pizda1(1,1)-pizda1(2,2)
8168             vv1(2)=pizda1(1,2)+pizda1(2,1)
8169             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8170             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8171      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8172             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8173      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8174             s5=scalar2(vv(1),Dtobr2(1,i))
8175             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8176           enddo
8177         enddo
8178       enddo
8179       return
8180       end
8181 c----------------------------------------------------------------------------
8182       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8183       implicit real*8 (a-h,o-z)
8184       include 'DIMENSIONS'
8185       include 'COMMON.IOUNITS'
8186       include 'COMMON.CHAIN'
8187       include 'COMMON.DERIV'
8188       include 'COMMON.INTERACT'
8189       include 'COMMON.CONTACTS'
8190       include 'COMMON.TORSION'
8191       include 'COMMON.VAR'
8192       include 'COMMON.GEO'
8193       logical swap
8194       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8195      & auxvec1(2),auxvec2(1),auxmat1(2,2)
8196       logical lprn
8197       common /kutas/ lprn
8198 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8199 C                                                                              C
8200 C      Parallel       Antiparallel                                             C
8201 C                                                                              C
8202 C          o             o                                                     C
8203 C     \   /l\           /j\   /                                                C
8204 C      \ /   \         /   \ /                                                 C
8205 C       o| o |         | o |o                                                  C
8206 C     \ j|/k\|      \  |/k\|l                                                  C
8207 C      \ /   \       \ /   \                                                   C
8208 C       o             o                                                        C
8209 C       i             i                                                        C
8210 C                                                                              C
8211 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8212 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8213 C AL 7/4/01 s1 would occur in the sixth-order moment,
8214 C           but not in a cluster cumulant
8215 #ifdef MOMENT
8216       s1=dip(1,jj,i)*dip(1,kk,k)
8217 #endif
8218       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8219       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8220       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8221       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8222       call transpose2(EUg(1,1,k),auxmat(1,1))
8223       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8224       vv(1)=pizda(1,1)-pizda(2,2)
8225       vv(2)=pizda(1,2)+pizda(2,1)
8226       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8227 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8228 #ifdef MOMENT
8229       eello6_graph2=-(s1+s2+s3+s4)
8230 #else
8231       eello6_graph2=-(s2+s3+s4)
8232 #endif
8233 c      eello6_graph2=-s3
8234 C Derivatives in gamma(i-1)
8235       if (i.gt.1) then
8236 #ifdef MOMENT
8237         s1=dipderg(1,jj,i)*dip(1,kk,k)
8238 #endif
8239         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8240         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8241         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8242         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8243 #ifdef MOMENT
8244         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8245 #else
8246         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8247 #endif
8248 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8249       endif
8250 C Derivatives in gamma(k-1)
8251 #ifdef MOMENT
8252       s1=dip(1,jj,i)*dipderg(1,kk,k)
8253 #endif
8254       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8255       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8256       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8257       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8258       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8259       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8260       vv(1)=pizda(1,1)-pizda(2,2)
8261       vv(2)=pizda(1,2)+pizda(2,1)
8262       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8263 #ifdef MOMENT
8264       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8265 #else
8266       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8267 #endif
8268 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8269 C Derivatives in gamma(j-1) or gamma(l-1)
8270       if (j.gt.1) then
8271 #ifdef MOMENT
8272         s1=dipderg(3,jj,i)*dip(1,kk,k)
8273 #endif
8274         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8275         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8276         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8277         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8278         vv(1)=pizda(1,1)-pizda(2,2)
8279         vv(2)=pizda(1,2)+pizda(2,1)
8280         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8281 #ifdef MOMENT
8282         if (swap) then
8283           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8284         else
8285           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8286         endif
8287 #endif
8288         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8289 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8290       endif
8291 C Derivatives in gamma(l-1) or gamma(j-1)
8292       if (l.gt.1) then
8293 #ifdef MOMENT
8294         s1=dip(1,jj,i)*dipderg(3,kk,k)
8295 #endif
8296         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8297         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8298         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8299         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8300         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8301         vv(1)=pizda(1,1)-pizda(2,2)
8302         vv(2)=pizda(1,2)+pizda(2,1)
8303         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8304 #ifdef MOMENT
8305         if (swap) then
8306           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8307         else
8308           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8309         endif
8310 #endif
8311         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8312 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8313       endif
8314 C Cartesian derivatives.
8315       if (lprn) then
8316         write (2,*) 'In eello6_graph2'
8317         do iii=1,2
8318           write (2,*) 'iii=',iii
8319           do kkk=1,5
8320             write (2,*) 'kkk=',kkk
8321             do jjj=1,2
8322               write (2,'(3(2f10.5),5x)')
8323      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8324             enddo
8325           enddo
8326         enddo
8327       endif
8328       do iii=1,2
8329         do kkk=1,5
8330           do lll=1,3
8331 #ifdef MOMENT
8332             if (iii.eq.1) then
8333               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8334             else
8335               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8336             endif
8337 #endif
8338             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8339      &        auxvec(1))
8340             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8341             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8342      &        auxvec(1))
8343             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8344             call transpose2(EUg(1,1,k),auxmat(1,1))
8345             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8346      &        pizda(1,1))
8347             vv(1)=pizda(1,1)-pizda(2,2)
8348             vv(2)=pizda(1,2)+pizda(2,1)
8349             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8350 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8351 #ifdef MOMENT
8352             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8353 #else
8354             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8355 #endif
8356             if (swap) then
8357               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8358             else
8359               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8360             endif
8361           enddo
8362         enddo
8363       enddo
8364       return
8365       end
8366 c----------------------------------------------------------------------------
8367       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8368       implicit real*8 (a-h,o-z)
8369       include 'DIMENSIONS'
8370       include 'COMMON.IOUNITS'
8371       include 'COMMON.CHAIN'
8372       include 'COMMON.DERIV'
8373       include 'COMMON.INTERACT'
8374       include 'COMMON.CONTACTS'
8375       include 'COMMON.TORSION'
8376       include 'COMMON.VAR'
8377       include 'COMMON.GEO'
8378       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8379       logical swap
8380 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8381 C                                                                              C
8382 C      Parallel       Antiparallel                                             C
8383 C                                                                              C
8384 C          o             o                                                     C
8385 C         /l\   /   \   /j\                                                    C
8386 C        /   \ /     \ /   \                                                   C
8387 C       /| o |o       o| o |\                                                  C
8388 C       j|/k\|  /      |/k\|l /                                                C
8389 C        /   \ /       /   \ /                                                 C
8390 C       /     o       /     o                                                  C
8391 C       i             i                                                        C
8392 C                                                                              C
8393 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8394 C
8395 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8396 C           energy moment and not to the cluster cumulant.
8397       iti=itortyp(itype(i))
8398       if (j.lt.nres-1) then
8399         itj1=itortyp(itype(j+1))
8400       else
8401         itj1=ntortyp+1
8402       endif
8403       itk=itortyp(itype(k))
8404       itk1=itortyp(itype(k+1))
8405       if (l.lt.nres-1) then
8406         itl1=itortyp(itype(l+1))
8407       else
8408         itl1=ntortyp+1
8409       endif
8410 #ifdef MOMENT
8411       s1=dip(4,jj,i)*dip(4,kk,k)
8412 #endif
8413       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8414       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8415       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8416       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8417       call transpose2(EE(1,1,itk),auxmat(1,1))
8418       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8419       vv(1)=pizda(1,1)+pizda(2,2)
8420       vv(2)=pizda(2,1)-pizda(1,2)
8421       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8422 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8423 cd     & "sum",-(s2+s3+s4)
8424 #ifdef MOMENT
8425       eello6_graph3=-(s1+s2+s3+s4)
8426 #else
8427       eello6_graph3=-(s2+s3+s4)
8428 #endif
8429 c      eello6_graph3=-s4
8430 C Derivatives in gamma(k-1)
8431       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8432       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8433       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8434       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8435 C Derivatives in gamma(l-1)
8436       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8437       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8438       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8439       vv(1)=pizda(1,1)+pizda(2,2)
8440       vv(2)=pizda(2,1)-pizda(1,2)
8441       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8442       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8443 C Cartesian derivatives.
8444       do iii=1,2
8445         do kkk=1,5
8446           do lll=1,3
8447 #ifdef MOMENT
8448             if (iii.eq.1) then
8449               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8450             else
8451               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8452             endif
8453 #endif
8454             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8455      &        auxvec(1))
8456             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8457             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8458      &        auxvec(1))
8459             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8460             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8461      &        pizda(1,1))
8462             vv(1)=pizda(1,1)+pizda(2,2)
8463             vv(2)=pizda(2,1)-pizda(1,2)
8464             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8465 #ifdef MOMENT
8466             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8467 #else
8468             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8469 #endif
8470             if (swap) then
8471               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8472             else
8473               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8474             endif
8475 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8476           enddo
8477         enddo
8478       enddo
8479       return
8480       end
8481 c----------------------------------------------------------------------------
8482       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8483       implicit real*8 (a-h,o-z)
8484       include 'DIMENSIONS'
8485       include 'COMMON.IOUNITS'
8486       include 'COMMON.CHAIN'
8487       include 'COMMON.DERIV'
8488       include 'COMMON.INTERACT'
8489       include 'COMMON.CONTACTS'
8490       include 'COMMON.TORSION'
8491       include 'COMMON.VAR'
8492       include 'COMMON.GEO'
8493       include 'COMMON.FFIELD'
8494       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8495      & auxvec1(2),auxmat1(2,2)
8496       logical swap
8497 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8498 C                                                                              C
8499 C      Parallel       Antiparallel                                             C
8500 C                                                                              C
8501 C          o             o                                                     C
8502 C         /l\   /   \   /j\                                                    C
8503 C        /   \ /     \ /   \                                                   C
8504 C       /| o |o       o| o |\                                                  C
8505 C     \ j|/k\|      \  |/k\|l                                                  C
8506 C      \ /   \       \ /   \                                                   C
8507 C       o     \       o     \                                                  C
8508 C       i             i                                                        C
8509 C                                                                              C
8510 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8511 C
8512 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8513 C           energy moment and not to the cluster cumulant.
8514 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8515       iti=itortyp(itype(i))
8516       itj=itortyp(itype(j))
8517       if (j.lt.nres-1) then
8518         itj1=itortyp(itype(j+1))
8519       else
8520         itj1=ntortyp+1
8521       endif
8522       itk=itortyp(itype(k))
8523       if (k.lt.nres-1) then
8524         itk1=itortyp(itype(k+1))
8525       else
8526         itk1=ntortyp+1
8527       endif
8528       itl=itortyp(itype(l))
8529       if (l.lt.nres-1) then
8530         itl1=itortyp(itype(l+1))
8531       else
8532         itl1=ntortyp+1
8533       endif
8534 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8535 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8536 cd     & ' itl',itl,' itl1',itl1
8537 #ifdef MOMENT
8538       if (imat.eq.1) then
8539         s1=dip(3,jj,i)*dip(3,kk,k)
8540       else
8541         s1=dip(2,jj,j)*dip(2,kk,l)
8542       endif
8543 #endif
8544       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8545       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8546       if (j.eq.l+1) then
8547         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8548         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8549       else
8550         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8551         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8552       endif
8553       call transpose2(EUg(1,1,k),auxmat(1,1))
8554       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8555       vv(1)=pizda(1,1)-pizda(2,2)
8556       vv(2)=pizda(2,1)+pizda(1,2)
8557       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8558 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8559 #ifdef MOMENT
8560       eello6_graph4=-(s1+s2+s3+s4)
8561 #else
8562       eello6_graph4=-(s2+s3+s4)
8563 #endif
8564 C Derivatives in gamma(i-1)
8565       if (i.gt.1) then
8566 #ifdef MOMENT
8567         if (imat.eq.1) then
8568           s1=dipderg(2,jj,i)*dip(3,kk,k)
8569         else
8570           s1=dipderg(4,jj,j)*dip(2,kk,l)
8571         endif
8572 #endif
8573         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8574         if (j.eq.l+1) then
8575           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8576           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8577         else
8578           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8579           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8580         endif
8581         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8582         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8583 cd          write (2,*) 'turn6 derivatives'
8584 #ifdef MOMENT
8585           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8586 #else
8587           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8588 #endif
8589         else
8590 #ifdef MOMENT
8591           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8592 #else
8593           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8594 #endif
8595         endif
8596       endif
8597 C Derivatives in gamma(k-1)
8598 #ifdef MOMENT
8599       if (imat.eq.1) then
8600         s1=dip(3,jj,i)*dipderg(2,kk,k)
8601       else
8602         s1=dip(2,jj,j)*dipderg(4,kk,l)
8603       endif
8604 #endif
8605       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8606       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8607       if (j.eq.l+1) then
8608         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8609         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8610       else
8611         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8612         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8613       endif
8614       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8615       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8616       vv(1)=pizda(1,1)-pizda(2,2)
8617       vv(2)=pizda(2,1)+pizda(1,2)
8618       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8619       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8620 #ifdef MOMENT
8621         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8622 #else
8623         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8624 #endif
8625       else
8626 #ifdef MOMENT
8627         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8628 #else
8629         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8630 #endif
8631       endif
8632 C Derivatives in gamma(j-1) or gamma(l-1)
8633       if (l.eq.j+1 .and. l.gt.1) then
8634         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8635         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8636         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8637         vv(1)=pizda(1,1)-pizda(2,2)
8638         vv(2)=pizda(2,1)+pizda(1,2)
8639         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8640         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8641       else if (j.gt.1) then
8642         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8643         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8644         call matmat2(AECAderg(1,1,imat),auxmat(1,1),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 (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8649           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8650         else
8651           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8652         endif
8653       endif
8654 C Cartesian derivatives.
8655       do iii=1,2
8656         do kkk=1,5
8657           do lll=1,3
8658 #ifdef MOMENT
8659             if (iii.eq.1) then
8660               if (imat.eq.1) then
8661                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8662               else
8663                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8664               endif
8665             else
8666               if (imat.eq.1) then
8667                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8668               else
8669                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8670               endif
8671             endif
8672 #endif
8673             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8674      &        auxvec(1))
8675             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8676             if (j.eq.l+1) then
8677               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8678      &          b1(1,itj1),auxvec(1))
8679               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8680             else
8681               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8682      &          b1(1,itl1),auxvec(1))
8683               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8684             endif
8685             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8686      &        pizda(1,1))
8687             vv(1)=pizda(1,1)-pizda(2,2)
8688             vv(2)=pizda(2,1)+pizda(1,2)
8689             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8690             if (swap) then
8691               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8692 #ifdef MOMENT
8693                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8694      &             -(s1+s2+s4)
8695 #else
8696                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8697      &             -(s2+s4)
8698 #endif
8699                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8700               else
8701 #ifdef MOMENT
8702                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8703 #else
8704                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8705 #endif
8706                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8707               endif
8708             else
8709 #ifdef MOMENT
8710               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8711 #else
8712               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8713 #endif
8714               if (l.eq.j+1) then
8715                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8716               else
8717                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8718               endif
8719             endif
8720           enddo
8721         enddo
8722       enddo
8723       return
8724       end
8725 c----------------------------------------------------------------------------
8726       double precision function eello_turn6(i,jj,kk)
8727       implicit real*8 (a-h,o-z)
8728       include 'DIMENSIONS'
8729       include 'COMMON.IOUNITS'
8730       include 'COMMON.CHAIN'
8731       include 'COMMON.DERIV'
8732       include 'COMMON.INTERACT'
8733       include 'COMMON.CONTACTS'
8734       include 'COMMON.TORSION'
8735       include 'COMMON.VAR'
8736       include 'COMMON.GEO'
8737       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8738      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8739      &  ggg1(3),ggg2(3)
8740       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8741      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8742 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8743 C           the respective energy moment and not to the cluster cumulant.
8744       s1=0.0d0
8745       s8=0.0d0
8746       s13=0.0d0
8747 c
8748       eello_turn6=0.0d0
8749       j=i+4
8750       k=i+1
8751       l=i+3
8752       iti=itortyp(itype(i))
8753       itk=itortyp(itype(k))
8754       itk1=itortyp(itype(k+1))
8755       itl=itortyp(itype(l))
8756       itj=itortyp(itype(j))
8757 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8758 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8759 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8760 cd        eello6=0.0d0
8761 cd        return
8762 cd      endif
8763 cd      write (iout,*)
8764 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8765 cd     &   ' and',k,l
8766 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8767       do iii=1,2
8768         do kkk=1,5
8769           do lll=1,3
8770             derx_turn(lll,kkk,iii)=0.0d0
8771           enddo
8772         enddo
8773       enddo
8774 cd      eij=1.0d0
8775 cd      ekl=1.0d0
8776 cd      ekont=1.0d0
8777       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8778 cd      eello6_5=0.0d0
8779 cd      write (2,*) 'eello6_5',eello6_5
8780 #ifdef MOMENT
8781       call transpose2(AEA(1,1,1),auxmat(1,1))
8782       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8783       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8784       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8785 #endif
8786       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8787       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8788       s2 = scalar2(b1(1,itk),vtemp1(1))
8789 #ifdef MOMENT
8790       call transpose2(AEA(1,1,2),atemp(1,1))
8791       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8792       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8793       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8794 #endif
8795       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8796       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8797       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8798 #ifdef MOMENT
8799       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8800       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8801       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8802       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8803       ss13 = scalar2(b1(1,itk),vtemp4(1))
8804       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8805 #endif
8806 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8807 c      s1=0.0d0
8808 c      s2=0.0d0
8809 c      s8=0.0d0
8810 c      s12=0.0d0
8811 c      s13=0.0d0
8812       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8813 C Derivatives in gamma(i+2)
8814       s1d =0.0d0
8815       s8d =0.0d0
8816 #ifdef MOMENT
8817       call transpose2(AEA(1,1,1),auxmatd(1,1))
8818       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8819       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8820       call transpose2(AEAderg(1,1,2),atempd(1,1))
8821       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8822       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8823 #endif
8824       call matmat2(EUg(1,1,i+3),AEAderg(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 c      s1d=0.0d0
8828 c      s2d=0.0d0
8829 c      s8d=0.0d0
8830 c      s12d=0.0d0
8831 c      s13d=0.0d0
8832       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8833 C Derivatives in gamma(i+3)
8834 #ifdef MOMENT
8835       call transpose2(AEA(1,1,1),auxmatd(1,1))
8836       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8837       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8838       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8839 #endif
8840       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8841       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8842       s2d = scalar2(b1(1,itk),vtemp1d(1))
8843 #ifdef MOMENT
8844       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8845       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8846 #endif
8847       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8848 #ifdef MOMENT
8849       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8850       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8851       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8852 #endif
8853 c      s1d=0.0d0
8854 c      s2d=0.0d0
8855 c      s8d=0.0d0
8856 c      s12d=0.0d0
8857 c      s13d=0.0d0
8858 #ifdef MOMENT
8859       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8860      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8861 #else
8862       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8863      &               -0.5d0*ekont*(s2d+s12d)
8864 #endif
8865 C Derivatives in gamma(i+4)
8866       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8867       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8868       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8869 #ifdef MOMENT
8870       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8871       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8872       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8873 #endif
8874 c      s1d=0.0d0
8875 c      s2d=0.0d0
8876 c      s8d=0.0d0
8877 C      s12d=0.0d0
8878 c      s13d=0.0d0
8879 #ifdef MOMENT
8880       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8881 #else
8882       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8883 #endif
8884 C Derivatives in gamma(i+5)
8885 #ifdef MOMENT
8886       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8887       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8888       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8889 #endif
8890       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8891       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8892       s2d = scalar2(b1(1,itk),vtemp1d(1))
8893 #ifdef MOMENT
8894       call transpose2(AEA(1,1,2),atempd(1,1))
8895       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8896       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8897 #endif
8898       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8899       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8900 #ifdef MOMENT
8901       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8902       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8903       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8904 #endif
8905 c      s1d=0.0d0
8906 c      s2d=0.0d0
8907 c      s8d=0.0d0
8908 c      s12d=0.0d0
8909 c      s13d=0.0d0
8910 #ifdef MOMENT
8911       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8912      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8913 #else
8914       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8915      &               -0.5d0*ekont*(s2d+s12d)
8916 #endif
8917 C Cartesian derivatives
8918       do iii=1,2
8919         do kkk=1,5
8920           do lll=1,3
8921 #ifdef MOMENT
8922             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8923             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8924             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8925 #endif
8926             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8927             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8928      &          vtemp1d(1))
8929             s2d = scalar2(b1(1,itk),vtemp1d(1))
8930 #ifdef MOMENT
8931             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8932             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8933             s8d = -(atempd(1,1)+atempd(2,2))*
8934      &           scalar2(cc(1,1,itl),vtemp2(1))
8935 #endif
8936             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8937      &           auxmatd(1,1))
8938             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8939             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8940 c      s1d=0.0d0
8941 c      s2d=0.0d0
8942 c      s8d=0.0d0
8943 c      s12d=0.0d0
8944 c      s13d=0.0d0
8945 #ifdef MOMENT
8946             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8947      &        - 0.5d0*(s1d+s2d)
8948 #else
8949             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8950      &        - 0.5d0*s2d
8951 #endif
8952 #ifdef MOMENT
8953             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8954      &        - 0.5d0*(s8d+s12d)
8955 #else
8956             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8957      &        - 0.5d0*s12d
8958 #endif
8959           enddo
8960         enddo
8961       enddo
8962 #ifdef MOMENT
8963       do kkk=1,5
8964         do lll=1,3
8965           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8966      &      achuj_tempd(1,1))
8967           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8968           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8969           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8970           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8971           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8972      &      vtemp4d(1))
8973           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8974           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8975           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8976         enddo
8977       enddo
8978 #endif
8979 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8980 cd     &  16*eel_turn6_num
8981 cd      goto 1112
8982       if (j.lt.nres-1) then
8983         j1=j+1
8984         j2=j-1
8985       else
8986         j1=j-1
8987         j2=j-2
8988       endif
8989       if (l.lt.nres-1) then
8990         l1=l+1
8991         l2=l-1
8992       else
8993         l1=l-1
8994         l2=l-2
8995       endif
8996       do ll=1,3
8997 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
8998 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
8999 cgrad        ghalf=0.5d0*ggg1(ll)
9000 cd        ghalf=0.0d0
9001         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9002         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9003         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9004      &    +ekont*derx_turn(ll,2,1)
9005         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9006         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9007      &    +ekont*derx_turn(ll,4,1)
9008         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9009         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9010         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9011 cgrad        ghalf=0.5d0*ggg2(ll)
9012 cd        ghalf=0.0d0
9013         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9014      &    +ekont*derx_turn(ll,2,2)
9015         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9016         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9017      &    +ekont*derx_turn(ll,4,2)
9018         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9019         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9020         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9021       enddo
9022 cd      goto 1112
9023 cgrad      do m=i+1,j-1
9024 cgrad        do ll=1,3
9025 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9026 cgrad        enddo
9027 cgrad      enddo
9028 cgrad      do m=k+1,l-1
9029 cgrad        do ll=1,3
9030 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9031 cgrad        enddo
9032 cgrad      enddo
9033 cgrad1112  continue
9034 cgrad      do m=i+2,j2
9035 cgrad        do ll=1,3
9036 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9037 cgrad        enddo
9038 cgrad      enddo
9039 cgrad      do m=k+2,l2
9040 cgrad        do ll=1,3
9041 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9042 cgrad        enddo
9043 cgrad      enddo
9044 cd      do iii=1,nres-3
9045 cd        write (2,*) iii,g_corr6_loc(iii)
9046 cd      enddo
9047       eello_turn6=ekont*eel_turn6
9048 cd      write (2,*) 'ekont',ekont
9049 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9050       return
9051       end
9052
9053 C-----------------------------------------------------------------------------
9054       double precision function scalar(u,v)
9055 !DIR$ INLINEALWAYS scalar
9056 #ifndef OSF
9057 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9058 #endif
9059       implicit none
9060       double precision u(3),v(3)
9061 cd      double precision sc
9062 cd      integer i
9063 cd      sc=0.0d0
9064 cd      do i=1,3
9065 cd        sc=sc+u(i)*v(i)
9066 cd      enddo
9067 cd      scalar=sc
9068
9069       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9070       return
9071       end
9072 crc-------------------------------------------------
9073       SUBROUTINE MATVEC2(A1,V1,V2)
9074 !DIR$ INLINEALWAYS MATVEC2
9075 #ifndef OSF
9076 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9077 #endif
9078       implicit real*8 (a-h,o-z)
9079       include 'DIMENSIONS'
9080       DIMENSION A1(2,2),V1(2),V2(2)
9081 c      DO 1 I=1,2
9082 c        VI=0.0
9083 c        DO 3 K=1,2
9084 c    3     VI=VI+A1(I,K)*V1(K)
9085 c        Vaux(I)=VI
9086 c    1 CONTINUE
9087
9088       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9089       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9090
9091       v2(1)=vaux1
9092       v2(2)=vaux2
9093       END
9094 C---------------------------------------
9095       SUBROUTINE MATMAT2(A1,A2,A3)
9096 #ifndef OSF
9097 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9098 #endif
9099       implicit real*8 (a-h,o-z)
9100       include 'DIMENSIONS'
9101       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9102 c      DIMENSION AI3(2,2)
9103 c        DO  J=1,2
9104 c          A3IJ=0.0
9105 c          DO K=1,2
9106 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9107 c          enddo
9108 c          A3(I,J)=A3IJ
9109 c       enddo
9110 c      enddo
9111
9112       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9113       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9114       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9115       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9116
9117       A3(1,1)=AI3_11
9118       A3(2,1)=AI3_21
9119       A3(1,2)=AI3_12
9120       A3(2,2)=AI3_22
9121       END
9122
9123 c-------------------------------------------------------------------------
9124       double precision function scalar2(u,v)
9125 !DIR$ INLINEALWAYS scalar2
9126       implicit none
9127       double precision u(2),v(2)
9128       double precision sc
9129       integer i
9130       scalar2=u(1)*v(1)+u(2)*v(2)
9131       return
9132       end
9133
9134 C-----------------------------------------------------------------------------
9135
9136       subroutine transpose2(a,at)
9137 !DIR$ INLINEALWAYS transpose2
9138 #ifndef OSF
9139 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9140 #endif
9141       implicit none
9142       double precision a(2,2),at(2,2)
9143       at(1,1)=a(1,1)
9144       at(1,2)=a(2,1)
9145       at(2,1)=a(1,2)
9146       at(2,2)=a(2,2)
9147       return
9148       end
9149 c--------------------------------------------------------------------------
9150       subroutine transpose(n,a,at)
9151       implicit none
9152       integer n,i,j
9153       double precision a(n,n),at(n,n)
9154       do i=1,n
9155         do j=1,n
9156           at(j,i)=a(i,j)
9157         enddo
9158       enddo
9159       return
9160       end
9161 C---------------------------------------------------------------------------
9162       subroutine prodmat3(a1,a2,kk,transp,prod)
9163 !DIR$ INLINEALWAYS prodmat3
9164 #ifndef OSF
9165 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9166 #endif
9167       implicit none
9168       integer i,j
9169       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9170       logical transp
9171 crc      double precision auxmat(2,2),prod_(2,2)
9172
9173       if (transp) then
9174 crc        call transpose2(kk(1,1),auxmat(1,1))
9175 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9176 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9177
9178            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9179      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9180            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9181      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9182            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9183      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9184            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9185      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9186
9187       else
9188 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9189 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9190
9191            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9192      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9193            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9194      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9195            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9196      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9197            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9198      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9199
9200       endif
9201 c      call transpose2(a2(1,1),a2t(1,1))
9202
9203 crc      print *,transp
9204 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9205 crc      print *,((prod(i,j),i=1,2),j=1,2)
9206
9207       return
9208       end
9209