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=itype(i)
1141         itypi1=itype(i+1)
1142         xi=c(1,nres+i)
1143         yi=c(2,nres+i)
1144         zi=c(3,nres+i)
1145 C Change 12/1/95
1146         num_conti=0
1147 C
1148 C Calculate SC interaction energy.
1149 C
1150         do iint=1,nint_gr(i)
1151 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1152 cd   &                  'iend=',iend(i,iint)
1153           do j=istart(i,iint),iend(i,iint)
1154             itypj=itype(j)
1155             xj=c(1,nres+j)-xi
1156             yj=c(2,nres+j)-yi
1157             zj=c(3,nres+j)-zi
1158 C Change 12/1/95 to calculate four-body interactions
1159             rij=xj*xj+yj*yj+zj*zj
1160             rrij=1.0D0/rij
1161 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1162             eps0ij=eps(itypi,itypj)
1163             fac=rrij**expon2
1164             e1=fac*fac*aa(itypi,itypj)
1165             e2=fac*bb(itypi,itypj)
1166             evdwij=e1+e2
1167 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1168 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1169 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1170 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1171 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1172 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1173 #ifdef TSCSC
1174             if (bb(itypi,itypj).gt.0) then
1175                evdw_p=evdw_p+evdwij
1176             else
1177                evdw_m=evdw_m+evdwij
1178             endif
1179 #else
1180             evdw=evdw+evdwij
1181 #endif
1182 C
1183 C Calculate the components of the gradient in DC and X
1184 C
1185             fac=-rrij*(e1+evdwij)
1186             gg(1)=xj*fac
1187             gg(2)=yj*fac
1188             gg(3)=zj*fac
1189 #ifdef TSCSC
1190             if (bb(itypi,itypj).gt.0.0d0) then
1191               do k=1,3
1192                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1193                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1194                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1195                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1196               enddo
1197             else
1198               do k=1,3
1199                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1200                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1201                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1202                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1203               enddo
1204             endif
1205 #else
1206             do k=1,3
1207               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1208               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1209               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1210               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1211             enddo
1212 #endif
1213 cgrad            do k=i,j-1
1214 cgrad              do l=1,3
1215 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1216 cgrad              enddo
1217 cgrad            enddo
1218 C
1219 C 12/1/95, revised on 5/20/97
1220 C
1221 C Calculate the contact function. The ith column of the array JCONT will
1222 C contain the numbers of atoms that make contacts with the atom I (of numbers
1223 C greater than I). The arrays FACONT and GACONT will contain the values of
1224 C the contact function and its derivative.
1225 C
1226 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1227 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1228 C Uncomment next line, if the correlation interactions are contact function only
1229             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1230               rij=dsqrt(rij)
1231               sigij=sigma(itypi,itypj)
1232               r0ij=rs0(itypi,itypj)
1233 C
1234 C Check whether the SC's are not too far to make a contact.
1235 C
1236               rcut=1.5d0*r0ij
1237               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1238 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1239 C
1240               if (fcont.gt.0.0D0) then
1241 C If the SC-SC distance if close to sigma, apply spline.
1242 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1243 cAdam &             fcont1,fprimcont1)
1244 cAdam           fcont1=1.0d0-fcont1
1245 cAdam           if (fcont1.gt.0.0d0) then
1246 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1247 cAdam             fcont=fcont*fcont1
1248 cAdam           endif
1249 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1250 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1251 cga             do k=1,3
1252 cga               gg(k)=gg(k)*eps0ij
1253 cga             enddo
1254 cga             eps0ij=-evdwij*eps0ij
1255 C Uncomment for AL's type of SC correlation interactions.
1256 cadam           eps0ij=-evdwij
1257                 num_conti=num_conti+1
1258                 jcont(num_conti,i)=j
1259                 facont(num_conti,i)=fcont*eps0ij
1260                 fprimcont=eps0ij*fprimcont/rij
1261                 fcont=expon*fcont
1262 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1263 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1264 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1265 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1266                 gacont(1,num_conti,i)=-fprimcont*xj
1267                 gacont(2,num_conti,i)=-fprimcont*yj
1268                 gacont(3,num_conti,i)=-fprimcont*zj
1269 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1270 cd              write (iout,'(2i3,3f10.5)')
1271 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1272               endif
1273             endif
1274           enddo      ! j
1275         enddo        ! iint
1276 C Change 12/1/95
1277         num_cont(i)=num_conti
1278       enddo          ! i
1279       do i=1,nct
1280         do j=1,3
1281           gvdwc(j,i)=expon*gvdwc(j,i)
1282           gvdwx(j,i)=expon*gvdwx(j,i)
1283         enddo
1284       enddo
1285 C******************************************************************************
1286 C
1287 C                              N O T E !!!
1288 C
1289 C To save time, the factor of EXPON has been extracted from ALL components
1290 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1291 C use!
1292 C
1293 C******************************************************************************
1294       return
1295       end
1296 C-----------------------------------------------------------------------------
1297       subroutine eljk(evdw,evdw_p,evdw_m)
1298 C
1299 C This subroutine calculates the interaction energy of nonbonded side chains
1300 C assuming the LJK potential of interaction.
1301 C
1302       implicit real*8 (a-h,o-z)
1303       include 'DIMENSIONS'
1304       include 'COMMON.GEO'
1305       include 'COMMON.VAR'
1306       include 'COMMON.LOCAL'
1307       include 'COMMON.CHAIN'
1308       include 'COMMON.DERIV'
1309       include 'COMMON.INTERACT'
1310       include 'COMMON.IOUNITS'
1311       include 'COMMON.NAMES'
1312       dimension gg(3)
1313       logical scheck
1314 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1315       evdw=0.0D0
1316       do i=iatsc_s,iatsc_e
1317         itypi=itype(i)
1318         itypi1=itype(i+1)
1319         xi=c(1,nres+i)
1320         yi=c(2,nres+i)
1321         zi=c(3,nres+i)
1322 C
1323 C Calculate SC interaction energy.
1324 C
1325         do iint=1,nint_gr(i)
1326           do j=istart(i,iint),iend(i,iint)
1327             itypj=itype(j)
1328             xj=c(1,nres+j)-xi
1329             yj=c(2,nres+j)-yi
1330             zj=c(3,nres+j)-zi
1331             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1332             fac_augm=rrij**expon
1333             e_augm=augm(itypi,itypj)*fac_augm
1334             r_inv_ij=dsqrt(rrij)
1335             rij=1.0D0/r_inv_ij
1336             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1337             fac=r_shift_inv**expon
1338             e1=fac*fac*aa(itypi,itypj)
1339             e2=fac*bb(itypi,itypj)
1340             evdwij=e_augm+e1+e2
1341 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1342 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1343 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1344 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1345 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1346 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1347 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1348 #ifdef TSCSC
1349             if (bb(itypi,itypj).gt.0) then
1350                evdw_p=evdw_p+evdwij
1351             else
1352                evdw_m=evdw_m+evdwij
1353             endif
1354 #else
1355             evdw=evdw+evdwij
1356 #endif
1357 C
1358 C Calculate the components of the gradient in DC and X
1359 C
1360             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1361             gg(1)=xj*fac
1362             gg(2)=yj*fac
1363             gg(3)=zj*fac
1364 #ifdef TSCSC
1365             if (bb(itypi,itypj).gt.0.0d0) then
1366               do k=1,3
1367                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1368                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1369                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1370                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1371               enddo
1372             else
1373               do k=1,3
1374                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1375                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1376                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1377                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1378               enddo
1379             endif
1380 #else
1381             do k=1,3
1382               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1383               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1384               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1385               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1386             enddo
1387 #endif
1388 cgrad            do k=i,j-1
1389 cgrad              do l=1,3
1390 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1391 cgrad              enddo
1392 cgrad            enddo
1393           enddo      ! j
1394         enddo        ! iint
1395       enddo          ! i
1396       do i=1,nct
1397         do j=1,3
1398           gvdwc(j,i)=expon*gvdwc(j,i)
1399           gvdwx(j,i)=expon*gvdwx(j,i)
1400         enddo
1401       enddo
1402       return
1403       end
1404 C-----------------------------------------------------------------------------
1405       subroutine ebp(evdw,evdw_p,evdw_m)
1406 C
1407 C This subroutine calculates the interaction energy of nonbonded side chains
1408 C assuming the Berne-Pechukas potential of interaction.
1409 C
1410       implicit real*8 (a-h,o-z)
1411       include 'DIMENSIONS'
1412       include 'COMMON.GEO'
1413       include 'COMMON.VAR'
1414       include 'COMMON.LOCAL'
1415       include 'COMMON.CHAIN'
1416       include 'COMMON.DERIV'
1417       include 'COMMON.NAMES'
1418       include 'COMMON.INTERACT'
1419       include 'COMMON.IOUNITS'
1420       include 'COMMON.CALC'
1421       common /srutu/ icall
1422 c     double precision rrsave(maxdim)
1423       logical lprn
1424       evdw=0.0D0
1425 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1426       evdw=0.0D0
1427 c     if (icall.eq.0) then
1428 c       lprn=.true.
1429 c     else
1430         lprn=.false.
1431 c     endif
1432       ind=0
1433       do i=iatsc_s,iatsc_e
1434         itypi=itype(i)
1435         itypi1=itype(i+1)
1436         xi=c(1,nres+i)
1437         yi=c(2,nres+i)
1438         zi=c(3,nres+i)
1439         dxi=dc_norm(1,nres+i)
1440         dyi=dc_norm(2,nres+i)
1441         dzi=dc_norm(3,nres+i)
1442 c        dsci_inv=dsc_inv(itypi)
1443         dsci_inv=vbld_inv(i+nres)
1444 C
1445 C Calculate SC interaction energy.
1446 C
1447         do iint=1,nint_gr(i)
1448           do j=istart(i,iint),iend(i,iint)
1449             ind=ind+1
1450             itypj=itype(j)
1451 c            dscj_inv=dsc_inv(itypj)
1452             dscj_inv=vbld_inv(j+nres)
1453             chi1=chi(itypi,itypj)
1454             chi2=chi(itypj,itypi)
1455             chi12=chi1*chi2
1456             chip1=chip(itypi)
1457             chip2=chip(itypj)
1458             chip12=chip1*chip2
1459             alf1=alp(itypi)
1460             alf2=alp(itypj)
1461             alf12=0.5D0*(alf1+alf2)
1462 C For diagnostics only!!!
1463 c           chi1=0.0D0
1464 c           chi2=0.0D0
1465 c           chi12=0.0D0
1466 c           chip1=0.0D0
1467 c           chip2=0.0D0
1468 c           chip12=0.0D0
1469 c           alf1=0.0D0
1470 c           alf2=0.0D0
1471 c           alf12=0.0D0
1472             xj=c(1,nres+j)-xi
1473             yj=c(2,nres+j)-yi
1474             zj=c(3,nres+j)-zi
1475             dxj=dc_norm(1,nres+j)
1476             dyj=dc_norm(2,nres+j)
1477             dzj=dc_norm(3,nres+j)
1478             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1479 cd          if (icall.eq.0) then
1480 cd            rrsave(ind)=rrij
1481 cd          else
1482 cd            rrij=rrsave(ind)
1483 cd          endif
1484             rij=dsqrt(rrij)
1485 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1486             call sc_angular
1487 C Calculate whole angle-dependent part of epsilon and contributions
1488 C to its derivatives
1489             fac=(rrij*sigsq)**expon2
1490             e1=fac*fac*aa(itypi,itypj)
1491             e2=fac*bb(itypi,itypj)
1492             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1493             eps2der=evdwij*eps3rt
1494             eps3der=evdwij*eps2rt
1495             evdwij=evdwij*eps2rt*eps3rt
1496 #ifdef TSCSC
1497             if (bb(itypi,itypj).gt.0) then
1498                evdw_p=evdw_p+evdwij
1499             else
1500                evdw_m=evdw_m+evdwij
1501             endif
1502 #else
1503             evdw=evdw+evdwij
1504 #endif
1505             if (lprn) then
1506             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1507             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1508 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1509 cd     &        restyp(itypi),i,restyp(itypj),j,
1510 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1511 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1512 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1513 cd     &        evdwij
1514             endif
1515 C Calculate gradient components.
1516             e1=e1*eps1*eps2rt**2*eps3rt**2
1517             fac=-expon*(e1+evdwij)
1518             sigder=fac/sigsq
1519             fac=rrij*fac
1520 C Calculate radial part of the gradient
1521             gg(1)=xj*fac
1522             gg(2)=yj*fac
1523             gg(3)=zj*fac
1524 C Calculate the angular part of the gradient and sum add the contributions
1525 C to the appropriate components of the Cartesian gradient.
1526 #ifdef TSCSC
1527             if (bb(itypi,itypj).gt.0) then
1528                call sc_grad
1529             else
1530                call sc_grad_T
1531             endif
1532 #else
1533             call sc_grad
1534 #endif
1535           enddo      ! j
1536         enddo        ! iint
1537       enddo          ! i
1538 c     stop
1539       return
1540       end
1541 C-----------------------------------------------------------------------------
1542       subroutine egb(evdw,evdw_p,evdw_m)
1543 C
1544 C This subroutine calculates the interaction energy of nonbonded side chains
1545 C assuming the Gay-Berne potential of interaction.
1546 C
1547       implicit real*8 (a-h,o-z)
1548       include 'DIMENSIONS'
1549       include 'COMMON.GEO'
1550       include 'COMMON.VAR'
1551       include 'COMMON.LOCAL'
1552       include 'COMMON.CHAIN'
1553       include 'COMMON.DERIV'
1554       include 'COMMON.NAMES'
1555       include 'COMMON.INTERACT'
1556       include 'COMMON.IOUNITS'
1557       include 'COMMON.CALC'
1558       include 'COMMON.CONTROL'
1559       logical lprn
1560       evdw=0.0D0
1561 ccccc      energy_dec=.false.
1562 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1563       evdw=0.0D0
1564       evdw_p=0.0D0
1565       evdw_m=0.0D0
1566       lprn=.false.
1567 c     if (icall.eq.0) lprn=.false.
1568       ind=0
1569       do i=iatsc_s,iatsc_e
1570         itypi=itype(i)
1571         itypi1=itype(i+1)
1572         xi=c(1,nres+i)
1573         yi=c(2,nres+i)
1574         zi=c(3,nres+i)
1575         dxi=dc_norm(1,nres+i)
1576         dyi=dc_norm(2,nres+i)
1577         dzi=dc_norm(3,nres+i)
1578 c        dsci_inv=dsc_inv(itypi)
1579         dsci_inv=vbld_inv(i+nres)
1580 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1581 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1582 C
1583 C Calculate SC interaction energy.
1584 C
1585         do iint=1,nint_gr(i)
1586           do j=istart(i,iint),iend(i,iint)
1587             ind=ind+1
1588             itypj=itype(j)
1589 c            dscj_inv=dsc_inv(itypj)
1590             dscj_inv=vbld_inv(j+nres)
1591 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1592 c     &       1.0d0/vbld(j+nres)
1593 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1594             sig0ij=sigma(itypi,itypj)
1595             chi1=chi(itypi,itypj)
1596             chi2=chi(itypj,itypi)
1597             chi12=chi1*chi2
1598             chip1=chip(itypi)
1599             chip2=chip(itypj)
1600             chip12=chip1*chip2
1601             alf1=alp(itypi)
1602             alf2=alp(itypj)
1603             alf12=0.5D0*(alf1+alf2)
1604 C For diagnostics only!!!
1605 c           chi1=0.0D0
1606 c           chi2=0.0D0
1607 c           chi12=0.0D0
1608 c           chip1=0.0D0
1609 c           chip2=0.0D0
1610 c           chip12=0.0D0
1611 c           alf1=0.0D0
1612 c           alf2=0.0D0
1613 c           alf12=0.0D0
1614             xj=c(1,nres+j)-xi
1615             yj=c(2,nres+j)-yi
1616             zj=c(3,nres+j)-zi
1617             dxj=dc_norm(1,nres+j)
1618             dyj=dc_norm(2,nres+j)
1619             dzj=dc_norm(3,nres+j)
1620 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1621 c            write (iout,*) "j",j," dc_norm",
1622 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1623             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1624             rij=dsqrt(rrij)
1625 C Calculate angle-dependent terms of energy and contributions to their
1626 C derivatives.
1627             call sc_angular
1628             sigsq=1.0D0/sigsq
1629             sig=sig0ij*dsqrt(sigsq)
1630             rij_shift=1.0D0/rij-sig+sig0ij
1631 c for diagnostics; uncomment
1632 c            rij_shift=1.2*sig0ij
1633 C I hate to put IF's in the loops, but here don't have another choice!!!!
1634             if (rij_shift.le.0.0D0) then
1635               evdw=1.0D20
1636 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1637 cd     &        restyp(itypi),i,restyp(itypj),j,
1638 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1639               return
1640             endif
1641             sigder=-sig*sigsq
1642 c---------------------------------------------------------------
1643             rij_shift=1.0D0/rij_shift
1644             fac=rij_shift**expon
1645             e1=fac*fac*aa(itypi,itypj)
1646             e2=fac*bb(itypi,itypj)
1647             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1648             eps2der=evdwij*eps3rt
1649             eps3der=evdwij*eps2rt
1650 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1651 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1652             evdwij=evdwij*eps2rt*eps3rt
1653 #ifdef TSCSC
1654             if (bb(itypi,itypj).gt.0) then
1655                evdw_p=evdw_p+evdwij
1656             else
1657                evdw_m=evdw_m+evdwij
1658             endif
1659 #else
1660             evdw=evdw+evdwij
1661 #endif
1662             if (lprn) then
1663             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1664             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1665             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1666      &        restyp(itypi),i,restyp(itypj),j,
1667      &        epsi,sigm,chi1,chi2,chip1,chip2,
1668      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1669      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1670      &        evdwij
1671             endif
1672
1673             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1674      &                        'evdw',i,j,evdwij
1675
1676 C Calculate gradient components.
1677             e1=e1*eps1*eps2rt**2*eps3rt**2
1678             fac=-expon*(e1+evdwij)*rij_shift
1679             sigder=fac*sigder
1680             fac=rij*fac
1681 c            fac=0.0d0
1682 C Calculate the radial part of the gradient
1683             gg(1)=xj*fac
1684             gg(2)=yj*fac
1685             gg(3)=zj*fac
1686 C Calculate angular part of the gradient.
1687 #ifdef TSCSC
1688             if (bb(itypi,itypj).gt.0) then
1689                call sc_grad
1690             else
1691                call sc_grad_T
1692             endif
1693 #else
1694             call sc_grad
1695 #endif
1696           enddo      ! j
1697         enddo        ! iint
1698       enddo          ! i
1699 c      write (iout,*) "Number of loop steps in EGB:",ind
1700 cccc      energy_dec=.false.
1701       return
1702       end
1703 C-----------------------------------------------------------------------------
1704       subroutine egbv(evdw,evdw_p,evdw_m)
1705 C
1706 C This subroutine calculates the interaction energy of nonbonded side chains
1707 C assuming the Gay-Berne-Vorobjev potential of interaction.
1708 C
1709       implicit real*8 (a-h,o-z)
1710       include 'DIMENSIONS'
1711       include 'COMMON.GEO'
1712       include 'COMMON.VAR'
1713       include 'COMMON.LOCAL'
1714       include 'COMMON.CHAIN'
1715       include 'COMMON.DERIV'
1716       include 'COMMON.NAMES'
1717       include 'COMMON.INTERACT'
1718       include 'COMMON.IOUNITS'
1719       include 'COMMON.CALC'
1720       common /srutu/ icall
1721       logical lprn
1722       evdw=0.0D0
1723 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1724       evdw=0.0D0
1725       lprn=.false.
1726 c     if (icall.eq.0) lprn=.true.
1727       ind=0
1728       do i=iatsc_s,iatsc_e
1729         itypi=itype(i)
1730         itypi1=itype(i+1)
1731         xi=c(1,nres+i)
1732         yi=c(2,nres+i)
1733         zi=c(3,nres+i)
1734         dxi=dc_norm(1,nres+i)
1735         dyi=dc_norm(2,nres+i)
1736         dzi=dc_norm(3,nres+i)
1737 c        dsci_inv=dsc_inv(itypi)
1738         dsci_inv=vbld_inv(i+nres)
1739 C
1740 C Calculate SC interaction energy.
1741 C
1742         do iint=1,nint_gr(i)
1743           do j=istart(i,iint),iend(i,iint)
1744             ind=ind+1
1745             itypj=itype(j)
1746 c            dscj_inv=dsc_inv(itypj)
1747             dscj_inv=vbld_inv(j+nres)
1748             sig0ij=sigma(itypi,itypj)
1749             r0ij=r0(itypi,itypj)
1750             chi1=chi(itypi,itypj)
1751             chi2=chi(itypj,itypi)
1752             chi12=chi1*chi2
1753             chip1=chip(itypi)
1754             chip2=chip(itypj)
1755             chip12=chip1*chip2
1756             alf1=alp(itypi)
1757             alf2=alp(itypj)
1758             alf12=0.5D0*(alf1+alf2)
1759 C For diagnostics only!!!
1760 c           chi1=0.0D0
1761 c           chi2=0.0D0
1762 c           chi12=0.0D0
1763 c           chip1=0.0D0
1764 c           chip2=0.0D0
1765 c           chip12=0.0D0
1766 c           alf1=0.0D0
1767 c           alf2=0.0D0
1768 c           alf12=0.0D0
1769             xj=c(1,nres+j)-xi
1770             yj=c(2,nres+j)-yi
1771             zj=c(3,nres+j)-zi
1772             dxj=dc_norm(1,nres+j)
1773             dyj=dc_norm(2,nres+j)
1774             dzj=dc_norm(3,nres+j)
1775             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1776             rij=dsqrt(rrij)
1777 C Calculate angle-dependent terms of energy and contributions to their
1778 C derivatives.
1779             call sc_angular
1780             sigsq=1.0D0/sigsq
1781             sig=sig0ij*dsqrt(sigsq)
1782             rij_shift=1.0D0/rij-sig+r0ij
1783 C I hate to put IF's in the loops, but here don't have another choice!!!!
1784             if (rij_shift.le.0.0D0) then
1785               evdw=1.0D20
1786               return
1787             endif
1788             sigder=-sig*sigsq
1789 c---------------------------------------------------------------
1790             rij_shift=1.0D0/rij_shift
1791             fac=rij_shift**expon
1792             e1=fac*fac*aa(itypi,itypj)
1793             e2=fac*bb(itypi,itypj)
1794             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1795             eps2der=evdwij*eps3rt
1796             eps3der=evdwij*eps2rt
1797             fac_augm=rrij**expon
1798             e_augm=augm(itypi,itypj)*fac_augm
1799             evdwij=evdwij*eps2rt*eps3rt
1800 #ifdef TSCSC
1801             if (bb(itypi,itypj).gt.0) then
1802                evdw_p=evdw_p+evdwij+e_augm
1803             else
1804                evdw_m=evdw_m+evdwij+e_augm
1805             endif
1806 #else
1807             evdw=evdw+evdwij+e_augm
1808 #endif
1809             if (lprn) then
1810             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1811             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1812             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1813      &        restyp(itypi),i,restyp(itypj),j,
1814      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1815      &        chi1,chi2,chip1,chip2,
1816      &        eps1,eps2rt**2,eps3rt**2,
1817      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1818      &        evdwij+e_augm
1819             endif
1820 C Calculate gradient components.
1821             e1=e1*eps1*eps2rt**2*eps3rt**2
1822             fac=-expon*(e1+evdwij)*rij_shift
1823             sigder=fac*sigder
1824             fac=rij*fac-2*expon*rrij*e_augm
1825 C Calculate the radial part of the gradient
1826             gg(1)=xj*fac
1827             gg(2)=yj*fac
1828             gg(3)=zj*fac
1829 C Calculate angular part of the gradient.
1830 #ifdef TSCSC
1831             if (bb(itypi,itypj).gt.0) then
1832                call sc_grad
1833             else
1834                call sc_grad_T
1835             endif
1836 #else
1837             call sc_grad
1838 #endif
1839           enddo      ! j
1840         enddo        ! iint
1841       enddo          ! i
1842       end
1843 C-----------------------------------------------------------------------------
1844       subroutine sc_angular
1845 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1846 C om12. Called by ebp, egb, and egbv.
1847       implicit none
1848       include 'COMMON.CALC'
1849       include 'COMMON.IOUNITS'
1850       erij(1)=xj*rij
1851       erij(2)=yj*rij
1852       erij(3)=zj*rij
1853       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1854       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1855       om12=dxi*dxj+dyi*dyj+dzi*dzj
1856       chiom12=chi12*om12
1857 C Calculate eps1(om12) and its derivative in om12
1858       faceps1=1.0D0-om12*chiom12
1859       faceps1_inv=1.0D0/faceps1
1860       eps1=dsqrt(faceps1_inv)
1861 C Following variable is eps1*deps1/dom12
1862       eps1_om12=faceps1_inv*chiom12
1863 c diagnostics only
1864 c      faceps1_inv=om12
1865 c      eps1=om12
1866 c      eps1_om12=1.0d0
1867 c      write (iout,*) "om12",om12," eps1",eps1
1868 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1869 C and om12.
1870       om1om2=om1*om2
1871       chiom1=chi1*om1
1872       chiom2=chi2*om2
1873       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1874       sigsq=1.0D0-facsig*faceps1_inv
1875       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1876       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1877       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1878 c diagnostics only
1879 c      sigsq=1.0d0
1880 c      sigsq_om1=0.0d0
1881 c      sigsq_om2=0.0d0
1882 c      sigsq_om12=0.0d0
1883 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1884 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1885 c     &    " eps1",eps1
1886 C Calculate eps2 and its derivatives in om1, om2, and om12.
1887       chipom1=chip1*om1
1888       chipom2=chip2*om2
1889       chipom12=chip12*om12
1890       facp=1.0D0-om12*chipom12
1891       facp_inv=1.0D0/facp
1892       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1893 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1894 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1895 C Following variable is the square root of eps2
1896       eps2rt=1.0D0-facp1*facp_inv
1897 C Following three variables are the derivatives of the square root of eps
1898 C in om1, om2, and om12.
1899       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1900       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1901       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1902 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1903       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1904 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1905 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1906 c     &  " eps2rt_om12",eps2rt_om12
1907 C Calculate whole angle-dependent part of epsilon and contributions
1908 C to its derivatives
1909       return
1910       end
1911
1912 C----------------------------------------------------------------------------
1913       subroutine sc_grad_T
1914       implicit real*8 (a-h,o-z)
1915       include 'DIMENSIONS'
1916       include 'COMMON.CHAIN'
1917       include 'COMMON.DERIV'
1918       include 'COMMON.CALC'
1919       include 'COMMON.IOUNITS'
1920       double precision dcosom1(3),dcosom2(3)
1921       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1922       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1923       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1924      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1925 c diagnostics only
1926 c      eom1=0.0d0
1927 c      eom2=0.0d0
1928 c      eom12=evdwij*eps1_om12
1929 c end diagnostics
1930 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1931 c     &  " sigder",sigder
1932 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1933 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1934       do k=1,3
1935         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1936         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1937       enddo
1938       do k=1,3
1939         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1940       enddo
1941 c      write (iout,*) "gg",(gg(k),k=1,3)
1942       do k=1,3
1943         gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1944      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1945      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1946         gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1947      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1948      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1949 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1950 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1951 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1952 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1953       enddo
1954 C
1955 C Calculate the components of the gradient in DC and X
1956 C
1957 cgrad      do k=i,j-1
1958 cgrad        do l=1,3
1959 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1960 cgrad        enddo
1961 cgrad      enddo
1962       do l=1,3
1963         gvdwcT(l,i)=gvdwcT(l,i)-gg(l)
1964         gvdwcT(l,j)=gvdwcT(l,j)+gg(l)
1965       enddo
1966       return
1967       end
1968
1969 C----------------------------------------------------------------------------
1970       subroutine sc_grad
1971       implicit real*8 (a-h,o-z)
1972       include 'DIMENSIONS'
1973       include 'COMMON.CHAIN'
1974       include 'COMMON.DERIV'
1975       include 'COMMON.CALC'
1976       include 'COMMON.IOUNITS'
1977       double precision dcosom1(3),dcosom2(3)
1978       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1979       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1980       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1981      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1982 c diagnostics only
1983 c      eom1=0.0d0
1984 c      eom2=0.0d0
1985 c      eom12=evdwij*eps1_om12
1986 c end diagnostics
1987 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1988 c     &  " sigder",sigder
1989 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1990 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1991       do k=1,3
1992         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1993         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1994       enddo
1995       do k=1,3
1996         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1997       enddo
1998 c      write (iout,*) "gg",(gg(k),k=1,3)
1999       do k=1,3
2000         gvdwx(k,i)=gvdwx(k,i)-gg(k)
2001      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2002      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2003         gvdwx(k,j)=gvdwx(k,j)+gg(k)
2004      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2005      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2006 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2007 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2008 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2009 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2010       enddo
2011 C
2012 C Calculate the components of the gradient in DC and X
2013 C
2014 cgrad      do k=i,j-1
2015 cgrad        do l=1,3
2016 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2017 cgrad        enddo
2018 cgrad      enddo
2019       do l=1,3
2020         gvdwc(l,i)=gvdwc(l,i)-gg(l)
2021         gvdwc(l,j)=gvdwc(l,j)+gg(l)
2022       enddo
2023       return
2024       end
2025 C-----------------------------------------------------------------------
2026       subroutine e_softsphere(evdw)
2027 C
2028 C This subroutine calculates the interaction energy of nonbonded side chains
2029 C assuming the LJ potential of interaction.
2030 C
2031       implicit real*8 (a-h,o-z)
2032       include 'DIMENSIONS'
2033       parameter (accur=1.0d-10)
2034       include 'COMMON.GEO'
2035       include 'COMMON.VAR'
2036       include 'COMMON.LOCAL'
2037       include 'COMMON.CHAIN'
2038       include 'COMMON.DERIV'
2039       include 'COMMON.INTERACT'
2040       include 'COMMON.TORSION'
2041       include 'COMMON.SBRIDGE'
2042       include 'COMMON.NAMES'
2043       include 'COMMON.IOUNITS'
2044       include 'COMMON.CONTACTS'
2045       dimension gg(3)
2046 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2047       evdw=0.0D0
2048       do i=iatsc_s,iatsc_e
2049         itypi=itype(i)
2050         itypi1=itype(i+1)
2051         xi=c(1,nres+i)
2052         yi=c(2,nres+i)
2053         zi=c(3,nres+i)
2054 C
2055 C Calculate SC interaction energy.
2056 C
2057         do iint=1,nint_gr(i)
2058 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2059 cd   &                  'iend=',iend(i,iint)
2060           do j=istart(i,iint),iend(i,iint)
2061             itypj=itype(j)
2062             xj=c(1,nres+j)-xi
2063             yj=c(2,nres+j)-yi
2064             zj=c(3,nres+j)-zi
2065             rij=xj*xj+yj*yj+zj*zj
2066 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2067             r0ij=r0(itypi,itypj)
2068             r0ijsq=r0ij*r0ij
2069 c            print *,i,j,r0ij,dsqrt(rij)
2070             if (rij.lt.r0ijsq) then
2071               evdwij=0.25d0*(rij-r0ijsq)**2
2072               fac=rij-r0ijsq
2073             else
2074               evdwij=0.0d0
2075               fac=0.0d0
2076             endif
2077             evdw=evdw+evdwij
2078 C
2079 C Calculate the components of the gradient in DC and X
2080 C
2081             gg(1)=xj*fac
2082             gg(2)=yj*fac
2083             gg(3)=zj*fac
2084             do k=1,3
2085               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2086               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2087               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2088               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2089             enddo
2090 cgrad            do k=i,j-1
2091 cgrad              do l=1,3
2092 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2093 cgrad              enddo
2094 cgrad            enddo
2095           enddo ! j
2096         enddo ! iint
2097       enddo ! i
2098       return
2099       end
2100 C--------------------------------------------------------------------------
2101       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2102      &              eello_turn4)
2103 C
2104 C Soft-sphere potential of p-p interaction
2105 C
2106       implicit real*8 (a-h,o-z)
2107       include 'DIMENSIONS'
2108       include 'COMMON.CONTROL'
2109       include 'COMMON.IOUNITS'
2110       include 'COMMON.GEO'
2111       include 'COMMON.VAR'
2112       include 'COMMON.LOCAL'
2113       include 'COMMON.CHAIN'
2114       include 'COMMON.DERIV'
2115       include 'COMMON.INTERACT'
2116       include 'COMMON.CONTACTS'
2117       include 'COMMON.TORSION'
2118       include 'COMMON.VECTORS'
2119       include 'COMMON.FFIELD'
2120       dimension ggg(3)
2121 cd      write(iout,*) 'In EELEC_soft_sphere'
2122       ees=0.0D0
2123       evdw1=0.0D0
2124       eel_loc=0.0d0
2125       eello_turn3=0.0d0
2126       eello_turn4=0.0d0
2127       ind=0
2128       do i=iatel_s,iatel_e
2129         dxi=dc(1,i)
2130         dyi=dc(2,i)
2131         dzi=dc(3,i)
2132         xmedi=c(1,i)+0.5d0*dxi
2133         ymedi=c(2,i)+0.5d0*dyi
2134         zmedi=c(3,i)+0.5d0*dzi
2135         num_conti=0
2136 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2137         do j=ielstart(i),ielend(i)
2138           ind=ind+1
2139           iteli=itel(i)
2140           itelj=itel(j)
2141           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2142           r0ij=rpp(iteli,itelj)
2143           r0ijsq=r0ij*r0ij
2144           dxj=dc(1,j)
2145           dyj=dc(2,j)
2146           dzj=dc(3,j)
2147           xj=c(1,j)+0.5D0*dxj-xmedi
2148           yj=c(2,j)+0.5D0*dyj-ymedi
2149           zj=c(3,j)+0.5D0*dzj-zmedi
2150           rij=xj*xj+yj*yj+zj*zj
2151           if (rij.lt.r0ijsq) then
2152             evdw1ij=0.25d0*(rij-r0ijsq)**2
2153             fac=rij-r0ijsq
2154           else
2155             evdw1ij=0.0d0
2156             fac=0.0d0
2157           endif
2158           evdw1=evdw1+evdw1ij
2159 C
2160 C Calculate contributions to the Cartesian gradient.
2161 C
2162           ggg(1)=fac*xj
2163           ggg(2)=fac*yj
2164           ggg(3)=fac*zj
2165           do k=1,3
2166             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2167             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2168           enddo
2169 *
2170 * Loop over residues i+1 thru j-1.
2171 *
2172 cgrad          do k=i+1,j-1
2173 cgrad            do l=1,3
2174 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2175 cgrad            enddo
2176 cgrad          enddo
2177         enddo ! j
2178       enddo   ! i
2179 cgrad      do i=nnt,nct-1
2180 cgrad        do k=1,3
2181 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2182 cgrad        enddo
2183 cgrad        do j=i+1,nct-1
2184 cgrad          do k=1,3
2185 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2186 cgrad          enddo
2187 cgrad        enddo
2188 cgrad      enddo
2189       return
2190       end
2191 c------------------------------------------------------------------------------
2192       subroutine vec_and_deriv
2193       implicit real*8 (a-h,o-z)
2194       include 'DIMENSIONS'
2195 #ifdef MPI
2196       include 'mpif.h'
2197 #endif
2198       include 'COMMON.IOUNITS'
2199       include 'COMMON.GEO'
2200       include 'COMMON.VAR'
2201       include 'COMMON.LOCAL'
2202       include 'COMMON.CHAIN'
2203       include 'COMMON.VECTORS'
2204       include 'COMMON.SETUP'
2205       include 'COMMON.TIME1'
2206       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2207 C Compute the local reference systems. For reference system (i), the
2208 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2209 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2210 #ifdef PARVEC
2211       do i=ivec_start,ivec_end
2212 #else
2213       do i=1,nres-1
2214 #endif
2215           if (i.eq.nres-1) then
2216 C Case of the last full residue
2217 C Compute the Z-axis
2218             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2219             costh=dcos(pi-theta(nres))
2220             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2221             do k=1,3
2222               uz(k,i)=fac*uz(k,i)
2223             enddo
2224 C Compute the derivatives of uz
2225             uzder(1,1,1)= 0.0d0
2226             uzder(2,1,1)=-dc_norm(3,i-1)
2227             uzder(3,1,1)= dc_norm(2,i-1)
2228             uzder(1,2,1)= dc_norm(3,i-1)
2229             uzder(2,2,1)= 0.0d0
2230             uzder(3,2,1)=-dc_norm(1,i-1)
2231             uzder(1,3,1)=-dc_norm(2,i-1)
2232             uzder(2,3,1)= dc_norm(1,i-1)
2233             uzder(3,3,1)= 0.0d0
2234             uzder(1,1,2)= 0.0d0
2235             uzder(2,1,2)= dc_norm(3,i)
2236             uzder(3,1,2)=-dc_norm(2,i)
2237             uzder(1,2,2)=-dc_norm(3,i)
2238             uzder(2,2,2)= 0.0d0
2239             uzder(3,2,2)= dc_norm(1,i)
2240             uzder(1,3,2)= dc_norm(2,i)
2241             uzder(2,3,2)=-dc_norm(1,i)
2242             uzder(3,3,2)= 0.0d0
2243 C Compute the Y-axis
2244             facy=fac
2245             do k=1,3
2246               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2247             enddo
2248 C Compute the derivatives of uy
2249             do j=1,3
2250               do k=1,3
2251                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2252      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2253                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2254               enddo
2255               uyder(j,j,1)=uyder(j,j,1)-costh
2256               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2257             enddo
2258             do j=1,2
2259               do k=1,3
2260                 do l=1,3
2261                   uygrad(l,k,j,i)=uyder(l,k,j)
2262                   uzgrad(l,k,j,i)=uzder(l,k,j)
2263                 enddo
2264               enddo
2265             enddo
2266             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2267             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2268             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2269             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2270           else
2271 C Other residues
2272 C Compute the Z-axis
2273             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2274             costh=dcos(pi-theta(i+2))
2275             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2276             do k=1,3
2277               uz(k,i)=fac*uz(k,i)
2278             enddo
2279 C Compute the derivatives of uz
2280             uzder(1,1,1)= 0.0d0
2281             uzder(2,1,1)=-dc_norm(3,i+1)
2282             uzder(3,1,1)= dc_norm(2,i+1)
2283             uzder(1,2,1)= dc_norm(3,i+1)
2284             uzder(2,2,1)= 0.0d0
2285             uzder(3,2,1)=-dc_norm(1,i+1)
2286             uzder(1,3,1)=-dc_norm(2,i+1)
2287             uzder(2,3,1)= dc_norm(1,i+1)
2288             uzder(3,3,1)= 0.0d0
2289             uzder(1,1,2)= 0.0d0
2290             uzder(2,1,2)= dc_norm(3,i)
2291             uzder(3,1,2)=-dc_norm(2,i)
2292             uzder(1,2,2)=-dc_norm(3,i)
2293             uzder(2,2,2)= 0.0d0
2294             uzder(3,2,2)= dc_norm(1,i)
2295             uzder(1,3,2)= dc_norm(2,i)
2296             uzder(2,3,2)=-dc_norm(1,i)
2297             uzder(3,3,2)= 0.0d0
2298 C Compute the Y-axis
2299             facy=fac
2300             do k=1,3
2301               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2302             enddo
2303 C Compute the derivatives of uy
2304             do j=1,3
2305               do k=1,3
2306                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2307      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2308                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2309               enddo
2310               uyder(j,j,1)=uyder(j,j,1)-costh
2311               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2312             enddo
2313             do j=1,2
2314               do k=1,3
2315                 do l=1,3
2316                   uygrad(l,k,j,i)=uyder(l,k,j)
2317                   uzgrad(l,k,j,i)=uzder(l,k,j)
2318                 enddo
2319               enddo
2320             enddo
2321             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2322             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2323             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2324             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2325           endif
2326       enddo
2327       do i=1,nres-1
2328         vbld_inv_temp(1)=vbld_inv(i+1)
2329         if (i.lt.nres-1) then
2330           vbld_inv_temp(2)=vbld_inv(i+2)
2331           else
2332           vbld_inv_temp(2)=vbld_inv(i)
2333           endif
2334         do j=1,2
2335           do k=1,3
2336             do l=1,3
2337               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2338               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2339             enddo
2340           enddo
2341         enddo
2342       enddo
2343 #if defined(PARVEC) && defined(MPI)
2344       if (nfgtasks1.gt.1) then
2345         time00=MPI_Wtime()
2346 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2347 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2348 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2349         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2350      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2351      &   FG_COMM1,IERR)
2352         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2353      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2354      &   FG_COMM1,IERR)
2355         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2356      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2357      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2358         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2359      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2360      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2361         time_gather=time_gather+MPI_Wtime()-time00
2362       endif
2363 c      if (fg_rank.eq.0) then
2364 c        write (iout,*) "Arrays UY and UZ"
2365 c        do i=1,nres-1
2366 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2367 c     &     (uz(k,i),k=1,3)
2368 c        enddo
2369 c      endif
2370 #endif
2371       return
2372       end
2373 C-----------------------------------------------------------------------------
2374       subroutine check_vecgrad
2375       implicit real*8 (a-h,o-z)
2376       include 'DIMENSIONS'
2377       include 'COMMON.IOUNITS'
2378       include 'COMMON.GEO'
2379       include 'COMMON.VAR'
2380       include 'COMMON.LOCAL'
2381       include 'COMMON.CHAIN'
2382       include 'COMMON.VECTORS'
2383       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2384       dimension uyt(3,maxres),uzt(3,maxres)
2385       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2386       double precision delta /1.0d-7/
2387       call vec_and_deriv
2388 cd      do i=1,nres
2389 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2390 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2391 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2392 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2393 cd     &     (dc_norm(if90,i),if90=1,3)
2394 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2395 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2396 cd          write(iout,'(a)')
2397 cd      enddo
2398       do i=1,nres
2399         do j=1,2
2400           do k=1,3
2401             do l=1,3
2402               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2403               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2404             enddo
2405           enddo
2406         enddo
2407       enddo
2408       call vec_and_deriv
2409       do i=1,nres
2410         do j=1,3
2411           uyt(j,i)=uy(j,i)
2412           uzt(j,i)=uz(j,i)
2413         enddo
2414       enddo
2415       do i=1,nres
2416 cd        write (iout,*) 'i=',i
2417         do k=1,3
2418           erij(k)=dc_norm(k,i)
2419         enddo
2420         do j=1,3
2421           do k=1,3
2422             dc_norm(k,i)=erij(k)
2423           enddo
2424           dc_norm(j,i)=dc_norm(j,i)+delta
2425 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2426 c          do k=1,3
2427 c            dc_norm(k,i)=dc_norm(k,i)/fac
2428 c          enddo
2429 c          write (iout,*) (dc_norm(k,i),k=1,3)
2430 c          write (iout,*) (erij(k),k=1,3)
2431           call vec_and_deriv
2432           do k=1,3
2433             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2434             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2435             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2436             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2437           enddo
2438 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2439 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2440 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2441         enddo
2442         do k=1,3
2443           dc_norm(k,i)=erij(k)
2444         enddo
2445 cd        do k=1,3
2446 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2447 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2448 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2449 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2450 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2451 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2452 cd          write (iout,'(a)')
2453 cd        enddo
2454       enddo
2455       return
2456       end
2457 C--------------------------------------------------------------------------
2458       subroutine set_matrices
2459       implicit real*8 (a-h,o-z)
2460       include 'DIMENSIONS'
2461 #ifdef MPI
2462       include "mpif.h"
2463       include "COMMON.SETUP"
2464       integer IERR
2465       integer status(MPI_STATUS_SIZE)
2466 #endif
2467       include 'COMMON.IOUNITS'
2468       include 'COMMON.GEO'
2469       include 'COMMON.VAR'
2470       include 'COMMON.LOCAL'
2471       include 'COMMON.CHAIN'
2472       include 'COMMON.DERIV'
2473       include 'COMMON.INTERACT'
2474       include 'COMMON.CONTACTS'
2475       include 'COMMON.TORSION'
2476       include 'COMMON.VECTORS'
2477       include 'COMMON.FFIELD'
2478       double precision auxvec(2),auxmat(2,2)
2479 C
2480 C Compute the virtual-bond-torsional-angle dependent quantities needed
2481 C to calculate the el-loc multibody terms of various order.
2482 C
2483 #ifdef PARMAT
2484       do i=ivec_start+2,ivec_end+2
2485 #else
2486       do i=3,nres+1
2487 #endif
2488         if (i .lt. nres+1) then
2489           sin1=dsin(phi(i))
2490           cos1=dcos(phi(i))
2491           sintab(i-2)=sin1
2492           costab(i-2)=cos1
2493           obrot(1,i-2)=cos1
2494           obrot(2,i-2)=sin1
2495           sin2=dsin(2*phi(i))
2496           cos2=dcos(2*phi(i))
2497           sintab2(i-2)=sin2
2498           costab2(i-2)=cos2
2499           obrot2(1,i-2)=cos2
2500           obrot2(2,i-2)=sin2
2501           Ug(1,1,i-2)=-cos1
2502           Ug(1,2,i-2)=-sin1
2503           Ug(2,1,i-2)=-sin1
2504           Ug(2,2,i-2)= cos1
2505           Ug2(1,1,i-2)=-cos2
2506           Ug2(1,2,i-2)=-sin2
2507           Ug2(2,1,i-2)=-sin2
2508           Ug2(2,2,i-2)= cos2
2509         else
2510           costab(i-2)=1.0d0
2511           sintab(i-2)=0.0d0
2512           obrot(1,i-2)=1.0d0
2513           obrot(2,i-2)=0.0d0
2514           obrot2(1,i-2)=0.0d0
2515           obrot2(2,i-2)=0.0d0
2516           Ug(1,1,i-2)=1.0d0
2517           Ug(1,2,i-2)=0.0d0
2518           Ug(2,1,i-2)=0.0d0
2519           Ug(2,2,i-2)=1.0d0
2520           Ug2(1,1,i-2)=0.0d0
2521           Ug2(1,2,i-2)=0.0d0
2522           Ug2(2,1,i-2)=0.0d0
2523           Ug2(2,2,i-2)=0.0d0
2524         endif
2525         if (i .gt. 3 .and. i .lt. nres+1) then
2526           obrot_der(1,i-2)=-sin1
2527           obrot_der(2,i-2)= cos1
2528           Ugder(1,1,i-2)= sin1
2529           Ugder(1,2,i-2)=-cos1
2530           Ugder(2,1,i-2)=-cos1
2531           Ugder(2,2,i-2)=-sin1
2532           dwacos2=cos2+cos2
2533           dwasin2=sin2+sin2
2534           obrot2_der(1,i-2)=-dwasin2
2535           obrot2_der(2,i-2)= dwacos2
2536           Ug2der(1,1,i-2)= dwasin2
2537           Ug2der(1,2,i-2)=-dwacos2
2538           Ug2der(2,1,i-2)=-dwacos2
2539           Ug2der(2,2,i-2)=-dwasin2
2540         else
2541           obrot_der(1,i-2)=0.0d0
2542           obrot_der(2,i-2)=0.0d0
2543           Ugder(1,1,i-2)=0.0d0
2544           Ugder(1,2,i-2)=0.0d0
2545           Ugder(2,1,i-2)=0.0d0
2546           Ugder(2,2,i-2)=0.0d0
2547           obrot2_der(1,i-2)=0.0d0
2548           obrot2_der(2,i-2)=0.0d0
2549           Ug2der(1,1,i-2)=0.0d0
2550           Ug2der(1,2,i-2)=0.0d0
2551           Ug2der(2,1,i-2)=0.0d0
2552           Ug2der(2,2,i-2)=0.0d0
2553         endif
2554 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2555         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2556           iti = itortyp(itype(i-2))
2557         else
2558           iti=ntortyp+1
2559         endif
2560 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2561         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2562           iti1 = itortyp(itype(i-1))
2563         else
2564           iti1=ntortyp+1
2565         endif
2566 cd        write (iout,*) '*******i',i,' iti1',iti
2567 cd        write (iout,*) 'b1',b1(:,iti)
2568 cd        write (iout,*) 'b2',b2(:,iti)
2569 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2570 c        if (i .gt. iatel_s+2) then
2571         if (i .gt. nnt+2) then
2572           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2573           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2574           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2575      &    then
2576           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2577           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2578           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2579           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2580           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2581           endif
2582         else
2583           do k=1,2
2584             Ub2(k,i-2)=0.0d0
2585             Ctobr(k,i-2)=0.0d0
2586             Dtobr2(k,i-2)=0.0d0
2587             do l=1,2
2588               EUg(l,k,i-2)=0.0d0
2589               CUg(l,k,i-2)=0.0d0
2590               DUg(l,k,i-2)=0.0d0
2591               DtUg2(l,k,i-2)=0.0d0
2592             enddo
2593           enddo
2594         endif
2595         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2596         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2597         do k=1,2
2598           muder(k,i-2)=Ub2der(k,i-2)
2599         enddo
2600 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2601         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2602           iti1 = itortyp(itype(i-1))
2603         else
2604           iti1=ntortyp+1
2605         endif
2606         do k=1,2
2607           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2608         enddo
2609 cd        write (iout,*) 'mu ',mu(:,i-2)
2610 cd        write (iout,*) 'mu1',mu1(:,i-2)
2611 cd        write (iout,*) 'mu2',mu2(:,i-2)
2612         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2613      &  then
2614         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2615         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2616         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2617         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2618         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2619 C Vectors and matrices dependent on a single virtual-bond dihedral.
2620         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2621         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2622         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2623         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2624         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2625         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2626         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2627         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2628         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2629         endif
2630       enddo
2631 C Matrices dependent on two consecutive virtual-bond dihedrals.
2632 C The order of matrices is from left to right.
2633       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2634      &then
2635 c      do i=max0(ivec_start,2),ivec_end
2636       do i=2,nres-1
2637         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2638         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2639         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2640         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2641         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2642         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2643         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2644         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2645       enddo
2646       endif
2647 #if defined(MPI) && defined(PARMAT)
2648 #ifdef DEBUG
2649 c      if (fg_rank.eq.0) then
2650         write (iout,*) "Arrays UG and UGDER before GATHER"
2651         do i=1,nres-1
2652           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2653      &     ((ug(l,k,i),l=1,2),k=1,2),
2654      &     ((ugder(l,k,i),l=1,2),k=1,2)
2655         enddo
2656         write (iout,*) "Arrays UG2 and UG2DER"
2657         do i=1,nres-1
2658           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2659      &     ((ug2(l,k,i),l=1,2),k=1,2),
2660      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2661         enddo
2662         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2663         do i=1,nres-1
2664           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2665      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2666      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2667         enddo
2668         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2669         do i=1,nres-1
2670           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2671      &     costab(i),sintab(i),costab2(i),sintab2(i)
2672         enddo
2673         write (iout,*) "Array MUDER"
2674         do i=1,nres-1
2675           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2676         enddo
2677 c      endif
2678 #endif
2679       if (nfgtasks.gt.1) then
2680         time00=MPI_Wtime()
2681 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2682 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2683 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2684 #ifdef MATGATHER
2685         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2686      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2687      &   FG_COMM1,IERR)
2688         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2689      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2690      &   FG_COMM1,IERR)
2691         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2692      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2693      &   FG_COMM1,IERR)
2694         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2695      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2696      &   FG_COMM1,IERR)
2697         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2698      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2699      &   FG_COMM1,IERR)
2700         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2701      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2702      &   FG_COMM1,IERR)
2703         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2704      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2705      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2706         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2707      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2708      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2709         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2710      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2711      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2712         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2713      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2714      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2715         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2716      &  then
2717         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2718      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2719      &   FG_COMM1,IERR)
2720         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2721      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2722      &   FG_COMM1,IERR)
2723         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2724      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2725      &   FG_COMM1,IERR)
2726        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2727      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2728      &   FG_COMM1,IERR)
2729         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2730      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2731      &   FG_COMM1,IERR)
2732         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2733      &   ivec_count(fg_rank1),
2734      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2735      &   FG_COMM1,IERR)
2736         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2737      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2738      &   FG_COMM1,IERR)
2739         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2740      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2741      &   FG_COMM1,IERR)
2742         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2743      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2744      &   FG_COMM1,IERR)
2745         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2746      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2747      &   FG_COMM1,IERR)
2748         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2749      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2750      &   FG_COMM1,IERR)
2751         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2752      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2753      &   FG_COMM1,IERR)
2754         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2755      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2756      &   FG_COMM1,IERR)
2757         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2758      &   ivec_count(fg_rank1),
2759      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2760      &   FG_COMM1,IERR)
2761         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2762      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2763      &   FG_COMM1,IERR)
2764        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2765      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2766      &   FG_COMM1,IERR)
2767         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2768      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2769      &   FG_COMM1,IERR)
2770        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2771      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2772      &   FG_COMM1,IERR)
2773         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2774      &   ivec_count(fg_rank1),
2775      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2776      &   FG_COMM1,IERR)
2777         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2778      &   ivec_count(fg_rank1),
2779      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2780      &   FG_COMM1,IERR)
2781         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2782      &   ivec_count(fg_rank1),
2783      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2784      &   MPI_MAT2,FG_COMM1,IERR)
2785         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2786      &   ivec_count(fg_rank1),
2787      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2788      &   MPI_MAT2,FG_COMM1,IERR)
2789         endif
2790 #else
2791 c Passes matrix info through the ring
2792       isend=fg_rank1
2793       irecv=fg_rank1-1
2794       if (irecv.lt.0) irecv=nfgtasks1-1
2795       iprev=irecv
2796       inext=fg_rank1+1
2797       if (inext.ge.nfgtasks1) inext=0
2798       do i=1,nfgtasks1-1
2799 c        write (iout,*) "isend",isend," irecv",irecv
2800 c        call flush(iout)
2801         lensend=lentyp(isend)
2802         lenrecv=lentyp(irecv)
2803 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2804 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2805 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2806 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2807 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2808 c        write (iout,*) "Gather ROTAT1"
2809 c        call flush(iout)
2810 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2811 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2812 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2813 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2814 c        write (iout,*) "Gather ROTAT2"
2815 c        call flush(iout)
2816         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2817      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2818      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2819      &   iprev,4400+irecv,FG_COMM,status,IERR)
2820 c        write (iout,*) "Gather ROTAT_OLD"
2821 c        call flush(iout)
2822         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2823      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2824      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2825      &   iprev,5500+irecv,FG_COMM,status,IERR)
2826 c        write (iout,*) "Gather PRECOMP11"
2827 c        call flush(iout)
2828         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2829      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2830      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2831      &   iprev,6600+irecv,FG_COMM,status,IERR)
2832 c        write (iout,*) "Gather PRECOMP12"
2833 c        call flush(iout)
2834         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2835      &  then
2836         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2837      &   MPI_ROTAT2(lensend),inext,7700+isend,
2838      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2839      &   iprev,7700+irecv,FG_COMM,status,IERR)
2840 c        write (iout,*) "Gather PRECOMP21"
2841 c        call flush(iout)
2842         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2843      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2844      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2845      &   iprev,8800+irecv,FG_COMM,status,IERR)
2846 c        write (iout,*) "Gather PRECOMP22"
2847 c        call flush(iout)
2848         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2849      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2850      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2851      &   MPI_PRECOMP23(lenrecv),
2852      &   iprev,9900+irecv,FG_COMM,status,IERR)
2853 c        write (iout,*) "Gather PRECOMP23"
2854 c        call flush(iout)
2855         endif
2856         isend=irecv
2857         irecv=irecv-1
2858         if (irecv.lt.0) irecv=nfgtasks1-1
2859       enddo
2860 #endif
2861         time_gather=time_gather+MPI_Wtime()-time00
2862       endif
2863 #ifdef DEBUG
2864 c      if (fg_rank.eq.0) then
2865         write (iout,*) "Arrays UG and UGDER"
2866         do i=1,nres-1
2867           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2868      &     ((ug(l,k,i),l=1,2),k=1,2),
2869      &     ((ugder(l,k,i),l=1,2),k=1,2)
2870         enddo
2871         write (iout,*) "Arrays UG2 and UG2DER"
2872         do i=1,nres-1
2873           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2874      &     ((ug2(l,k,i),l=1,2),k=1,2),
2875      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2876         enddo
2877         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2878         do i=1,nres-1
2879           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2880      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2881      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2882         enddo
2883         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2884         do i=1,nres-1
2885           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2886      &     costab(i),sintab(i),costab2(i),sintab2(i)
2887         enddo
2888         write (iout,*) "Array MUDER"
2889         do i=1,nres-1
2890           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2891         enddo
2892 c      endif
2893 #endif
2894 #endif
2895 cd      do i=1,nres
2896 cd        iti = itortyp(itype(i))
2897 cd        write (iout,*) i
2898 cd        do j=1,2
2899 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2900 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2901 cd        enddo
2902 cd      enddo
2903       return
2904       end
2905 C--------------------------------------------------------------------------
2906       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2907 C
2908 C This subroutine calculates the average interaction energy and its gradient
2909 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2910 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2911 C The potential depends both on the distance of peptide-group centers and on
2912 C the orientation of the CA-CA virtual bonds.
2913 C
2914       implicit real*8 (a-h,o-z)
2915 #ifdef MPI
2916       include 'mpif.h'
2917 #endif
2918       include 'DIMENSIONS'
2919       include 'COMMON.CONTROL'
2920       include 'COMMON.SETUP'
2921       include 'COMMON.IOUNITS'
2922       include 'COMMON.GEO'
2923       include 'COMMON.VAR'
2924       include 'COMMON.LOCAL'
2925       include 'COMMON.CHAIN'
2926       include 'COMMON.DERIV'
2927       include 'COMMON.INTERACT'
2928       include 'COMMON.CONTACTS'
2929       include 'COMMON.TORSION'
2930       include 'COMMON.VECTORS'
2931       include 'COMMON.FFIELD'
2932       include 'COMMON.TIME1'
2933       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2934      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2935       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2936      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2937       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2938      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2939      &    num_conti,j1,j2
2940 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2941 #ifdef MOMENT
2942       double precision scal_el /1.0d0/
2943 #else
2944       double precision scal_el /0.5d0/
2945 #endif
2946 C 12/13/98
2947 C 13-go grudnia roku pamietnego...
2948       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2949      &                   0.0d0,1.0d0,0.0d0,
2950      &                   0.0d0,0.0d0,1.0d0/
2951 cd      write(iout,*) 'In EELEC'
2952 cd      do i=1,nloctyp
2953 cd        write(iout,*) 'Type',i
2954 cd        write(iout,*) 'B1',B1(:,i)
2955 cd        write(iout,*) 'B2',B2(:,i)
2956 cd        write(iout,*) 'CC',CC(:,:,i)
2957 cd        write(iout,*) 'DD',DD(:,:,i)
2958 cd        write(iout,*) 'EE',EE(:,:,i)
2959 cd      enddo
2960 cd      call check_vecgrad
2961 cd      stop
2962       if (icheckgrad.eq.1) then
2963         do i=1,nres-1
2964           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2965           do k=1,3
2966             dc_norm(k,i)=dc(k,i)*fac
2967           enddo
2968 c          write (iout,*) 'i',i,' fac',fac
2969         enddo
2970       endif
2971       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2972      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2973      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2974 c        call vec_and_deriv
2975 #ifdef TIMING
2976         time01=MPI_Wtime()
2977 #endif
2978         call set_matrices
2979 #ifdef TIMING
2980         time_mat=time_mat+MPI_Wtime()-time01
2981 #endif
2982       endif
2983 cd      do i=1,nres-1
2984 cd        write (iout,*) 'i=',i
2985 cd        do k=1,3
2986 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2987 cd        enddo
2988 cd        do k=1,3
2989 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2990 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2991 cd        enddo
2992 cd      enddo
2993       t_eelecij=0.0d0
2994       ees=0.0D0
2995       evdw1=0.0D0
2996       eel_loc=0.0d0
2997       eello_turn3=0.0d0
2998       eello_turn4=0.0d0
2999       ind=0
3000       do i=1,nres
3001         num_cont_hb(i)=0
3002       enddo
3003 cd      print '(a)','Enter EELEC'
3004 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3005       do i=1,nres
3006         gel_loc_loc(i)=0.0d0
3007         gcorr_loc(i)=0.0d0
3008       enddo
3009 c
3010 c
3011 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3012 C
3013 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3014 C
3015       do i=iturn3_start,iturn3_end
3016         dxi=dc(1,i)
3017         dyi=dc(2,i)
3018         dzi=dc(3,i)
3019         dx_normi=dc_norm(1,i)
3020         dy_normi=dc_norm(2,i)
3021         dz_normi=dc_norm(3,i)
3022         xmedi=c(1,i)+0.5d0*dxi
3023         ymedi=c(2,i)+0.5d0*dyi
3024         zmedi=c(3,i)+0.5d0*dzi
3025         num_conti=0
3026         call eelecij(i,i+2,ees,evdw1,eel_loc)
3027         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3028         num_cont_hb(i)=num_conti
3029       enddo
3030       do i=iturn4_start,iturn4_end
3031         dxi=dc(1,i)
3032         dyi=dc(2,i)
3033         dzi=dc(3,i)
3034         dx_normi=dc_norm(1,i)
3035         dy_normi=dc_norm(2,i)
3036         dz_normi=dc_norm(3,i)
3037         xmedi=c(1,i)+0.5d0*dxi
3038         ymedi=c(2,i)+0.5d0*dyi
3039         zmedi=c(3,i)+0.5d0*dzi
3040         num_conti=num_cont_hb(i)
3041         call eelecij(i,i+3,ees,evdw1,eel_loc)
3042         if (wturn4.gt.0.0d0) call eturn4(i,eello_turn4)
3043         num_cont_hb(i)=num_conti
3044       enddo   ! i
3045 c
3046 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3047 c
3048       do i=iatel_s,iatel_e
3049         dxi=dc(1,i)
3050         dyi=dc(2,i)
3051         dzi=dc(3,i)
3052         dx_normi=dc_norm(1,i)
3053         dy_normi=dc_norm(2,i)
3054         dz_normi=dc_norm(3,i)
3055         xmedi=c(1,i)+0.5d0*dxi
3056         ymedi=c(2,i)+0.5d0*dyi
3057         zmedi=c(3,i)+0.5d0*dzi
3058 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3059         num_conti=num_cont_hb(i)
3060         do j=ielstart(i),ielend(i)
3061           call eelecij(i,j,ees,evdw1,eel_loc)
3062         enddo ! j
3063         num_cont_hb(i)=num_conti
3064       enddo   ! i
3065 c      write (iout,*) "Number of loop steps in EELEC:",ind
3066 cd      do i=1,nres
3067 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3068 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3069 cd      enddo
3070 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3071 ccc      eel_loc=eel_loc+eello_turn3
3072 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3073       return
3074       end
3075 C-------------------------------------------------------------------------------
3076       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3077       implicit real*8 (a-h,o-z)
3078       include 'DIMENSIONS'
3079 #ifdef MPI
3080       include "mpif.h"
3081 #endif
3082       include 'COMMON.CONTROL'
3083       include 'COMMON.IOUNITS'
3084       include 'COMMON.GEO'
3085       include 'COMMON.VAR'
3086       include 'COMMON.LOCAL'
3087       include 'COMMON.CHAIN'
3088       include 'COMMON.DERIV'
3089       include 'COMMON.INTERACT'
3090       include 'COMMON.CONTACTS'
3091       include 'COMMON.TORSION'
3092       include 'COMMON.VECTORS'
3093       include 'COMMON.FFIELD'
3094       include 'COMMON.TIME1'
3095       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3096      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3097       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3098      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3099       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3100      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3101      &    num_conti,j1,j2
3102 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3103 #ifdef MOMENT
3104       double precision scal_el /1.0d0/
3105 #else
3106       double precision scal_el /0.5d0/
3107 #endif
3108 C 12/13/98
3109 C 13-go grudnia roku pamietnego...
3110       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3111      &                   0.0d0,1.0d0,0.0d0,
3112      &                   0.0d0,0.0d0,1.0d0/
3113 c          time00=MPI_Wtime()
3114 cd      write (iout,*) "eelecij",i,j
3115 c          ind=ind+1
3116           iteli=itel(i)
3117           itelj=itel(j)
3118           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3119           aaa=app(iteli,itelj)
3120           bbb=bpp(iteli,itelj)
3121           ael6i=ael6(iteli,itelj)
3122           ael3i=ael3(iteli,itelj)
3123           dxj=dc(1,j)
3124           dyj=dc(2,j)
3125           dzj=dc(3,j)
3126           dx_normj=dc_norm(1,j)
3127           dy_normj=dc_norm(2,j)
3128           dz_normj=dc_norm(3,j)
3129           xj=c(1,j)+0.5D0*dxj-xmedi
3130           yj=c(2,j)+0.5D0*dyj-ymedi
3131           zj=c(3,j)+0.5D0*dzj-zmedi
3132           rij=xj*xj+yj*yj+zj*zj
3133           rrmij=1.0D0/rij
3134           rij=dsqrt(rij)
3135           rmij=1.0D0/rij
3136           r3ij=rrmij*rmij
3137           r6ij=r3ij*r3ij
3138           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3139           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3140           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3141           fac=cosa-3.0D0*cosb*cosg
3142           ev1=aaa*r6ij*r6ij
3143 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3144           if (j.eq.i+2) ev1=scal_el*ev1
3145           ev2=bbb*r6ij
3146           fac3=ael6i*r6ij
3147           fac4=ael3i*r3ij
3148           evdwij=ev1+ev2
3149           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3150           el2=fac4*fac
3151           eesij=el1+el2
3152 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3153           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3154           ees=ees+eesij
3155           evdw1=evdw1+evdwij
3156 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3157 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3158 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3159 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3160
3161           if (energy_dec) then
3162               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3163               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3164           endif
3165
3166 C
3167 C Calculate contributions to the Cartesian gradient.
3168 C
3169 #ifdef SPLITELE
3170           facvdw=-6*rrmij*(ev1+evdwij)
3171           facel=-3*rrmij*(el1+eesij)
3172           fac1=fac
3173           erij(1)=xj*rmij
3174           erij(2)=yj*rmij
3175           erij(3)=zj*rmij
3176 *
3177 * Radial derivatives. First process both termini of the fragment (i,j)
3178 *
3179           ggg(1)=facel*xj
3180           ggg(2)=facel*yj
3181           ggg(3)=facel*zj
3182 c          do k=1,3
3183 c            ghalf=0.5D0*ggg(k)
3184 c            gelc(k,i)=gelc(k,i)+ghalf
3185 c            gelc(k,j)=gelc(k,j)+ghalf
3186 c          enddo
3187 c 9/28/08 AL Gradient compotents will be summed only at the end
3188           do k=1,3
3189             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3190             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3191           enddo
3192 *
3193 * Loop over residues i+1 thru j-1.
3194 *
3195 cgrad          do k=i+1,j-1
3196 cgrad            do l=1,3
3197 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3198 cgrad            enddo
3199 cgrad          enddo
3200           ggg(1)=facvdw*xj
3201           ggg(2)=facvdw*yj
3202           ggg(3)=facvdw*zj
3203 c          do k=1,3
3204 c            ghalf=0.5D0*ggg(k)
3205 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3206 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3207 c          enddo
3208 c 9/28/08 AL Gradient compotents will be summed only at the end
3209           do k=1,3
3210             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3211             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3212           enddo
3213 *
3214 * Loop over residues i+1 thru j-1.
3215 *
3216 cgrad          do k=i+1,j-1
3217 cgrad            do l=1,3
3218 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3219 cgrad            enddo
3220 cgrad          enddo
3221 #else
3222           facvdw=ev1+evdwij
3223           facel=el1+eesij
3224           fac1=fac
3225           fac=-3*rrmij*(facvdw+facvdw+facel)
3226           erij(1)=xj*rmij
3227           erij(2)=yj*rmij
3228           erij(3)=zj*rmij
3229 *
3230 * Radial derivatives. First process both termini of the fragment (i,j)
3231 *
3232           ggg(1)=fac*xj
3233           ggg(2)=fac*yj
3234           ggg(3)=fac*zj
3235 c          do k=1,3
3236 c            ghalf=0.5D0*ggg(k)
3237 c            gelc(k,i)=gelc(k,i)+ghalf
3238 c            gelc(k,j)=gelc(k,j)+ghalf
3239 c          enddo
3240 c 9/28/08 AL Gradient compotents will be summed only at the end
3241           do k=1,3
3242             gelc_long(k,j)=gelc(k,j)+ggg(k)
3243             gelc_long(k,i)=gelc(k,i)-ggg(k)
3244           enddo
3245 *
3246 * Loop over residues i+1 thru j-1.
3247 *
3248 cgrad          do k=i+1,j-1
3249 cgrad            do l=1,3
3250 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3251 cgrad            enddo
3252 cgrad          enddo
3253 c 9/28/08 AL Gradient compotents will be summed only at the end
3254           ggg(1)=facvdw*xj
3255           ggg(2)=facvdw*yj
3256           ggg(3)=facvdw*zj
3257           do k=1,3
3258             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3259             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3260           enddo
3261 #endif
3262 *
3263 * Angular part
3264 *
3265           ecosa=2.0D0*fac3*fac1+fac4
3266           fac4=-3.0D0*fac4
3267           fac3=-6.0D0*fac3
3268           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3269           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3270           do k=1,3
3271             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3272             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3273           enddo
3274 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3275 cd   &          (dcosg(k),k=1,3)
3276           do k=1,3
3277             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3278           enddo
3279 c          do k=1,3
3280 c            ghalf=0.5D0*ggg(k)
3281 c            gelc(k,i)=gelc(k,i)+ghalf
3282 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3283 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3284 c            gelc(k,j)=gelc(k,j)+ghalf
3285 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3286 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3287 c          enddo
3288 cgrad          do k=i+1,j-1
3289 cgrad            do l=1,3
3290 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3291 cgrad            enddo
3292 cgrad          enddo
3293           do k=1,3
3294             gelc(k,i)=gelc(k,i)
3295      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3296      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3297             gelc(k,j)=gelc(k,j)
3298      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3299      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3300             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3301             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3302           enddo
3303           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3304      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3305      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3306 C
3307 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3308 C   energy of a peptide unit is assumed in the form of a second-order
3309 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3310 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3311 C   are computed for EVERY pair of non-contiguous peptide groups.
3312 C
3313           if (j.lt.nres-1) then
3314             j1=j+1
3315             j2=j-1
3316           else
3317             j1=j-1
3318             j2=j-2
3319           endif
3320           kkk=0
3321           do k=1,2
3322             do l=1,2
3323               kkk=kkk+1
3324               muij(kkk)=mu(k,i)*mu(l,j)
3325             enddo
3326           enddo
3327 cd         write (iout,*) 'EELEC: i',i,' j',j
3328 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3329 cd          write(iout,*) 'muij',muij
3330           ury=scalar(uy(1,i),erij)
3331           urz=scalar(uz(1,i),erij)
3332           vry=scalar(uy(1,j),erij)
3333           vrz=scalar(uz(1,j),erij)
3334           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3335           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3336           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3337           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3338           fac=dsqrt(-ael6i)*r3ij
3339           a22=a22*fac
3340           a23=a23*fac
3341           a32=a32*fac
3342           a33=a33*fac
3343 cd          write (iout,'(4i5,4f10.5)')
3344 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3345 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3346 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3347 cd     &      uy(:,j),uz(:,j)
3348 cd          write (iout,'(4f10.5)')
3349 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3350 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3351 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3352 cd           write (iout,'(9f10.5/)')
3353 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3354 C Derivatives of the elements of A in virtual-bond vectors
3355           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3356           do k=1,3
3357             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3358             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3359             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3360             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3361             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3362             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3363             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3364             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3365             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3366             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3367             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3368             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3369           enddo
3370 C Compute radial contributions to the gradient
3371           facr=-3.0d0*rrmij
3372           a22der=a22*facr
3373           a23der=a23*facr
3374           a32der=a32*facr
3375           a33der=a33*facr
3376           agg(1,1)=a22der*xj
3377           agg(2,1)=a22der*yj
3378           agg(3,1)=a22der*zj
3379           agg(1,2)=a23der*xj
3380           agg(2,2)=a23der*yj
3381           agg(3,2)=a23der*zj
3382           agg(1,3)=a32der*xj
3383           agg(2,3)=a32der*yj
3384           agg(3,3)=a32der*zj
3385           agg(1,4)=a33der*xj
3386           agg(2,4)=a33der*yj
3387           agg(3,4)=a33der*zj
3388 C Add the contributions coming from er
3389           fac3=-3.0d0*fac
3390           do k=1,3
3391             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3392             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3393             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3394             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3395           enddo
3396           do k=1,3
3397 C Derivatives in DC(i)
3398 cgrad            ghalf1=0.5d0*agg(k,1)
3399 cgrad            ghalf2=0.5d0*agg(k,2)
3400 cgrad            ghalf3=0.5d0*agg(k,3)
3401 cgrad            ghalf4=0.5d0*agg(k,4)
3402             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3403      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3404             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3405      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3406             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3407      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3408             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3409      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3410 C Derivatives in DC(i+1)
3411             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3412      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3413             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3414      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3415             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3416      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3417             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3418      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3419 C Derivatives in DC(j)
3420             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3421      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3422             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3423      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3424             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3425      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3426             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3427      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3428 C Derivatives in DC(j+1) or DC(nres-1)
3429             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3430      &      -3.0d0*vryg(k,3)*ury)
3431             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3432      &      -3.0d0*vrzg(k,3)*ury)
3433             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3434      &      -3.0d0*vryg(k,3)*urz)
3435             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3436      &      -3.0d0*vrzg(k,3)*urz)
3437 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3438 cgrad              do l=1,4
3439 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3440 cgrad              enddo
3441 cgrad            endif
3442           enddo
3443           acipa(1,1)=a22
3444           acipa(1,2)=a23
3445           acipa(2,1)=a32
3446           acipa(2,2)=a33
3447           a22=-a22
3448           a23=-a23
3449           do l=1,2
3450             do k=1,3
3451               agg(k,l)=-agg(k,l)
3452               aggi(k,l)=-aggi(k,l)
3453               aggi1(k,l)=-aggi1(k,l)
3454               aggj(k,l)=-aggj(k,l)
3455               aggj1(k,l)=-aggj1(k,l)
3456             enddo
3457           enddo
3458           if (j.lt.nres-1) then
3459             a22=-a22
3460             a32=-a32
3461             do l=1,3,2
3462               do k=1,3
3463                 agg(k,l)=-agg(k,l)
3464                 aggi(k,l)=-aggi(k,l)
3465                 aggi1(k,l)=-aggi1(k,l)
3466                 aggj(k,l)=-aggj(k,l)
3467                 aggj1(k,l)=-aggj1(k,l)
3468               enddo
3469             enddo
3470           else
3471             a22=-a22
3472             a23=-a23
3473             a32=-a32
3474             a33=-a33
3475             do l=1,4
3476               do k=1,3
3477                 agg(k,l)=-agg(k,l)
3478                 aggi(k,l)=-aggi(k,l)
3479                 aggi1(k,l)=-aggi1(k,l)
3480                 aggj(k,l)=-aggj(k,l)
3481                 aggj1(k,l)=-aggj1(k,l)
3482               enddo
3483             enddo
3484           endif
3485           ENDIF ! WCORR
3486           IF (wel_loc.gt.0.0d0) THEN
3487 C Contribution to the local-electrostatic energy coming from the i-j pair
3488           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3489      &     +a33*muij(4)
3490 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3491
3492           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3493      &            'eelloc',i,j,eel_loc_ij
3494
3495           eel_loc=eel_loc+eel_loc_ij
3496 C Partial derivatives in virtual-bond dihedral angles gamma
3497           if (i.gt.1)
3498      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3499      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3500      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3501           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3502      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3503      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3504 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3505           do l=1,3
3506             ggg(l)=agg(l,1)*muij(1)+
3507      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3508             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3509             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3510 cgrad            ghalf=0.5d0*ggg(l)
3511 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3512 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3513           enddo
3514 cgrad          do k=i+1,j2
3515 cgrad            do l=1,3
3516 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3517 cgrad            enddo
3518 cgrad          enddo
3519 C Remaining derivatives of eello
3520           do l=1,3
3521             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3522      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3523             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3524      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3525             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3526      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3527             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3528      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3529           enddo
3530           ENDIF
3531 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3532 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3533           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3534      &       .and. num_conti.le.maxconts) then
3535 c            write (iout,*) i,j," entered corr"
3536 C
3537 C Calculate the contact function. The ith column of the array JCONT will
3538 C contain the numbers of atoms that make contacts with the atom I (of numbers
3539 C greater than I). The arrays FACONT and GACONT will contain the values of
3540 C the contact function and its derivative.
3541 c           r0ij=1.02D0*rpp(iteli,itelj)
3542 c           r0ij=1.11D0*rpp(iteli,itelj)
3543             r0ij=2.20D0*rpp(iteli,itelj)
3544 c           r0ij=1.55D0*rpp(iteli,itelj)
3545             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3546             if (fcont.gt.0.0D0) then
3547               num_conti=num_conti+1
3548               if (num_conti.gt.maxconts) then
3549                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3550      &                         ' will skip next contacts for this conf.'
3551               else
3552                 jcont_hb(num_conti,i)=j
3553 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3554 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3555                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3556      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3557 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3558 C  terms.
3559                 d_cont(num_conti,i)=rij
3560 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3561 C     --- Electrostatic-interaction matrix ---
3562                 a_chuj(1,1,num_conti,i)=a22
3563                 a_chuj(1,2,num_conti,i)=a23
3564                 a_chuj(2,1,num_conti,i)=a32
3565                 a_chuj(2,2,num_conti,i)=a33
3566 C     --- Gradient of rij
3567                 do kkk=1,3
3568                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3569                 enddo
3570                 kkll=0
3571                 do k=1,2
3572                   do l=1,2
3573                     kkll=kkll+1
3574                     do m=1,3
3575                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3576                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3577                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3578                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3579                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3580                     enddo
3581                   enddo
3582                 enddo
3583                 ENDIF
3584                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3585 C Calculate contact energies
3586                 cosa4=4.0D0*cosa
3587                 wij=cosa-3.0D0*cosb*cosg
3588                 cosbg1=cosb+cosg
3589                 cosbg2=cosb-cosg
3590 c               fac3=dsqrt(-ael6i)/r0ij**3
3591                 fac3=dsqrt(-ael6i)*r3ij
3592 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3593                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3594                 if (ees0tmp.gt.0) then
3595                   ees0pij=dsqrt(ees0tmp)
3596                 else
3597                   ees0pij=0
3598                 endif
3599 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3600                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3601                 if (ees0tmp.gt.0) then
3602                   ees0mij=dsqrt(ees0tmp)
3603                 else
3604                   ees0mij=0
3605                 endif
3606 c               ees0mij=0.0D0
3607                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3608                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3609 C Diagnostics. Comment out or remove after debugging!
3610 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3611 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3612 c               ees0m(num_conti,i)=0.0D0
3613 C End diagnostics.
3614 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3615 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3616 C Angular derivatives of the contact function
3617                 ees0pij1=fac3/ees0pij
3618                 ees0mij1=fac3/ees0mij
3619                 fac3p=-3.0D0*fac3*rrmij
3620                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3621                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3622 c               ees0mij1=0.0D0
3623                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3624                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3625                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3626                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3627                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3628                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3629                 ecosap=ecosa1+ecosa2
3630                 ecosbp=ecosb1+ecosb2
3631                 ecosgp=ecosg1+ecosg2
3632                 ecosam=ecosa1-ecosa2
3633                 ecosbm=ecosb1-ecosb2
3634                 ecosgm=ecosg1-ecosg2
3635 C Diagnostics
3636 c               ecosap=ecosa1
3637 c               ecosbp=ecosb1
3638 c               ecosgp=ecosg1
3639 c               ecosam=0.0D0
3640 c               ecosbm=0.0D0
3641 c               ecosgm=0.0D0
3642 C End diagnostics
3643                 facont_hb(num_conti,i)=fcont
3644                 fprimcont=fprimcont/rij
3645 cd              facont_hb(num_conti,i)=1.0D0
3646 C Following line is for diagnostics.
3647 cd              fprimcont=0.0D0
3648                 do k=1,3
3649                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3650                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3651                 enddo
3652                 do k=1,3
3653                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3654                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3655                 enddo
3656                 gggp(1)=gggp(1)+ees0pijp*xj
3657                 gggp(2)=gggp(2)+ees0pijp*yj
3658                 gggp(3)=gggp(3)+ees0pijp*zj
3659                 gggm(1)=gggm(1)+ees0mijp*xj
3660                 gggm(2)=gggm(2)+ees0mijp*yj
3661                 gggm(3)=gggm(3)+ees0mijp*zj
3662 C Derivatives due to the contact function
3663                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3664                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3665                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3666                 do k=1,3
3667 c
3668 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3669 c          following the change of gradient-summation algorithm.
3670 c
3671 cgrad                  ghalfp=0.5D0*gggp(k)
3672 cgrad                  ghalfm=0.5D0*gggm(k)
3673                   gacontp_hb1(k,num_conti,i)=!ghalfp
3674      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3675      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3676                   gacontp_hb2(k,num_conti,i)=!ghalfp
3677      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3678      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3679                   gacontp_hb3(k,num_conti,i)=gggp(k)
3680                   gacontm_hb1(k,num_conti,i)=!ghalfm
3681      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3682      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3683                   gacontm_hb2(k,num_conti,i)=!ghalfm
3684      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3685      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3686                   gacontm_hb3(k,num_conti,i)=gggm(k)
3687                 enddo
3688 C Diagnostics. Comment out or remove after debugging!
3689 cdiag           do k=1,3
3690 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3691 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3692 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3693 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3694 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3695 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3696 cdiag           enddo
3697               ENDIF ! wcorr
3698               endif  ! num_conti.le.maxconts
3699             endif  ! fcont.gt.0
3700           endif    ! j.gt.i+1
3701           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3702             do k=1,4
3703               do l=1,3
3704                 ghalf=0.5d0*agg(l,k)
3705                 aggi(l,k)=aggi(l,k)+ghalf
3706                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3707                 aggj(l,k)=aggj(l,k)+ghalf
3708               enddo
3709             enddo
3710             if (j.eq.nres-1 .and. i.lt.j-2) then
3711               do k=1,4
3712                 do l=1,3
3713                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3714                 enddo
3715               enddo
3716             endif
3717           endif
3718 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3719       return
3720       end
3721 C-----------------------------------------------------------------------------
3722       subroutine eturn3(i,eello_turn3)
3723 C Third- and fourth-order contributions from turns
3724       implicit real*8 (a-h,o-z)
3725       include 'DIMENSIONS'
3726       include 'COMMON.IOUNITS'
3727       include 'COMMON.GEO'
3728       include 'COMMON.VAR'
3729       include 'COMMON.LOCAL'
3730       include 'COMMON.CHAIN'
3731       include 'COMMON.DERIV'
3732       include 'COMMON.INTERACT'
3733       include 'COMMON.CONTACTS'
3734       include 'COMMON.TORSION'
3735       include 'COMMON.VECTORS'
3736       include 'COMMON.FFIELD'
3737       include 'COMMON.CONTROL'
3738       dimension ggg(3)
3739       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3740      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3741      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3742       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3743      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3744       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3745      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3746      &    num_conti,j1,j2
3747       j=i+2
3748 c      write (iout,*) "eturn3",i,j,j1,j2
3749       a_temp(1,1)=a22
3750       a_temp(1,2)=a23
3751       a_temp(2,1)=a32
3752       a_temp(2,2)=a33
3753 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3754 C
3755 C               Third-order contributions
3756 C
3757 C                 (i+2)o----(i+3)
3758 C                      | |
3759 C                      | |
3760 C                 (i+1)o----i
3761 C
3762 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3763 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3764         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3765         call transpose2(auxmat(1,1),auxmat1(1,1))
3766         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3767         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3768         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3769      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3770 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3771 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3772 cd     &    ' eello_turn3_num',4*eello_turn3_num
3773 C Derivatives in gamma(i)
3774         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3775         call transpose2(auxmat2(1,1),auxmat3(1,1))
3776         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3777         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3778 C Derivatives in gamma(i+1)
3779         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3780         call transpose2(auxmat2(1,1),auxmat3(1,1))
3781         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3782         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3783      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3784 C Cartesian derivatives
3785         do l=1,3
3786 c            ghalf1=0.5d0*agg(l,1)
3787 c            ghalf2=0.5d0*agg(l,2)
3788 c            ghalf3=0.5d0*agg(l,3)
3789 c            ghalf4=0.5d0*agg(l,4)
3790           a_temp(1,1)=aggi(l,1)!+ghalf1
3791           a_temp(1,2)=aggi(l,2)!+ghalf2
3792           a_temp(2,1)=aggi(l,3)!+ghalf3
3793           a_temp(2,2)=aggi(l,4)!+ghalf4
3794           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3795           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3796      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3797           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3798           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3799           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3800           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3801           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3802           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3803      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3804           a_temp(1,1)=aggj(l,1)!+ghalf1
3805           a_temp(1,2)=aggj(l,2)!+ghalf2
3806           a_temp(2,1)=aggj(l,3)!+ghalf3
3807           a_temp(2,2)=aggj(l,4)!+ghalf4
3808           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3809           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3810      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3811           a_temp(1,1)=aggj1(l,1)
3812           a_temp(1,2)=aggj1(l,2)
3813           a_temp(2,1)=aggj1(l,3)
3814           a_temp(2,2)=aggj1(l,4)
3815           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3816           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3817      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3818         enddo
3819       return
3820       end
3821 C-------------------------------------------------------------------------------
3822       subroutine eturn4(i,eello_turn4)
3823 C Third- and fourth-order contributions from turns
3824       implicit real*8 (a-h,o-z)
3825       include 'DIMENSIONS'
3826       include 'COMMON.IOUNITS'
3827       include 'COMMON.GEO'
3828       include 'COMMON.VAR'
3829       include 'COMMON.LOCAL'
3830       include 'COMMON.CHAIN'
3831       include 'COMMON.DERIV'
3832       include 'COMMON.INTERACT'
3833       include 'COMMON.CONTACTS'
3834       include 'COMMON.TORSION'
3835       include 'COMMON.VECTORS'
3836       include 'COMMON.FFIELD'
3837       include 'COMMON.CONTROL'
3838       dimension ggg(3)
3839       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3840      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3841      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3842       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3843      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3844       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3845      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3846      &    num_conti,j1,j2
3847       j=i+3
3848 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3849 C
3850 C               Fourth-order contributions
3851 C
3852 C                 (i+3)o----(i+4)
3853 C                     /  |
3854 C               (i+2)o   |
3855 C                     \  |
3856 C                 (i+1)o----i
3857 C
3858 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3859 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3860 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3861         a_temp(1,1)=a22
3862         a_temp(1,2)=a23
3863         a_temp(2,1)=a32
3864         a_temp(2,2)=a33
3865         iti1=itortyp(itype(i+1))
3866         iti2=itortyp(itype(i+2))
3867         iti3=itortyp(itype(i+3))
3868 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3869         call transpose2(EUg(1,1,i+1),e1t(1,1))
3870         call transpose2(Eug(1,1,i+2),e2t(1,1))
3871         call transpose2(Eug(1,1,i+3),e3t(1,1))
3872         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3873         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3874         s1=scalar2(b1(1,iti2),auxvec(1))
3875         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3876         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3877         s2=scalar2(b1(1,iti1),auxvec(1))
3878         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3879         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3880         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3881         eello_turn4=eello_turn4-(s1+s2+s3)
3882         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3883      &      'eturn4',i,j,-(s1+s2+s3)
3884 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3885 cd     &    ' eello_turn4_num',8*eello_turn4_num
3886 C Derivatives in gamma(i)
3887         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3888         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3889         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3890         s1=scalar2(b1(1,iti2),auxvec(1))
3891         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3892         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3893         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3894 C Derivatives in gamma(i+1)
3895         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3896         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3897         s2=scalar2(b1(1,iti1),auxvec(1))
3898         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3899         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3900         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3901         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3902 C Derivatives in gamma(i+2)
3903         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3904         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3905         s1=scalar2(b1(1,iti2),auxvec(1))
3906         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3907         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3908         s2=scalar2(b1(1,iti1),auxvec(1))
3909         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3910         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3911         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3912         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3913 C Cartesian derivatives
3914 C Derivatives of this turn contributions in DC(i+2)
3915         if (j.lt.nres-1) then
3916           do l=1,3
3917             a_temp(1,1)=agg(l,1)
3918             a_temp(1,2)=agg(l,2)
3919             a_temp(2,1)=agg(l,3)
3920             a_temp(2,2)=agg(l,4)
3921             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3922             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3923             s1=scalar2(b1(1,iti2),auxvec(1))
3924             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3925             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3926             s2=scalar2(b1(1,iti1),auxvec(1))
3927             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3928             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3929             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3930             ggg(l)=-(s1+s2+s3)
3931             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3932           enddo
3933         endif
3934 C Remaining derivatives of this turn contribution
3935         do l=1,3
3936           a_temp(1,1)=aggi(l,1)
3937           a_temp(1,2)=aggi(l,2)
3938           a_temp(2,1)=aggi(l,3)
3939           a_temp(2,2)=aggi(l,4)
3940           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3941           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3942           s1=scalar2(b1(1,iti2),auxvec(1))
3943           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3944           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3945           s2=scalar2(b1(1,iti1),auxvec(1))
3946           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3947           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3948           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3949           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3950           a_temp(1,1)=aggi1(l,1)
3951           a_temp(1,2)=aggi1(l,2)
3952           a_temp(2,1)=aggi1(l,3)
3953           a_temp(2,2)=aggi1(l,4)
3954           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3955           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3956           s1=scalar2(b1(1,iti2),auxvec(1))
3957           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3958           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3959           s2=scalar2(b1(1,iti1),auxvec(1))
3960           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3961           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3962           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3963           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3964           a_temp(1,1)=aggj(l,1)
3965           a_temp(1,2)=aggj(l,2)
3966           a_temp(2,1)=aggj(l,3)
3967           a_temp(2,2)=aggj(l,4)
3968           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3969           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3970           s1=scalar2(b1(1,iti2),auxvec(1))
3971           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3972           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3973           s2=scalar2(b1(1,iti1),auxvec(1))
3974           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3975           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3976           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3977           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3978           a_temp(1,1)=aggj1(l,1)
3979           a_temp(1,2)=aggj1(l,2)
3980           a_temp(2,1)=aggj1(l,3)
3981           a_temp(2,2)=aggj1(l,4)
3982           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3983           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3984           s1=scalar2(b1(1,iti2),auxvec(1))
3985           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3986           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3987           s2=scalar2(b1(1,iti1),auxvec(1))
3988           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3989           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3990           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3991 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3992           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3993         enddo
3994       return
3995       end
3996 C-----------------------------------------------------------------------------
3997       subroutine vecpr(u,v,w)
3998       implicit real*8(a-h,o-z)
3999       dimension u(3),v(3),w(3)
4000       w(1)=u(2)*v(3)-u(3)*v(2)
4001       w(2)=-u(1)*v(3)+u(3)*v(1)
4002       w(3)=u(1)*v(2)-u(2)*v(1)
4003       return
4004       end
4005 C-----------------------------------------------------------------------------
4006       subroutine unormderiv(u,ugrad,unorm,ungrad)
4007 C This subroutine computes the derivatives of a normalized vector u, given
4008 C the derivatives computed without normalization conditions, ugrad. Returns
4009 C ungrad.
4010       implicit none
4011       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4012       double precision vec(3)
4013       double precision scalar
4014       integer i,j
4015 c      write (2,*) 'ugrad',ugrad
4016 c      write (2,*) 'u',u
4017       do i=1,3
4018         vec(i)=scalar(ugrad(1,i),u(1))
4019       enddo
4020 c      write (2,*) 'vec',vec
4021       do i=1,3
4022         do j=1,3
4023           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4024         enddo
4025       enddo
4026 c      write (2,*) 'ungrad',ungrad
4027       return
4028       end
4029 C-----------------------------------------------------------------------------
4030       subroutine escp_soft_sphere(evdw2,evdw2_14)
4031 C
4032 C This subroutine calculates the excluded-volume interaction energy between
4033 C peptide-group centers and side chains and its gradient in virtual-bond and
4034 C side-chain vectors.
4035 C
4036       implicit real*8 (a-h,o-z)
4037       include 'DIMENSIONS'
4038       include 'COMMON.GEO'
4039       include 'COMMON.VAR'
4040       include 'COMMON.LOCAL'
4041       include 'COMMON.CHAIN'
4042       include 'COMMON.DERIV'
4043       include 'COMMON.INTERACT'
4044       include 'COMMON.FFIELD'
4045       include 'COMMON.IOUNITS'
4046       include 'COMMON.CONTROL'
4047       dimension ggg(3)
4048       evdw2=0.0D0
4049       evdw2_14=0.0d0
4050       r0_scp=4.5d0
4051 cd    print '(a)','Enter ESCP'
4052 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4053       do i=iatscp_s,iatscp_e
4054         iteli=itel(i)
4055         xi=0.5D0*(c(1,i)+c(1,i+1))
4056         yi=0.5D0*(c(2,i)+c(2,i+1))
4057         zi=0.5D0*(c(3,i)+c(3,i+1))
4058
4059         do iint=1,nscp_gr(i)
4060
4061         do j=iscpstart(i,iint),iscpend(i,iint)
4062           itypj=itype(j)
4063 C Uncomment following three lines for SC-p interactions
4064 c         xj=c(1,nres+j)-xi
4065 c         yj=c(2,nres+j)-yi
4066 c         zj=c(3,nres+j)-zi
4067 C Uncomment following three lines for Ca-p interactions
4068           xj=c(1,j)-xi
4069           yj=c(2,j)-yi
4070           zj=c(3,j)-zi
4071           rij=xj*xj+yj*yj+zj*zj
4072           r0ij=r0_scp
4073           r0ijsq=r0ij*r0ij
4074           if (rij.lt.r0ijsq) then
4075             evdwij=0.25d0*(rij-r0ijsq)**2
4076             fac=rij-r0ijsq
4077           else
4078             evdwij=0.0d0
4079             fac=0.0d0
4080           endif
4081           evdw2=evdw2+evdwij
4082 C
4083 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4084 C
4085           ggg(1)=xj*fac
4086           ggg(2)=yj*fac
4087           ggg(3)=zj*fac
4088 cgrad          if (j.lt.i) then
4089 cd          write (iout,*) 'j<i'
4090 C Uncomment following three lines for SC-p interactions
4091 c           do k=1,3
4092 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4093 c           enddo
4094 cgrad          else
4095 cd          write (iout,*) 'j>i'
4096 cgrad            do k=1,3
4097 cgrad              ggg(k)=-ggg(k)
4098 C Uncomment following line for SC-p interactions
4099 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4100 cgrad            enddo
4101 cgrad          endif
4102 cgrad          do k=1,3
4103 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4104 cgrad          enddo
4105 cgrad          kstart=min0(i+1,j)
4106 cgrad          kend=max0(i-1,j-1)
4107 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4108 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4109 cgrad          do k=kstart,kend
4110 cgrad            do l=1,3
4111 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4112 cgrad            enddo
4113 cgrad          enddo
4114           do k=1,3
4115             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4116             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4117           enddo
4118         enddo
4119
4120         enddo ! iint
4121       enddo ! i
4122       return
4123       end
4124 C-----------------------------------------------------------------------------
4125       subroutine escp(evdw2,evdw2_14)
4126 C
4127 C This subroutine calculates the excluded-volume interaction energy between
4128 C peptide-group centers and side chains and its gradient in virtual-bond and
4129 C side-chain vectors.
4130 C
4131       implicit real*8 (a-h,o-z)
4132       include 'DIMENSIONS'
4133       include 'COMMON.GEO'
4134       include 'COMMON.VAR'
4135       include 'COMMON.LOCAL'
4136       include 'COMMON.CHAIN'
4137       include 'COMMON.DERIV'
4138       include 'COMMON.INTERACT'
4139       include 'COMMON.FFIELD'
4140       include 'COMMON.IOUNITS'
4141       include 'COMMON.CONTROL'
4142       dimension ggg(3)
4143       evdw2=0.0D0
4144       evdw2_14=0.0d0
4145 cd    print '(a)','Enter ESCP'
4146 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4147       do i=iatscp_s,iatscp_e
4148         iteli=itel(i)
4149         xi=0.5D0*(c(1,i)+c(1,i+1))
4150         yi=0.5D0*(c(2,i)+c(2,i+1))
4151         zi=0.5D0*(c(3,i)+c(3,i+1))
4152
4153         do iint=1,nscp_gr(i)
4154
4155         do j=iscpstart(i,iint),iscpend(i,iint)
4156           itypj=itype(j)
4157 C Uncomment following three lines for SC-p interactions
4158 c         xj=c(1,nres+j)-xi
4159 c         yj=c(2,nres+j)-yi
4160 c         zj=c(3,nres+j)-zi
4161 C Uncomment following three lines for Ca-p interactions
4162           xj=c(1,j)-xi
4163           yj=c(2,j)-yi
4164           zj=c(3,j)-zi
4165           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4166           fac=rrij**expon2
4167           e1=fac*fac*aad(itypj,iteli)
4168           e2=fac*bad(itypj,iteli)
4169           if (iabs(j-i) .le. 2) then
4170             e1=scal14*e1
4171             e2=scal14*e2
4172             evdw2_14=evdw2_14+e1+e2
4173           endif
4174           evdwij=e1+e2
4175           evdw2=evdw2+evdwij
4176           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4177      &        'evdw2',i,j,evdwij
4178 C
4179 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4180 C
4181           fac=-(evdwij+e1)*rrij
4182           ggg(1)=xj*fac
4183           ggg(2)=yj*fac
4184           ggg(3)=zj*fac
4185 cgrad          if (j.lt.i) then
4186 cd          write (iout,*) 'j<i'
4187 C Uncomment following three lines for SC-p interactions
4188 c           do k=1,3
4189 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4190 c           enddo
4191 cgrad          else
4192 cd          write (iout,*) 'j>i'
4193 cgrad            do k=1,3
4194 cgrad              ggg(k)=-ggg(k)
4195 C Uncomment following line for SC-p interactions
4196 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4197 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4198 cgrad            enddo
4199 cgrad          endif
4200 cgrad          do k=1,3
4201 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4202 cgrad          enddo
4203 cgrad          kstart=min0(i+1,j)
4204 cgrad          kend=max0(i-1,j-1)
4205 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4206 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4207 cgrad          do k=kstart,kend
4208 cgrad            do l=1,3
4209 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4210 cgrad            enddo
4211 cgrad          enddo
4212           do k=1,3
4213             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4214             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4215           enddo
4216         enddo
4217
4218         enddo ! iint
4219       enddo ! i
4220       do i=1,nct
4221         do j=1,3
4222           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4223           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4224           gradx_scp(j,i)=expon*gradx_scp(j,i)
4225         enddo
4226       enddo
4227 C******************************************************************************
4228 C
4229 C                              N O T E !!!
4230 C
4231 C To save time the factor EXPON has been extracted from ALL components
4232 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4233 C use!
4234 C
4235 C******************************************************************************
4236       return
4237       end
4238 C--------------------------------------------------------------------------
4239       subroutine edis(ehpb)
4240 C
4241 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4242 C
4243       implicit real*8 (a-h,o-z)
4244       include 'DIMENSIONS'
4245       include 'COMMON.SBRIDGE'
4246       include 'COMMON.CHAIN'
4247       include 'COMMON.DERIV'
4248       include 'COMMON.VAR'
4249       include 'COMMON.INTERACT'
4250       include 'COMMON.IOUNITS'
4251       dimension ggg(3)
4252       ehpb=0.0D0
4253 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4254 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4255       if (link_end.eq.0) return
4256       do i=link_start,link_end
4257 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4258 C CA-CA distance used in regularization of structure.
4259         ii=ihpb(i)
4260         jj=jhpb(i)
4261 C iii and jjj point to the residues for which the distance is assigned.
4262         if (ii.gt.nres) then
4263           iii=ii-nres
4264           jjj=jj-nres
4265         else
4266           iii=ii
4267           jjj=jj
4268         endif
4269 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. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4274           call ssbond_ene(iii,jjj,eij)
4275           ehpb=ehpb+2*eij
4276 cd          write (iout,*) "eij",eij
4277         else if (ii.gt.nres .and. jj.gt.nres) then
4278 c Restraints from contact prediction
4279           dd=dist(ii,jj)
4280           if (dhpb1(i).gt.0.0d0) then
4281             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4282             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4283 c            write (iout,*) "beta nmr",
4284 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4285           else
4286             dd=dist(ii,jj)
4287             rdis=dd-dhpb(i)
4288 C Get the force constant corresponding to this distance.
4289             waga=forcon(i)
4290 C Calculate the contribution to energy.
4291             ehpb=ehpb+waga*rdis*rdis
4292 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
4293 C
4294 C Evaluate gradient.
4295 C
4296             fac=waga*rdis/dd
4297           endif
4298           do j=1,3
4299             ggg(j)=fac*(c(j,jj)-c(j,ii))
4300           enddo
4301           do j=1,3
4302             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4303             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4304           enddo
4305           do k=1,3
4306             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4307             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4308           enddo
4309         else
4310 C Calculate the distance between the two points and its difference from the
4311 C target distance.
4312           dd=dist(ii,jj)
4313           if (dhpb1(i).gt.0.0d0) then
4314             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4315             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4316 c            write (iout,*) "alph nmr",
4317 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4318           else
4319             rdis=dd-dhpb(i)
4320 C Get the force constant corresponding to this distance.
4321             waga=forcon(i)
4322 C Calculate the contribution to energy.
4323             ehpb=ehpb+waga*rdis*rdis
4324 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
4325 C
4326 C Evaluate gradient.
4327 C
4328             fac=waga*rdis/dd
4329           endif
4330 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4331 cd   &   ' waga=',waga,' fac=',fac
4332             do j=1,3
4333               ggg(j)=fac*(c(j,jj)-c(j,ii))
4334             enddo
4335 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4336 C If this is a SC-SC distance, we need to calculate the contributions to the
4337 C Cartesian gradient in the SC vectors (ghpbx).
4338           if (iii.lt.ii) then
4339           do j=1,3
4340             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4341             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4342           enddo
4343           endif
4344 cgrad        do j=iii,jjj-1
4345 cgrad          do k=1,3
4346 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4347 cgrad          enddo
4348 cgrad        enddo
4349           do k=1,3
4350             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4351             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4352           enddo
4353         endif
4354       enddo
4355       ehpb=0.5D0*ehpb
4356       return
4357       end
4358 C--------------------------------------------------------------------------
4359       subroutine ssbond_ene(i,j,eij)
4360 C
4361 C Calculate the distance and angle dependent SS-bond potential energy
4362 C using a free-energy function derived based on RHF/6-31G** ab initio
4363 C calculations of diethyl disulfide.
4364 C
4365 C A. Liwo and U. Kozlowska, 11/24/03
4366 C
4367       implicit real*8 (a-h,o-z)
4368       include 'DIMENSIONS'
4369       include 'COMMON.SBRIDGE'
4370       include 'COMMON.CHAIN'
4371       include 'COMMON.DERIV'
4372       include 'COMMON.LOCAL'
4373       include 'COMMON.INTERACT'
4374       include 'COMMON.VAR'
4375       include 'COMMON.IOUNITS'
4376       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4377       itypi=itype(i)
4378       xi=c(1,nres+i)
4379       yi=c(2,nres+i)
4380       zi=c(3,nres+i)
4381       dxi=dc_norm(1,nres+i)
4382       dyi=dc_norm(2,nres+i)
4383       dzi=dc_norm(3,nres+i)
4384 c      dsci_inv=dsc_inv(itypi)
4385       dsci_inv=vbld_inv(nres+i)
4386       itypj=itype(j)
4387 c      dscj_inv=dsc_inv(itypj)
4388       dscj_inv=vbld_inv(nres+j)
4389       xj=c(1,nres+j)-xi
4390       yj=c(2,nres+j)-yi
4391       zj=c(3,nres+j)-zi
4392       dxj=dc_norm(1,nres+j)
4393       dyj=dc_norm(2,nres+j)
4394       dzj=dc_norm(3,nres+j)
4395       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4396       rij=dsqrt(rrij)
4397       erij(1)=xj*rij
4398       erij(2)=yj*rij
4399       erij(3)=zj*rij
4400       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4401       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4402       om12=dxi*dxj+dyi*dyj+dzi*dzj
4403       do k=1,3
4404         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4405         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4406       enddo
4407       rij=1.0d0/rij
4408       deltad=rij-d0cm
4409       deltat1=1.0d0-om1
4410       deltat2=1.0d0+om2
4411       deltat12=om2-om1+2.0d0
4412       cosphi=om12-om1*om2
4413       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4414      &  +akct*deltad*deltat12
4415      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4416 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4417 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4418 c     &  " deltat12",deltat12," eij",eij
4419       ed=2*akcm*deltad+akct*deltat12
4420       pom1=akct*deltad
4421       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4422       eom1=-2*akth*deltat1-pom1-om2*pom2
4423       eom2= 2*akth*deltat2+pom1-om1*pom2
4424       eom12=pom2
4425       do k=1,3
4426         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4427         ghpbx(k,i)=ghpbx(k,i)-ggk
4428      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4429      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4430         ghpbx(k,j)=ghpbx(k,j)+ggk
4431      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4432      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4433         ghpbc(k,i)=ghpbc(k,i)-ggk
4434         ghpbc(k,j)=ghpbc(k,j)+ggk
4435       enddo
4436 C
4437 C Calculate the components of the gradient in DC and X
4438 C
4439 cgrad      do k=i,j-1
4440 cgrad        do l=1,3
4441 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4442 cgrad        enddo
4443 cgrad      enddo
4444       return
4445       end
4446 C--------------------------------------------------------------------------
4447       subroutine ebond(estr)
4448 c
4449 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4450 c
4451       implicit real*8 (a-h,o-z)
4452       include 'DIMENSIONS'
4453       include 'COMMON.LOCAL'
4454       include 'COMMON.GEO'
4455       include 'COMMON.INTERACT'
4456       include 'COMMON.DERIV'
4457       include 'COMMON.VAR'
4458       include 'COMMON.CHAIN'
4459       include 'COMMON.IOUNITS'
4460       include 'COMMON.NAMES'
4461       include 'COMMON.FFIELD'
4462       include 'COMMON.CONTROL'
4463       include 'COMMON.SETUP'
4464       double precision u(3),ud(3)
4465       estr=0.0d0
4466       do i=ibondp_start,ibondp_end
4467         diff = vbld(i)-vbldp0
4468 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4469         estr=estr+diff*diff
4470         do j=1,3
4471           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4472         enddo
4473 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4474       enddo
4475       estr=0.5d0*AKP*estr
4476 c
4477 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4478 c
4479       do i=ibond_start,ibond_end
4480         iti=itype(i)
4481         if (iti.ne.10) then
4482           nbi=nbondterm(iti)
4483           if (nbi.eq.1) then
4484             diff=vbld(i+nres)-vbldsc0(1,iti)
4485 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4486 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4487             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4488             do j=1,3
4489               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4490             enddo
4491           else
4492             do j=1,nbi
4493               diff=vbld(i+nres)-vbldsc0(j,iti)
4494               ud(j)=aksc(j,iti)*diff
4495               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4496             enddo
4497             uprod=u(1)
4498             do j=2,nbi
4499               uprod=uprod*u(j)
4500             enddo
4501             usum=0.0d0
4502             usumsqder=0.0d0
4503             do j=1,nbi
4504               uprod1=1.0d0
4505               uprod2=1.0d0
4506               do k=1,nbi
4507                 if (k.ne.j) then
4508                   uprod1=uprod1*u(k)
4509                   uprod2=uprod2*u(k)*u(k)
4510                 endif
4511               enddo
4512               usum=usum+uprod1
4513               usumsqder=usumsqder+ud(j)*uprod2
4514             enddo
4515             estr=estr+uprod/usum
4516             do j=1,3
4517              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4518             enddo
4519           endif
4520         endif
4521       enddo
4522       return
4523       end
4524 #ifdef CRYST_THETA
4525 C--------------------------------------------------------------------------
4526       subroutine ebend(etheta)
4527 C
4528 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4529 C angles gamma and its derivatives in consecutive thetas and gammas.
4530 C
4531       implicit real*8 (a-h,o-z)
4532       include 'DIMENSIONS'
4533       include 'COMMON.LOCAL'
4534       include 'COMMON.GEO'
4535       include 'COMMON.INTERACT'
4536       include 'COMMON.DERIV'
4537       include 'COMMON.VAR'
4538       include 'COMMON.CHAIN'
4539       include 'COMMON.IOUNITS'
4540       include 'COMMON.NAMES'
4541       include 'COMMON.FFIELD'
4542       include 'COMMON.CONTROL'
4543       common /calcthet/ term1,term2,termm,diffak,ratak,
4544      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4545      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4546       double precision y(2),z(2)
4547       delta=0.02d0*pi
4548 c      time11=dexp(-2*time)
4549 c      time12=1.0d0
4550       etheta=0.0D0
4551 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4552       do i=ithet_start,ithet_end
4553 C Zero the energy function and its derivative at 0 or pi.
4554         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4555         it=itype(i-1)
4556         if (i.gt.3) then
4557 #ifdef OSF
4558           phii=phi(i)
4559           if (phii.ne.phii) phii=150.0
4560 #else
4561           phii=phi(i)
4562 #endif
4563           y(1)=dcos(phii)
4564           y(2)=dsin(phii)
4565         else
4566           y(1)=0.0D0
4567           y(2)=0.0D0
4568         endif
4569         if (i.lt.nres) then
4570 #ifdef OSF
4571           phii1=phi(i+1)
4572           if (phii1.ne.phii1) phii1=150.0
4573           phii1=pinorm(phii1)
4574           z(1)=cos(phii1)
4575 #else
4576           phii1=phi(i+1)
4577           z(1)=dcos(phii1)
4578 #endif
4579           z(2)=dsin(phii1)
4580         else
4581           z(1)=0.0D0
4582           z(2)=0.0D0
4583         endif
4584 C Calculate the "mean" value of theta from the part of the distribution
4585 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4586 C In following comments this theta will be referred to as t_c.
4587         thet_pred_mean=0.0d0
4588         do k=1,2
4589           athetk=athet(k,it)
4590           bthetk=bthet(k,it)
4591           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4592         enddo
4593         dthett=thet_pred_mean*ssd
4594         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4595 C Derivatives of the "mean" values in gamma1 and gamma2.
4596         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
4597         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
4598         if (theta(i).gt.pi-delta) then
4599           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4600      &         E_tc0)
4601           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4602           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4603           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4604      &        E_theta)
4605           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4606      &        E_tc)
4607         else if (theta(i).lt.delta) then
4608           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4609           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4610           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4611      &        E_theta)
4612           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4613           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4614      &        E_tc)
4615         else
4616           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4617      &        E_theta,E_tc)
4618         endif
4619         etheta=etheta+ethetai
4620         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4621      &      'ebend',i,ethetai
4622         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4623         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4624         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4625       enddo
4626 C Ufff.... We've done all this!!!
4627       return
4628       end
4629 C---------------------------------------------------------------------------
4630       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4631      &     E_tc)
4632       implicit real*8 (a-h,o-z)
4633       include 'DIMENSIONS'
4634       include 'COMMON.LOCAL'
4635       include 'COMMON.IOUNITS'
4636       common /calcthet/ term1,term2,termm,diffak,ratak,
4637      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4638      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4639 C Calculate the contributions to both Gaussian lobes.
4640 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4641 C The "polynomial part" of the "standard deviation" of this part of
4642 C the distribution.
4643         sig=polthet(3,it)
4644         do j=2,0,-1
4645           sig=sig*thet_pred_mean+polthet(j,it)
4646         enddo
4647 C Derivative of the "interior part" of the "standard deviation of the"
4648 C gamma-dependent Gaussian lobe in t_c.
4649         sigtc=3*polthet(3,it)
4650         do j=2,1,-1
4651           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4652         enddo
4653         sigtc=sig*sigtc
4654 C Set the parameters of both Gaussian lobes of the distribution.
4655 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4656         fac=sig*sig+sigc0(it)
4657         sigcsq=fac+fac
4658         sigc=1.0D0/sigcsq
4659 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4660         sigsqtc=-4.0D0*sigcsq*sigtc
4661 c       print *,i,sig,sigtc,sigsqtc
4662 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4663         sigtc=-sigtc/(fac*fac)
4664 C Following variable is sigma(t_c)**(-2)
4665         sigcsq=sigcsq*sigcsq
4666         sig0i=sig0(it)
4667         sig0inv=1.0D0/sig0i**2
4668         delthec=thetai-thet_pred_mean
4669         delthe0=thetai-theta0i
4670         term1=-0.5D0*sigcsq*delthec*delthec
4671         term2=-0.5D0*sig0inv*delthe0*delthe0
4672 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4673 C NaNs in taking the logarithm. We extract the largest exponent which is added
4674 C to the energy (this being the log of the distribution) at the end of energy
4675 C term evaluation for this virtual-bond angle.
4676         if (term1.gt.term2) then
4677           termm=term1
4678           term2=dexp(term2-termm)
4679           term1=1.0d0
4680         else
4681           termm=term2
4682           term1=dexp(term1-termm)
4683           term2=1.0d0
4684         endif
4685 C The ratio between the gamma-independent and gamma-dependent lobes of
4686 C the distribution is a Gaussian function of thet_pred_mean too.
4687         diffak=gthet(2,it)-thet_pred_mean
4688         ratak=diffak/gthet(3,it)**2
4689         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4690 C Let's differentiate it in thet_pred_mean NOW.
4691         aktc=ak*ratak
4692 C Now put together the distribution terms to make complete distribution.
4693         termexp=term1+ak*term2
4694         termpre=sigc+ak*sig0i
4695 C Contribution of the bending energy from this theta is just the -log of
4696 C the sum of the contributions from the two lobes and the pre-exponential
4697 C factor. Simple enough, isn't it?
4698         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4699 C NOW the derivatives!!!
4700 C 6/6/97 Take into account the deformation.
4701         E_theta=(delthec*sigcsq*term1
4702      &       +ak*delthe0*sig0inv*term2)/termexp
4703         E_tc=((sigtc+aktc*sig0i)/termpre
4704      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4705      &       aktc*term2)/termexp)
4706       return
4707       end
4708 c-----------------------------------------------------------------------------
4709       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4710       implicit real*8 (a-h,o-z)
4711       include 'DIMENSIONS'
4712       include 'COMMON.LOCAL'
4713       include 'COMMON.IOUNITS'
4714       common /calcthet/ term1,term2,termm,diffak,ratak,
4715      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4716      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4717       delthec=thetai-thet_pred_mean
4718       delthe0=thetai-theta0i
4719 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4720       t3 = thetai-thet_pred_mean
4721       t6 = t3**2
4722       t9 = term1
4723       t12 = t3*sigcsq
4724       t14 = t12+t6*sigsqtc
4725       t16 = 1.0d0
4726       t21 = thetai-theta0i
4727       t23 = t21**2
4728       t26 = term2
4729       t27 = t21*t26
4730       t32 = termexp
4731       t40 = t32**2
4732       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4733      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4734      & *(-t12*t9-ak*sig0inv*t27)
4735       return
4736       end
4737 #else
4738 C--------------------------------------------------------------------------
4739       subroutine ebend(etheta)
4740 C
4741 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4742 C angles gamma and its derivatives in consecutive thetas and gammas.
4743 C ab initio-derived potentials from
4744 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4745 C
4746       implicit real*8 (a-h,o-z)
4747       include 'DIMENSIONS'
4748       include 'COMMON.LOCAL'
4749       include 'COMMON.GEO'
4750       include 'COMMON.INTERACT'
4751       include 'COMMON.DERIV'
4752       include 'COMMON.VAR'
4753       include 'COMMON.CHAIN'
4754       include 'COMMON.IOUNITS'
4755       include 'COMMON.NAMES'
4756       include 'COMMON.FFIELD'
4757       include 'COMMON.CONTROL'
4758       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4759      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4760      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4761      & sinph1ph2(maxdouble,maxdouble)
4762       logical lprn /.false./, lprn1 /.false./
4763       etheta=0.0D0
4764       do i=ithet_start,ithet_end
4765         dethetai=0.0d0
4766         dephii=0.0d0
4767         dephii1=0.0d0
4768         theti2=0.5d0*theta(i)
4769         ityp2=ithetyp(itype(i-1))
4770         do k=1,nntheterm
4771           coskt(k)=dcos(k*theti2)
4772           sinkt(k)=dsin(k*theti2)
4773         enddo
4774         if (i.gt.3) then
4775 #ifdef OSF
4776           phii=phi(i)
4777           if (phii.ne.phii) phii=150.0
4778 #else
4779           phii=phi(i)
4780 #endif
4781           ityp1=ithetyp(itype(i-2))
4782           do k=1,nsingle
4783             cosph1(k)=dcos(k*phii)
4784             sinph1(k)=dsin(k*phii)
4785           enddo
4786         else
4787           phii=0.0d0
4788           ityp1=nthetyp+1
4789           do k=1,nsingle
4790             cosph1(k)=0.0d0
4791             sinph1(k)=0.0d0
4792           enddo
4793         endif
4794         if (i.lt.nres) then
4795 #ifdef OSF
4796           phii1=phi(i+1)
4797           if (phii1.ne.phii1) phii1=150.0
4798           phii1=pinorm(phii1)
4799 #else
4800           phii1=phi(i+1)
4801 #endif
4802           ityp3=ithetyp(itype(i))
4803           do k=1,nsingle
4804             cosph2(k)=dcos(k*phii1)
4805             sinph2(k)=dsin(k*phii1)
4806           enddo
4807         else
4808           phii1=0.0d0
4809           ityp3=nthetyp+1
4810           do k=1,nsingle
4811             cosph2(k)=0.0d0
4812             sinph2(k)=0.0d0
4813           enddo
4814         endif
4815         ethetai=aa0thet(ityp1,ityp2,ityp3)
4816         do k=1,ndouble
4817           do l=1,k-1
4818             ccl=cosph1(l)*cosph2(k-l)
4819             ssl=sinph1(l)*sinph2(k-l)
4820             scl=sinph1(l)*cosph2(k-l)
4821             csl=cosph1(l)*sinph2(k-l)
4822             cosph1ph2(l,k)=ccl-ssl
4823             cosph1ph2(k,l)=ccl+ssl
4824             sinph1ph2(l,k)=scl+csl
4825             sinph1ph2(k,l)=scl-csl
4826           enddo
4827         enddo
4828         if (lprn) then
4829         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4830      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4831         write (iout,*) "coskt and sinkt"
4832         do k=1,nntheterm
4833           write (iout,*) k,coskt(k),sinkt(k)
4834         enddo
4835         endif
4836         do k=1,ntheterm
4837           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4838           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4839      &      *coskt(k)
4840           if (lprn)
4841      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4842      &     " ethetai",ethetai
4843         enddo
4844         if (lprn) then
4845         write (iout,*) "cosph and sinph"
4846         do k=1,nsingle
4847           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4848         enddo
4849         write (iout,*) "cosph1ph2 and sinph2ph2"
4850         do k=2,ndouble
4851           do l=1,k-1
4852             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4853      &         sinph1ph2(l,k),sinph1ph2(k,l)
4854           enddo
4855         enddo
4856         write(iout,*) "ethetai",ethetai
4857         endif
4858         do m=1,ntheterm2
4859           do k=1,nsingle
4860             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4861      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4862      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4863      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4864             ethetai=ethetai+sinkt(m)*aux
4865             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4866             dephii=dephii+k*sinkt(m)*(
4867      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4868      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4869             dephii1=dephii1+k*sinkt(m)*(
4870      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4871      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4872             if (lprn)
4873      &      write (iout,*) "m",m," k",k," bbthet",
4874      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4875      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4876      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4877      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4878           enddo
4879         enddo
4880         if (lprn)
4881      &  write(iout,*) "ethetai",ethetai
4882         do m=1,ntheterm3
4883           do k=2,ndouble
4884             do l=1,k-1
4885               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4886      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4887      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4888      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4889               ethetai=ethetai+sinkt(m)*aux
4890               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4891               dephii=dephii+l*sinkt(m)*(
4892      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4893      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4894      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4895      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4896               dephii1=dephii1+(k-l)*sinkt(m)*(
4897      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4898      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4899      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
4900      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4901               if (lprn) then
4902               write (iout,*) "m",m," k",k," l",l," ffthet",
4903      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
4904      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
4905      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
4906      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4907               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4908      &            cosph1ph2(k,l)*sinkt(m),
4909      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4910               endif
4911             enddo
4912           enddo
4913         enddo
4914 10      continue
4915         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4916      &   i,theta(i)*rad2deg,phii*rad2deg,
4917      &   phii1*rad2deg,ethetai
4918         etheta=etheta+ethetai
4919         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4920         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4921         gloc(nphi+i-2,icg)=wang*dethetai
4922       enddo
4923       return
4924       end
4925 #endif
4926 #ifdef CRYST_SC
4927 c-----------------------------------------------------------------------------
4928       subroutine esc(escloc)
4929 C Calculate the local energy of a side chain and its derivatives in the
4930 C corresponding virtual-bond valence angles THETA and the spherical angles
4931 C ALPHA and OMEGA.
4932       implicit real*8 (a-h,o-z)
4933       include 'DIMENSIONS'
4934       include 'COMMON.GEO'
4935       include 'COMMON.LOCAL'
4936       include 'COMMON.VAR'
4937       include 'COMMON.INTERACT'
4938       include 'COMMON.DERIV'
4939       include 'COMMON.CHAIN'
4940       include 'COMMON.IOUNITS'
4941       include 'COMMON.NAMES'
4942       include 'COMMON.FFIELD'
4943       include 'COMMON.CONTROL'
4944       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4945      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4946       common /sccalc/ time11,time12,time112,theti,it,nlobit
4947       delta=0.02d0*pi
4948       escloc=0.0D0
4949 c     write (iout,'(a)') 'ESC'
4950       do i=loc_start,loc_end
4951         it=itype(i)
4952         if (it.eq.10) goto 1
4953         nlobit=nlob(it)
4954 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4955 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4956         theti=theta(i+1)-pipol
4957         x(1)=dtan(theti)
4958         x(2)=alph(i)
4959         x(3)=omeg(i)
4960
4961         if (x(2).gt.pi-delta) then
4962           xtemp(1)=x(1)
4963           xtemp(2)=pi-delta
4964           xtemp(3)=x(3)
4965           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4966           xtemp(2)=pi
4967           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4968           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4969      &        escloci,dersc(2))
4970           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4971      &        ddersc0(1),dersc(1))
4972           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4973      &        ddersc0(3),dersc(3))
4974           xtemp(2)=pi-delta
4975           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4976           xtemp(2)=pi
4977           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4978           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4979      &            dersc0(2),esclocbi,dersc02)
4980           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4981      &            dersc12,dersc01)
4982           call splinthet(x(2),0.5d0*delta,ss,ssd)
4983           dersc0(1)=dersc01
4984           dersc0(2)=dersc02
4985           dersc0(3)=0.0d0
4986           do k=1,3
4987             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4988           enddo
4989           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4990 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4991 c    &             esclocbi,ss,ssd
4992           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4993 c         escloci=esclocbi
4994 c         write (iout,*) escloci
4995         else if (x(2).lt.delta) then
4996           xtemp(1)=x(1)
4997           xtemp(2)=delta
4998           xtemp(3)=x(3)
4999           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5000           xtemp(2)=0.0d0
5001           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5002           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5003      &        escloci,dersc(2))
5004           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5005      &        ddersc0(1),dersc(1))
5006           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5007      &        ddersc0(3),dersc(3))
5008           xtemp(2)=delta
5009           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5010           xtemp(2)=0.0d0
5011           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5012           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5013      &            dersc0(2),esclocbi,dersc02)
5014           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5015      &            dersc12,dersc01)
5016           dersc0(1)=dersc01
5017           dersc0(2)=dersc02
5018           dersc0(3)=0.0d0
5019           call splinthet(x(2),0.5d0*delta,ss,ssd)
5020           do k=1,3
5021             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5022           enddo
5023           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5024 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5025 c    &             esclocbi,ss,ssd
5026           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5027 c         write (iout,*) escloci
5028         else
5029           call enesc(x,escloci,dersc,ddummy,.false.)
5030         endif
5031
5032         escloc=escloc+escloci
5033         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5034      &     'escloc',i,escloci
5035 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5036
5037         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5038      &   wscloc*dersc(1)
5039         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5040         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5041     1   continue
5042       enddo
5043       return
5044       end
5045 C---------------------------------------------------------------------------
5046       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5047       implicit real*8 (a-h,o-z)
5048       include 'DIMENSIONS'
5049       include 'COMMON.GEO'
5050       include 'COMMON.LOCAL'
5051       include 'COMMON.IOUNITS'
5052       common /sccalc/ time11,time12,time112,theti,it,nlobit
5053       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5054       double precision contr(maxlob,-1:1)
5055       logical mixed
5056 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5057         escloc_i=0.0D0
5058         do j=1,3
5059           dersc(j)=0.0D0
5060           if (mixed) ddersc(j)=0.0d0
5061         enddo
5062         x3=x(3)
5063
5064 C Because of periodicity of the dependence of the SC energy in omega we have
5065 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5066 C To avoid underflows, first compute & store the exponents.
5067
5068         do iii=-1,1
5069
5070           x(3)=x3+iii*dwapi
5071
5072           do j=1,nlobit
5073             do k=1,3
5074               z(k)=x(k)-censc(k,j,it)
5075             enddo
5076             do k=1,3
5077               Axk=0.0D0
5078               do l=1,3
5079                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5080               enddo
5081               Ax(k,j,iii)=Axk
5082             enddo
5083             expfac=0.0D0
5084             do k=1,3
5085               expfac=expfac+Ax(k,j,iii)*z(k)
5086             enddo
5087             contr(j,iii)=expfac
5088           enddo ! j
5089
5090         enddo ! iii
5091
5092         x(3)=x3
5093 C As in the case of ebend, we want to avoid underflows in exponentiation and
5094 C subsequent NaNs and INFs in energy calculation.
5095 C Find the largest exponent
5096         emin=contr(1,-1)
5097         do iii=-1,1
5098           do j=1,nlobit
5099             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5100           enddo
5101         enddo
5102         emin=0.5D0*emin
5103 cd      print *,'it=',it,' emin=',emin
5104
5105 C Compute the contribution to SC energy and derivatives
5106         do iii=-1,1
5107
5108           do j=1,nlobit
5109 #ifdef OSF
5110             adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin
5111             if(adexp.ne.adexp) adexp=1.0
5112             expfac=dexp(adexp)
5113 #else
5114             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
5115 #endif
5116 cd          print *,'j=',j,' expfac=',expfac
5117             escloc_i=escloc_i+expfac
5118             do k=1,3
5119               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5120             enddo
5121             if (mixed) then
5122               do k=1,3,2
5123                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5124      &            +gaussc(k,2,j,it))*expfac
5125               enddo
5126             endif
5127           enddo
5128
5129         enddo ! iii
5130
5131         dersc(1)=dersc(1)/cos(theti)**2
5132         ddersc(1)=ddersc(1)/cos(theti)**2
5133         ddersc(3)=ddersc(3)
5134
5135         escloci=-(dlog(escloc_i)-emin)
5136         do j=1,3
5137           dersc(j)=dersc(j)/escloc_i
5138         enddo
5139         if (mixed) then
5140           do j=1,3,2
5141             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5142           enddo
5143         endif
5144       return
5145       end
5146 C------------------------------------------------------------------------------
5147       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5148       implicit real*8 (a-h,o-z)
5149       include 'DIMENSIONS'
5150       include 'COMMON.GEO'
5151       include 'COMMON.LOCAL'
5152       include 'COMMON.IOUNITS'
5153       common /sccalc/ time11,time12,time112,theti,it,nlobit
5154       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5155       double precision contr(maxlob)
5156       logical mixed
5157
5158       escloc_i=0.0D0
5159
5160       do j=1,3
5161         dersc(j)=0.0D0
5162       enddo
5163
5164       do j=1,nlobit
5165         do k=1,2
5166           z(k)=x(k)-censc(k,j,it)
5167         enddo
5168         z(3)=dwapi
5169         do k=1,3
5170           Axk=0.0D0
5171           do l=1,3
5172             Axk=Axk+gaussc(l,k,j,it)*z(l)
5173           enddo
5174           Ax(k,j)=Axk
5175         enddo
5176         expfac=0.0D0
5177         do k=1,3
5178           expfac=expfac+Ax(k,j)*z(k)
5179         enddo
5180         contr(j)=expfac
5181       enddo ! j
5182
5183 C As in the case of ebend, we want to avoid underflows in exponentiation and
5184 C subsequent NaNs and INFs in energy calculation.
5185 C Find the largest exponent
5186       emin=contr(1)
5187       do j=1,nlobit
5188         if (emin.gt.contr(j)) emin=contr(j)
5189       enddo
5190       emin=0.5D0*emin
5191
5192 C Compute the contribution to SC energy and derivatives
5193
5194       dersc12=0.0d0
5195       do j=1,nlobit
5196         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
5197         escloc_i=escloc_i+expfac
5198         do k=1,2
5199           dersc(k)=dersc(k)+Ax(k,j)*expfac
5200         enddo
5201         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5202      &            +gaussc(1,2,j,it))*expfac
5203         dersc(3)=0.0d0
5204       enddo
5205
5206       dersc(1)=dersc(1)/cos(theti)**2
5207       dersc12=dersc12/cos(theti)**2
5208       escloci=-(dlog(escloc_i)-emin)
5209       do j=1,2
5210         dersc(j)=dersc(j)/escloc_i
5211       enddo
5212       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5213       return
5214       end
5215 #else
5216 c----------------------------------------------------------------------------------
5217       subroutine esc(escloc)
5218 C Calculate the local energy of a side chain and its derivatives in the
5219 C corresponding virtual-bond valence angles THETA and the spherical angles
5220 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5221 C added by Urszula Kozlowska. 07/11/2007
5222 C
5223       implicit real*8 (a-h,o-z)
5224       include 'DIMENSIONS'
5225       include 'COMMON.GEO'
5226       include 'COMMON.LOCAL'
5227       include 'COMMON.VAR'
5228       include 'COMMON.SCROT'
5229       include 'COMMON.INTERACT'
5230       include 'COMMON.DERIV'
5231       include 'COMMON.CHAIN'
5232       include 'COMMON.IOUNITS'
5233       include 'COMMON.NAMES'
5234       include 'COMMON.FFIELD'
5235       include 'COMMON.CONTROL'
5236       include 'COMMON.VECTORS'
5237       double precision x_prime(3),y_prime(3),z_prime(3)
5238      &    , sumene,dsc_i,dp2_i,x(65),
5239      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5240      &    de_dxx,de_dyy,de_dzz,de_dt
5241       double precision s1_t,s1_6_t,s2_t,s2_6_t
5242       double precision
5243      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5244      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5245      & dt_dCi(3),dt_dCi1(3)
5246       common /sccalc/ time11,time12,time112,theti,it,nlobit
5247       delta=0.02d0*pi
5248       escloc=0.0D0
5249       do i=loc_start,loc_end
5250         costtab(i+1) =dcos(theta(i+1))
5251         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5252         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5253         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5254         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5255         cosfac=dsqrt(cosfac2)
5256         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5257         sinfac=dsqrt(sinfac2)
5258         it=itype(i)
5259         if (it.eq.10) goto 1
5260 c
5261 C  Compute the axes of tghe local cartesian coordinates system; store in
5262 c   x_prime, y_prime and z_prime
5263 c
5264         do j=1,3
5265           x_prime(j) = 0.00
5266           y_prime(j) = 0.00
5267           z_prime(j) = 0.00
5268         enddo
5269 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5270 C     &   dc_norm(3,i+nres)
5271         do j = 1,3
5272           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5273           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5274         enddo
5275         do j = 1,3
5276           z_prime(j) = -uz(j,i-1)
5277         enddo
5278 c       write (2,*) "i",i
5279 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5280 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5281 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5282 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5283 c      & " xy",scalar(x_prime(1),y_prime(1)),
5284 c      & " xz",scalar(x_prime(1),z_prime(1)),
5285 c      & " yy",scalar(y_prime(1),y_prime(1)),
5286 c      & " yz",scalar(y_prime(1),z_prime(1)),
5287 c      & " zz",scalar(z_prime(1),z_prime(1))
5288 c
5289 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5290 C to local coordinate system. Store in xx, yy, zz.
5291 c
5292         xx=0.0d0
5293         yy=0.0d0
5294         zz=0.0d0
5295         do j = 1,3
5296           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5297           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5298           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5299         enddo
5300
5301         xxtab(i)=xx
5302         yytab(i)=yy
5303         zztab(i)=zz
5304 C
5305 C Compute the energy of the ith side cbain
5306 C
5307 c        write (2,*) "xx",xx," yy",yy," zz",zz
5308         it=itype(i)
5309         do j = 1,65
5310           x(j) = sc_parmin(j,it)
5311         enddo
5312 #ifdef CHECK_COORD
5313 Cc diagnostics - remove later
5314         xx1 = dcos(alph(2))
5315         yy1 = dsin(alph(2))*dcos(omeg(2))
5316         zz1 = -dsin(alph(2))*dsin(omeg(2))
5317         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5318      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5319      &    xx1,yy1,zz1
5320 C,"  --- ", xx_w,yy_w,zz_w
5321 c end diagnostics
5322 #endif
5323         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5324      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5325      &   + x(10)*yy*zz
5326         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5327      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5328      & + x(20)*yy*zz
5329         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5330      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5331      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5332      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5333      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5334      &  +x(40)*xx*yy*zz
5335         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5336      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5337      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5338      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5339      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5340      &  +x(60)*xx*yy*zz
5341         dsc_i   = 0.743d0+x(61)
5342         dp2_i   = 1.9d0+x(62)
5343         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5344      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5345         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5346      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5347         s1=(1+x(63))/(0.1d0 + dscp1)
5348         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5349         s2=(1+x(65))/(0.1d0 + dscp2)
5350         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5351         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5352      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5353 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5354 c     &   sumene4,
5355 c     &   dscp1,dscp2,sumene
5356 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5357         escloc = escloc + sumene
5358 c        write (2,*) "i",i," escloc",sumene,escloc
5359 #ifdef DEBUG
5360 C
5361 C This section to check the numerical derivatives of the energy of ith side
5362 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5363 C #define DEBUG in the code to turn it on.
5364 C
5365         write (2,*) "sumene               =",sumene
5366         aincr=1.0d-7
5367         xxsave=xx
5368         xx=xx+aincr
5369         write (2,*) xx,yy,zz
5370         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5371         de_dxx_num=(sumenep-sumene)/aincr
5372         xx=xxsave
5373         write (2,*) "xx+ sumene from enesc=",sumenep
5374         yysave=yy
5375         yy=yy+aincr
5376         write (2,*) xx,yy,zz
5377         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5378         de_dyy_num=(sumenep-sumene)/aincr
5379         yy=yysave
5380         write (2,*) "yy+ sumene from enesc=",sumenep
5381         zzsave=zz
5382         zz=zz+aincr
5383         write (2,*) xx,yy,zz
5384         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5385         de_dzz_num=(sumenep-sumene)/aincr
5386         zz=zzsave
5387         write (2,*) "zz+ sumene from enesc=",sumenep
5388         costsave=cost2tab(i+1)
5389         sintsave=sint2tab(i+1)
5390         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5391         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5392         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5393         de_dt_num=(sumenep-sumene)/aincr
5394         write (2,*) " t+ sumene from enesc=",sumenep
5395         cost2tab(i+1)=costsave
5396         sint2tab(i+1)=sintsave
5397 C End of diagnostics section.
5398 #endif
5399 C
5400 C Compute the gradient of esc
5401 C
5402         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5403         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5404         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5405         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5406         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5407         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5408         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5409         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5410         pom1=(sumene3*sint2tab(i+1)+sumene1)
5411      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5412         pom2=(sumene4*cost2tab(i+1)+sumene2)
5413      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5414         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5415         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5416      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5417      &  +x(40)*yy*zz
5418         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5419         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5420      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5421      &  +x(60)*yy*zz
5422         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5423      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5424      &        +(pom1+pom2)*pom_dx
5425 #ifdef DEBUG
5426         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5427 #endif
5428 C
5429         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5430         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5431      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5432      &  +x(40)*xx*zz
5433         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5434         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5435      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5436      &  +x(59)*zz**2 +x(60)*xx*zz
5437         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5438      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5439      &        +(pom1-pom2)*pom_dy
5440 #ifdef DEBUG
5441         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5442 #endif
5443 C
5444         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5445      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5446      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5447      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5448      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5449      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5450      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5451      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5452 #ifdef DEBUG
5453         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5454 #endif
5455 C
5456         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5457      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5458      &  +pom1*pom_dt1+pom2*pom_dt2
5459 #ifdef DEBUG
5460         write(2,*), "de_dt = ", de_dt,de_dt_num
5461 #endif
5462 c
5463 C
5464        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5465        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5466        cosfac2xx=cosfac2*xx
5467        sinfac2yy=sinfac2*yy
5468        do k = 1,3
5469          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5470      &      vbld_inv(i+1)
5471          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5472      &      vbld_inv(i)
5473          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5474          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5475 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5476 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5477 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5478 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5479          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5480          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5481          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5482          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5483          dZZ_Ci1(k)=0.0d0
5484          dZZ_Ci(k)=0.0d0
5485          do j=1,3
5486            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5487            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5488          enddo
5489
5490          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5491          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5492          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5493 c
5494          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5495          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5496        enddo
5497
5498        do k=1,3
5499          dXX_Ctab(k,i)=dXX_Ci(k)
5500          dXX_C1tab(k,i)=dXX_Ci1(k)
5501          dYY_Ctab(k,i)=dYY_Ci(k)
5502          dYY_C1tab(k,i)=dYY_Ci1(k)
5503          dZZ_Ctab(k,i)=dZZ_Ci(k)
5504          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5505          dXX_XYZtab(k,i)=dXX_XYZ(k)
5506          dYY_XYZtab(k,i)=dYY_XYZ(k)
5507          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5508        enddo
5509
5510        do k = 1,3
5511 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5512 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5513 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5514 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5515 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5516 c     &    dt_dci(k)
5517 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5518 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5519          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5520      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5521          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5522      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5523          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5524      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5525        enddo
5526 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5527 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5528
5529 C to check gradient call subroutine check_grad
5530
5531     1 continue
5532       enddo
5533       return
5534       end
5535 c------------------------------------------------------------------------------
5536       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5537       implicit none
5538       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5539      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5540       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5541      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5542      &   + x(10)*yy*zz
5543       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5544      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5545      & + x(20)*yy*zz
5546       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5547      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5548      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5549      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5550      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5551      &  +x(40)*xx*yy*zz
5552       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5553      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5554      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5555      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5556      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5557      &  +x(60)*xx*yy*zz
5558       dsc_i   = 0.743d0+x(61)
5559       dp2_i   = 1.9d0+x(62)
5560       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5561      &          *(xx*cost2+yy*sint2))
5562       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5563      &          *(xx*cost2-yy*sint2))
5564       s1=(1+x(63))/(0.1d0 + dscp1)
5565       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5566       s2=(1+x(65))/(0.1d0 + dscp2)
5567       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5568       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5569      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5570       enesc=sumene
5571       return
5572       end
5573 #endif
5574 c------------------------------------------------------------------------------
5575       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5576 C
5577 C This procedure calculates two-body contact function g(rij) and its derivative:
5578 C
5579 C           eps0ij                                     !       x < -1
5580 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5581 C            0                                         !       x > 1
5582 C
5583 C where x=(rij-r0ij)/delta
5584 C
5585 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5586 C
5587       implicit none
5588       double precision rij,r0ij,eps0ij,fcont,fprimcont
5589       double precision x,x2,x4,delta
5590 c     delta=0.02D0*r0ij
5591 c      delta=0.2D0*r0ij
5592       x=(rij-r0ij)/delta
5593       if (x.lt.-1.0D0) then
5594         fcont=eps0ij
5595         fprimcont=0.0D0
5596       else if (x.le.1.0D0) then
5597         x2=x*x
5598         x4=x2*x2
5599         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5600         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5601       else
5602         fcont=0.0D0
5603         fprimcont=0.0D0
5604       endif
5605       return
5606       end
5607 c------------------------------------------------------------------------------
5608       subroutine splinthet(theti,delta,ss,ssder)
5609       implicit real*8 (a-h,o-z)
5610       include 'DIMENSIONS'
5611       include 'COMMON.VAR'
5612       include 'COMMON.GEO'
5613       thetup=pi-delta
5614       thetlow=delta
5615       if (theti.gt.pipol) then
5616         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5617       else
5618         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5619         ssder=-ssder
5620       endif
5621       return
5622       end
5623 c------------------------------------------------------------------------------
5624       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5625       implicit none
5626       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5627       double precision ksi,ksi2,ksi3,a1,a2,a3
5628       a1=fprim0*delta/(f1-f0)
5629       a2=3.0d0-2.0d0*a1
5630       a3=a1-2.0d0
5631       ksi=(x-x0)/delta
5632       ksi2=ksi*ksi
5633       ksi3=ksi2*ksi
5634       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5635       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5636       return
5637       end
5638 c------------------------------------------------------------------------------
5639       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5640       implicit none
5641       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5642       double precision ksi,ksi2,ksi3,a1,a2,a3
5643       ksi=(x-x0)/delta
5644       ksi2=ksi*ksi
5645       ksi3=ksi2*ksi
5646       a1=fprim0x*delta
5647       a2=3*(f1x-f0x)-2*fprim0x*delta
5648       a3=fprim0x*delta-2*(f1x-f0x)
5649       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5650       return
5651       end
5652 C-----------------------------------------------------------------------------
5653 #ifdef CRYST_TOR
5654 C-----------------------------------------------------------------------------
5655       subroutine etor(etors,edihcnstr)
5656       implicit real*8 (a-h,o-z)
5657       include 'DIMENSIONS'
5658       include 'COMMON.VAR'
5659       include 'COMMON.GEO'
5660       include 'COMMON.LOCAL'
5661       include 'COMMON.TORSION'
5662       include 'COMMON.INTERACT'
5663       include 'COMMON.DERIV'
5664       include 'COMMON.CHAIN'
5665       include 'COMMON.NAMES'
5666       include 'COMMON.IOUNITS'
5667       include 'COMMON.FFIELD'
5668       include 'COMMON.TORCNSTR'
5669       include 'COMMON.CONTROL'
5670       logical lprn
5671 C Set lprn=.true. for debugging
5672       lprn=.false.
5673 c      lprn=.true.
5674       etors=0.0D0
5675       do i=iphi_start,iphi_end
5676       etors_ii=0.0D0
5677         itori=itortyp(itype(i-2))
5678         itori1=itortyp(itype(i-1))
5679         phii=phi(i)
5680         gloci=0.0D0
5681 C Proline-Proline pair is a special case...
5682         if (itori.eq.3 .and. itori1.eq.3) then
5683           if (phii.gt.-dwapi3) then
5684             cosphi=dcos(3*phii)
5685             fac=1.0D0/(1.0D0-cosphi)
5686             etorsi=v1(1,3,3)*fac
5687             etorsi=etorsi+etorsi
5688             etors=etors+etorsi-v1(1,3,3)
5689             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5690             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5691           endif
5692           do j=1,3
5693             v1ij=v1(j+1,itori,itori1)
5694             v2ij=v2(j+1,itori,itori1)
5695             cosphi=dcos(j*phii)
5696             sinphi=dsin(j*phii)
5697             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5698             if (energy_dec) etors_ii=etors_ii+
5699      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5700             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5701           enddo
5702         else
5703           do j=1,nterm_old
5704             v1ij=v1(j,itori,itori1)
5705             v2ij=v2(j,itori,itori1)
5706             cosphi=dcos(j*phii)
5707             sinphi=dsin(j*phii)
5708             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5709             if (energy_dec) etors_ii=etors_ii+
5710      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5711             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5712           enddo
5713         endif
5714         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5715      &        'etor',i,etors_ii
5716         if (lprn)
5717      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5718      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5719      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5720         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5721         write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5722       enddo
5723 ! 6/20/98 - dihedral angle constraints
5724       edihcnstr=0.0d0
5725       do i=1,ndih_constr
5726         itori=idih_constr(i)
5727         phii=phi(itori)
5728         difi=phii-phi0(i)
5729         if (difi.gt.drange(i)) then
5730           difi=difi-drange(i)
5731           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5732           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5733         else if (difi.lt.-drange(i)) then
5734           difi=difi+drange(i)
5735           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5736           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5737         endif
5738 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5739 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5740       enddo
5741 !      write (iout,*) 'edihcnstr',edihcnstr
5742       return
5743       end
5744 c------------------------------------------------------------------------------
5745       subroutine etor_d(etors_d)
5746       etors_d=0.0d0
5747       return
5748       end
5749 c----------------------------------------------------------------------------
5750 #else
5751       subroutine etor(etors,edihcnstr)
5752       implicit real*8 (a-h,o-z)
5753       include 'DIMENSIONS'
5754       include 'COMMON.VAR'
5755       include 'COMMON.GEO'
5756       include 'COMMON.LOCAL'
5757       include 'COMMON.TORSION'
5758       include 'COMMON.INTERACT'
5759       include 'COMMON.DERIV'
5760       include 'COMMON.CHAIN'
5761       include 'COMMON.NAMES'
5762       include 'COMMON.IOUNITS'
5763       include 'COMMON.FFIELD'
5764       include 'COMMON.TORCNSTR'
5765       include 'COMMON.CONTROL'
5766       logical lprn
5767 C Set lprn=.true. for debugging
5768       lprn=.false.
5769 c     lprn=.true.
5770       etors=0.0D0
5771       do i=iphi_start,iphi_end
5772       etors_ii=0.0D0
5773         itori=itortyp(itype(i-2))
5774         itori1=itortyp(itype(i-1))
5775         phii=phi(i)
5776         gloci=0.0D0
5777 C Regular cosine and sine terms
5778         do j=1,nterm(itori,itori1)
5779           v1ij=v1(j,itori,itori1)
5780           v2ij=v2(j,itori,itori1)
5781           cosphi=dcos(j*phii)
5782           sinphi=dsin(j*phii)
5783           etors=etors+v1ij*cosphi+v2ij*sinphi
5784           if (energy_dec) etors_ii=etors_ii+
5785      &                v1ij*cosphi+v2ij*sinphi
5786           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5787         enddo
5788 C Lorentz terms
5789 C                         v1
5790 C  E = SUM ----------------------------------- - v1
5791 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5792 C
5793         cosphi=dcos(0.5d0*phii)
5794         sinphi=dsin(0.5d0*phii)
5795         do j=1,nlor(itori,itori1)
5796           vl1ij=vlor1(j,itori,itori1)
5797           vl2ij=vlor2(j,itori,itori1)
5798           vl3ij=vlor3(j,itori,itori1)
5799           pom=vl2ij*cosphi+vl3ij*sinphi
5800           pom1=1.0d0/(pom*pom+1.0d0)
5801           etors=etors+vl1ij*pom1
5802           if (energy_dec) etors_ii=etors_ii+
5803      &                vl1ij*pom1
5804           pom=-pom*pom1*pom1
5805           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5806         enddo
5807 C Subtract the constant term
5808         etors=etors-v0(itori,itori1)
5809           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5810      &         'etor',i,etors_ii-v0(itori,itori1)
5811         if (lprn)
5812      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5813      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5814      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5815         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5816 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5817       enddo
5818 ! 6/20/98 - dihedral angle constraints
5819       edihcnstr=0.0d0
5820 c      do i=1,ndih_constr
5821       do i=idihconstr_start,idihconstr_end
5822         itori=idih_constr(i)
5823         phii=phi(itori)
5824         difi=pinorm(phii-phi0(i))
5825         if (difi.gt.drange(i)) then
5826           difi=difi-drange(i)
5827           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5828           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5829         else if (difi.lt.-drange(i)) then
5830           difi=difi+drange(i)
5831           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5832           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5833         else
5834           difi=0.0
5835         endif
5836 c        write (iout,*) "gloci", gloc(i-3,icg)
5837 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5838 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5839 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5840       enddo
5841 cd       write (iout,*) 'edihcnstr',edihcnstr
5842       return
5843       end
5844 c----------------------------------------------------------------------------
5845       subroutine etor_d(etors_d)
5846 C 6/23/01 Compute double torsional energy
5847       implicit real*8 (a-h,o-z)
5848       include 'DIMENSIONS'
5849       include 'COMMON.VAR'
5850       include 'COMMON.GEO'
5851       include 'COMMON.LOCAL'
5852       include 'COMMON.TORSION'
5853       include 'COMMON.INTERACT'
5854       include 'COMMON.DERIV'
5855       include 'COMMON.CHAIN'
5856       include 'COMMON.NAMES'
5857       include 'COMMON.IOUNITS'
5858       include 'COMMON.FFIELD'
5859       include 'COMMON.TORCNSTR'
5860       logical lprn
5861 C Set lprn=.true. for debugging
5862       lprn=.false.
5863 c     lprn=.true.
5864       etors_d=0.0D0
5865       do i=iphid_start,iphid_end
5866         itori=itortyp(itype(i-2))
5867         itori1=itortyp(itype(i-1))
5868         itori2=itortyp(itype(i))
5869         phii=phi(i)
5870         phii1=phi(i+1)
5871         gloci1=0.0D0
5872         gloci2=0.0D0
5873         do j=1,ntermd_1(itori,itori1,itori2)
5874           v1cij=v1c(1,j,itori,itori1,itori2)
5875           v1sij=v1s(1,j,itori,itori1,itori2)
5876           v2cij=v1c(2,j,itori,itori1,itori2)
5877           v2sij=v1s(2,j,itori,itori1,itori2)
5878           cosphi1=dcos(j*phii)
5879           sinphi1=dsin(j*phii)
5880           cosphi2=dcos(j*phii1)
5881           sinphi2=dsin(j*phii1)
5882           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5883      &     v2cij*cosphi2+v2sij*sinphi2
5884           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5885           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5886         enddo
5887         do k=2,ntermd_2(itori,itori1,itori2)
5888           do l=1,k-1
5889             v1cdij = v2c(k,l,itori,itori1,itori2)
5890             v2cdij = v2c(l,k,itori,itori1,itori2)
5891             v1sdij = v2s(k,l,itori,itori1,itori2)
5892             v2sdij = v2s(l,k,itori,itori1,itori2)
5893             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5894             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5895             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5896             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5897             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5898      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5899             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5900      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5901             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5902      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5903           enddo
5904         enddo
5905         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5906         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5907 c        write (iout,*) "gloci", gloc(i-3,icg)
5908       enddo
5909       return
5910       end
5911 #endif
5912 c------------------------------------------------------------------------------
5913       subroutine eback_sc_corr(esccor)
5914 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5915 c        conformational states; temporarily implemented as differences
5916 c        between UNRES torsional potentials (dependent on three types of
5917 c        residues) and the torsional potentials dependent on all 20 types
5918 c        of residues computed from AM1  energy surfaces of terminally-blocked
5919 c        amino-acid residues.
5920       implicit real*8 (a-h,o-z)
5921       include 'DIMENSIONS'
5922       include 'COMMON.VAR'
5923       include 'COMMON.GEO'
5924       include 'COMMON.LOCAL'
5925       include 'COMMON.TORSION'
5926       include 'COMMON.SCCOR'
5927       include 'COMMON.INTERACT'
5928       include 'COMMON.DERIV'
5929       include 'COMMON.CHAIN'
5930       include 'COMMON.NAMES'
5931       include 'COMMON.IOUNITS'
5932       include 'COMMON.FFIELD'
5933       include 'COMMON.CONTROL'
5934       logical lprn
5935 C Set lprn=.true. for debugging
5936       lprn=.false.
5937 c      lprn=.true.
5938 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
5939       esccor=0.0D0
5940       do i=itau_start,itau_end
5941         esccor_ii=0.0D0
5942         isccori=isccortyp(itype(i-2))
5943         isccori1=isccortyp(itype(i-1))
5944         phii=phi(i)
5945 cccc  Added 9 May 2012
5946 cc Tauangle is torsional engle depending on the value of first digit
5947 c(see comment below)
5948 cc Omicron is flat angle depending on the value of first digit
5949 c(see comment below)
5950
5951
5952         do intertyp=1,3 !intertyp
5953 cc Added 09 May 2012 (Adasko)
5954 cc  Intertyp means interaction type of backbone mainchain correlation:
5955 c   1 = SC...Ca...Ca...Ca
5956 c   2 = Ca...Ca...Ca...SC
5957 c   3 = SC...Ca...Ca...SCi
5958         gloci=0.0D0
5959         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5960      &      (itype(i-1).eq.10).or.(itype(i-2).eq.21).or.
5961      &      (itype(i-1).eq.21)))
5962      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5963      &     .or.(itype(i-2).eq.21)))
5964      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5965      &      (itype(i-1).eq.21)))) cycle
5966         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle
5967         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21))
5968      & cycle
5969         do j=1,nterm_sccor(isccori,isccori1)
5970           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5971           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5972           cosphi=dcos(j*tauangle(intertyp,i))
5973           sinphi=dsin(j*tauangle(intertyp,i))
5974           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5975           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5976         enddo
5977         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5978 c        write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
5979 c     &gloc_sc(intertyp,i-3,icg)
5980         if (lprn)
5981      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5982      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5983      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
5984      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
5985         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5986        enddo !intertyp
5987       enddo
5988 c        do i=1,nres
5989 c        write (iout,*) "W@T@F",  gloc_sc(1,i,icg),gloc(i,icg)
5990 c        enddo
5991       return
5992       end
5993 c----------------------------------------------------------------------------
5994       subroutine multibody(ecorr)
5995 C This subroutine calculates multi-body contributions to energy following
5996 C the idea of Skolnick et al. If side chains I and J make a contact and
5997 C at the same time side chains I+1 and J+1 make a contact, an extra
5998 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5999       implicit real*8 (a-h,o-z)
6000       include 'DIMENSIONS'
6001       include 'COMMON.IOUNITS'
6002       include 'COMMON.DERIV'
6003       include 'COMMON.INTERACT'
6004       include 'COMMON.CONTACTS'
6005       double precision gx(3),gx1(3)
6006       logical lprn
6007
6008 C Set lprn=.true. for debugging
6009       lprn=.false.
6010
6011       if (lprn) then
6012         write (iout,'(a)') 'Contact function values:'
6013         do i=nnt,nct-2
6014           write (iout,'(i2,20(1x,i2,f10.5))')
6015      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6016         enddo
6017       endif
6018       ecorr=0.0D0
6019       do i=nnt,nct
6020         do j=1,3
6021           gradcorr(j,i)=0.0D0
6022           gradxorr(j,i)=0.0D0
6023         enddo
6024       enddo
6025       do i=nnt,nct-2
6026
6027         DO ISHIFT = 3,4
6028
6029         i1=i+ishift
6030         num_conti=num_cont(i)
6031         num_conti1=num_cont(i1)
6032         do jj=1,num_conti
6033           j=jcont(jj,i)
6034           do kk=1,num_conti1
6035             j1=jcont(kk,i1)
6036             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6037 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6038 cd   &                   ' ishift=',ishift
6039 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6040 C The system gains extra energy.
6041               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6042             endif   ! j1==j+-ishift
6043           enddo     ! kk
6044         enddo       ! jj
6045
6046         ENDDO ! ISHIFT
6047
6048       enddo         ! i
6049       return
6050       end
6051 c------------------------------------------------------------------------------
6052       double precision function esccorr(i,j,k,l,jj,kk)
6053       implicit real*8 (a-h,o-z)
6054       include 'DIMENSIONS'
6055       include 'COMMON.IOUNITS'
6056       include 'COMMON.DERIV'
6057       include 'COMMON.INTERACT'
6058       include 'COMMON.CONTACTS'
6059       double precision gx(3),gx1(3)
6060       logical lprn
6061       lprn=.false.
6062       eij=facont(jj,i)
6063       ekl=facont(kk,k)
6064 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6065 C Calculate the multi-body contribution to energy.
6066 C Calculate multi-body contributions to the gradient.
6067 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6068 cd   & k,l,(gacont(m,kk,k),m=1,3)
6069       do m=1,3
6070         gx(m) =ekl*gacont(m,jj,i)
6071         gx1(m)=eij*gacont(m,kk,k)
6072         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6073         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6074         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6075         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6076       enddo
6077       do m=i,j-1
6078         do ll=1,3
6079           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6080         enddo
6081       enddo
6082       do m=k,l-1
6083         do ll=1,3
6084           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6085         enddo
6086       enddo
6087       esccorr=-eij*ekl
6088       return
6089       end
6090 c------------------------------------------------------------------------------
6091       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6092 C This subroutine calculates multi-body contributions to hydrogen-bonding
6093       implicit real*8 (a-h,o-z)
6094       include 'DIMENSIONS'
6095       include 'COMMON.IOUNITS'
6096 #ifdef MPI
6097       include "mpif.h"
6098       parameter (max_cont=maxconts)
6099       parameter (max_dim=26)
6100       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6101       double precision zapas(max_dim,maxconts,max_fg_procs),
6102      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6103       common /przechowalnia/ zapas
6104       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6105      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6106 #endif
6107       include 'COMMON.SETUP'
6108       include 'COMMON.FFIELD'
6109       include 'COMMON.DERIV'
6110       include 'COMMON.INTERACT'
6111       include 'COMMON.CONTACTS'
6112       include 'COMMON.CONTROL'
6113       include 'COMMON.LOCAL'
6114       double precision gx(3),gx1(3),time00
6115       logical lprn,ldone
6116
6117 C Set lprn=.true. for debugging
6118       lprn=.false.
6119 #ifdef MPI
6120       n_corr=0
6121       n_corr1=0
6122       if (nfgtasks.le.1) goto 30
6123       if (lprn) then
6124         write (iout,'(a)') 'Contact function values before RECEIVE:'
6125         do i=nnt,nct-2
6126           write (iout,'(2i3,50(1x,i2,f5.2))')
6127      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6128      &    j=1,num_cont_hb(i))
6129         enddo
6130       endif
6131       call flush(iout)
6132       do i=1,ntask_cont_from
6133         ncont_recv(i)=0
6134       enddo
6135       do i=1,ntask_cont_to
6136         ncont_sent(i)=0
6137       enddo
6138 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6139 c     & ntask_cont_to
6140 C Make the list of contacts to send to send to other procesors
6141 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6142 c      call flush(iout)
6143       do i=iturn3_start,iturn3_end
6144 c        write (iout,*) "make contact list turn3",i," num_cont",
6145 c     &    num_cont_hb(i)
6146         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6147       enddo
6148       do i=iturn4_start,iturn4_end
6149 c        write (iout,*) "make contact list turn4",i," num_cont",
6150 c     &   num_cont_hb(i)
6151         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6152       enddo
6153       do ii=1,nat_sent
6154         i=iat_sent(ii)
6155 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6156 c     &    num_cont_hb(i)
6157         do j=1,num_cont_hb(i)
6158         do k=1,4
6159           jjc=jcont_hb(j,i)
6160           iproc=iint_sent_local(k,jjc,ii)
6161 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6162           if (iproc.gt.0) then
6163             ncont_sent(iproc)=ncont_sent(iproc)+1
6164             nn=ncont_sent(iproc)
6165             zapas(1,nn,iproc)=i
6166             zapas(2,nn,iproc)=jjc
6167             zapas(3,nn,iproc)=facont_hb(j,i)
6168             zapas(4,nn,iproc)=ees0p(j,i)
6169             zapas(5,nn,iproc)=ees0m(j,i)
6170             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6171             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6172             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6173             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6174             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6175             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6176             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6177             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6178             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6179             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6180             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6181             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6182             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6183             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6184             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6185             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6186             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6187             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6188             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6189             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6190             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6191           endif
6192         enddo
6193         enddo
6194       enddo
6195       if (lprn) then
6196       write (iout,*)
6197      &  "Numbers of contacts to be sent to other processors",
6198      &  (ncont_sent(i),i=1,ntask_cont_to)
6199       write (iout,*) "Contacts sent"
6200       do ii=1,ntask_cont_to
6201         nn=ncont_sent(ii)
6202         iproc=itask_cont_to(ii)
6203         write (iout,*) nn," contacts to processor",iproc,
6204      &   " of CONT_TO_COMM group"
6205         do i=1,nn
6206           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6207         enddo
6208       enddo
6209       call flush(iout)
6210       endif
6211       CorrelType=477
6212       CorrelID=fg_rank+1
6213       CorrelType1=478
6214       CorrelID1=nfgtasks+fg_rank+1
6215       ireq=0
6216 C Receive the numbers of needed contacts from other processors
6217       do ii=1,ntask_cont_from
6218         iproc=itask_cont_from(ii)
6219         ireq=ireq+1
6220         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6221      &    FG_COMM,req(ireq),IERR)
6222       enddo
6223 c      write (iout,*) "IRECV ended"
6224 c      call flush(iout)
6225 C Send the number of contacts needed by other processors
6226       do ii=1,ntask_cont_to
6227         iproc=itask_cont_to(ii)
6228         ireq=ireq+1
6229         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6230      &    FG_COMM,req(ireq),IERR)
6231       enddo
6232 c      write (iout,*) "ISEND ended"
6233 c      write (iout,*) "number of requests (nn)",ireq
6234       call flush(iout)
6235       if (ireq.gt.0)
6236      &  call MPI_Waitall(ireq,req,status_array,ierr)
6237 c      write (iout,*)
6238 c     &  "Numbers of contacts to be received from other processors",
6239 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6240 c      call flush(iout)
6241 C Receive contacts
6242       ireq=0
6243       do ii=1,ntask_cont_from
6244         iproc=itask_cont_from(ii)
6245         nn=ncont_recv(ii)
6246 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6247 c     &   " of CONT_TO_COMM group"
6248         call flush(iout)
6249         if (nn.gt.0) then
6250           ireq=ireq+1
6251           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6252      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6253 c          write (iout,*) "ireq,req",ireq,req(ireq)
6254         endif
6255       enddo
6256 C Send the contacts to processors that need them
6257       do ii=1,ntask_cont_to
6258         iproc=itask_cont_to(ii)
6259         nn=ncont_sent(ii)
6260 c        write (iout,*) nn," contacts to processor",iproc,
6261 c     &   " of CONT_TO_COMM group"
6262         if (nn.gt.0) then
6263           ireq=ireq+1
6264           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6265      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6266 c          write (iout,*) "ireq,req",ireq,req(ireq)
6267 c          do i=1,nn
6268 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6269 c          enddo
6270         endif
6271       enddo
6272 c      write (iout,*) "number of requests (contacts)",ireq
6273 c      write (iout,*) "req",(req(i),i=1,4)
6274 c      call flush(iout)
6275       if (ireq.gt.0)
6276      & call MPI_Waitall(ireq,req,status_array,ierr)
6277       do iii=1,ntask_cont_from
6278         iproc=itask_cont_from(iii)
6279         nn=ncont_recv(iii)
6280         if (lprn) then
6281         write (iout,*) "Received",nn," contacts from processor",iproc,
6282      &   " of CONT_FROM_COMM group"
6283         call flush(iout)
6284         do i=1,nn
6285           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6286         enddo
6287         call flush(iout)
6288         endif
6289         do i=1,nn
6290           ii=zapas_recv(1,i,iii)
6291 c Flag the received contacts to prevent double-counting
6292           jj=-zapas_recv(2,i,iii)
6293 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6294 c          call flush(iout)
6295           nnn=num_cont_hb(ii)+1
6296           num_cont_hb(ii)=nnn
6297           jcont_hb(nnn,ii)=jj
6298           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6299           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6300           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6301           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6302           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6303           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6304           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6305           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6306           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6307           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6308           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6309           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6310           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6311           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6312           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6313           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6314           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6315           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6316           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6317           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6318           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6319           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6320           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6321           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6322         enddo
6323       enddo
6324       call flush(iout)
6325       if (lprn) then
6326         write (iout,'(a)') 'Contact function values after receive:'
6327         do i=nnt,nct-2
6328           write (iout,'(2i3,50(1x,i3,f5.2))')
6329      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6330      &    j=1,num_cont_hb(i))
6331         enddo
6332         call flush(iout)
6333       endif
6334    30 continue
6335 #endif
6336       if (lprn) then
6337         write (iout,'(a)') 'Contact function values:'
6338         do i=nnt,nct-2
6339           write (iout,'(2i3,50(1x,i3,f5.2))')
6340      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6341      &    j=1,num_cont_hb(i))
6342         enddo
6343       endif
6344       ecorr=0.0D0
6345 C Remove the loop below after debugging !!!
6346       do i=nnt,nct
6347         do j=1,3
6348           gradcorr(j,i)=0.0D0
6349           gradxorr(j,i)=0.0D0
6350         enddo
6351       enddo
6352 C Calculate the local-electrostatic correlation terms
6353       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6354         i1=i+1
6355         num_conti=num_cont_hb(i)
6356         num_conti1=num_cont_hb(i+1)
6357         do jj=1,num_conti
6358           j=jcont_hb(jj,i)
6359           jp=iabs(j)
6360           do kk=1,num_conti1
6361             j1=jcont_hb(kk,i1)
6362             jp1=iabs(j1)
6363 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6364 c     &         ' jj=',jj,' kk=',kk
6365             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6366      &          .or. j.lt.0 .and. j1.gt.0) .and.
6367      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6368 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6369 C The system gains extra energy.
6370               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6371               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6372      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6373               n_corr=n_corr+1
6374             else if (j1.eq.j) then
6375 C Contacts I-J and I-(J+1) occur simultaneously.
6376 C The system loses extra energy.
6377 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6378             endif
6379           enddo ! kk
6380           do kk=1,num_conti
6381             j1=jcont_hb(kk,i)
6382 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6383 c    &         ' jj=',jj,' kk=',kk
6384             if (j1.eq.j+1) then
6385 C Contacts I-J and (I+1)-J occur simultaneously.
6386 C The system loses extra energy.
6387 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6388             endif ! j1==j+1
6389           enddo ! kk
6390         enddo ! jj
6391       enddo ! i
6392       return
6393       end
6394 c------------------------------------------------------------------------------
6395       subroutine add_hb_contact(ii,jj,itask)
6396       implicit real*8 (a-h,o-z)
6397       include "DIMENSIONS"
6398       include "COMMON.IOUNITS"
6399       integer max_cont
6400       integer max_dim
6401       parameter (max_cont=maxconts)
6402       parameter (max_dim=26)
6403       include "COMMON.CONTACTS"
6404       double precision zapas(max_dim,maxconts,max_fg_procs),
6405      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6406       common /przechowalnia/ zapas
6407       integer i,j,ii,jj,iproc,itask(4),nn
6408 c      write (iout,*) "itask",itask
6409       do i=1,2
6410         iproc=itask(i)
6411         if (iproc.gt.0) then
6412           do j=1,num_cont_hb(ii)
6413             jjc=jcont_hb(j,ii)
6414 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6415             if (jjc.eq.jj) then
6416               ncont_sent(iproc)=ncont_sent(iproc)+1
6417               nn=ncont_sent(iproc)
6418               zapas(1,nn,iproc)=ii
6419               zapas(2,nn,iproc)=jjc
6420               zapas(3,nn,iproc)=facont_hb(j,ii)
6421               zapas(4,nn,iproc)=ees0p(j,ii)
6422               zapas(5,nn,iproc)=ees0m(j,ii)
6423               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6424               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6425               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6426               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6427               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6428               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6429               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6430               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6431               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6432               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6433               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6434               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6435               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6436               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6437               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6438               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6439               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6440               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6441               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6442               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6443               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6444               exit
6445             endif
6446           enddo
6447         endif
6448       enddo
6449       return
6450       end
6451 c------------------------------------------------------------------------------
6452       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6453      &  n_corr1)
6454 C This subroutine calculates multi-body contributions to hydrogen-bonding
6455       implicit real*8 (a-h,o-z)
6456       include 'DIMENSIONS'
6457       include 'COMMON.IOUNITS'
6458 #ifdef MPI
6459       include "mpif.h"
6460       parameter (max_cont=maxconts)
6461       parameter (max_dim=70)
6462       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6463       double precision zapas(max_dim,maxconts,max_fg_procs),
6464      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6465       common /przechowalnia/ zapas
6466       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6467      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6468 #endif
6469       include 'COMMON.SETUP'
6470       include 'COMMON.FFIELD'
6471       include 'COMMON.DERIV'
6472       include 'COMMON.LOCAL'
6473       include 'COMMON.INTERACT'
6474       include 'COMMON.CONTACTS'
6475       include 'COMMON.CHAIN'
6476       include 'COMMON.CONTROL'
6477       double precision gx(3),gx1(3)
6478       integer num_cont_hb_old(maxres)
6479       logical lprn,ldone
6480       double precision eello4,eello5,eelo6,eello_turn6
6481       external eello4,eello5,eello6,eello_turn6
6482 C Set lprn=.true. for debugging
6483       lprn=.false.
6484       eturn6=0.0d0
6485 #ifdef MPI
6486       do i=1,nres
6487         num_cont_hb_old(i)=num_cont_hb(i)
6488       enddo
6489       n_corr=0
6490       n_corr1=0
6491       if (nfgtasks.le.1) goto 30
6492       if (lprn) then
6493         write (iout,'(a)') 'Contact function values before RECEIVE:'
6494         do i=nnt,nct-2
6495           write (iout,'(2i3,50(1x,i2,f5.2))')
6496      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6497      &    j=1,num_cont_hb(i))
6498         enddo
6499       endif
6500       call flush(iout)
6501       do i=1,ntask_cont_from
6502         ncont_recv(i)=0
6503       enddo
6504       do i=1,ntask_cont_to
6505         ncont_sent(i)=0
6506       enddo
6507 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6508 c     & ntask_cont_to
6509 C Make the list of contacts to send to send to other procesors
6510       do i=iturn3_start,iturn3_end
6511 c        write (iout,*) "make contact list turn3",i," num_cont",
6512 c     &    num_cont_hb(i)
6513         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6514       enddo
6515       do i=iturn4_start,iturn4_end
6516 c        write (iout,*) "make contact list turn4",i," num_cont",
6517 c     &   num_cont_hb(i)
6518         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6519       enddo
6520       do ii=1,nat_sent
6521         i=iat_sent(ii)
6522 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6523 c     &    num_cont_hb(i)
6524         do j=1,num_cont_hb(i)
6525         do k=1,4
6526           jjc=jcont_hb(j,i)
6527           iproc=iint_sent_local(k,jjc,ii)
6528 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6529           if (iproc.ne.0) then
6530             ncont_sent(iproc)=ncont_sent(iproc)+1
6531             nn=ncont_sent(iproc)
6532             zapas(1,nn,iproc)=i
6533             zapas(2,nn,iproc)=jjc
6534             zapas(3,nn,iproc)=d_cont(j,i)
6535             ind=3
6536             do kk=1,3
6537               ind=ind+1
6538               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6539             enddo
6540             do kk=1,2
6541               do ll=1,2
6542                 ind=ind+1
6543                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6544               enddo
6545             enddo
6546             do jj=1,5
6547               do kk=1,3
6548                 do ll=1,2
6549                   do mm=1,2
6550                     ind=ind+1
6551                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6552                   enddo
6553                 enddo
6554               enddo
6555             enddo
6556           endif
6557         enddo
6558         enddo
6559       enddo
6560       if (lprn) then
6561       write (iout,*)
6562      &  "Numbers of contacts to be sent to other processors",
6563      &  (ncont_sent(i),i=1,ntask_cont_to)
6564       write (iout,*) "Contacts sent"
6565       do ii=1,ntask_cont_to
6566         nn=ncont_sent(ii)
6567         iproc=itask_cont_to(ii)
6568         write (iout,*) nn," contacts to processor",iproc,
6569      &   " of CONT_TO_COMM group"
6570         do i=1,nn
6571           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6572         enddo
6573       enddo
6574       call flush(iout)
6575       endif
6576       CorrelType=477
6577       CorrelID=fg_rank+1
6578       CorrelType1=478
6579       CorrelID1=nfgtasks+fg_rank+1
6580       ireq=0
6581 C Receive the numbers of needed contacts from other processors
6582       do ii=1,ntask_cont_from
6583         iproc=itask_cont_from(ii)
6584         ireq=ireq+1
6585         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6586      &    FG_COMM,req(ireq),IERR)
6587       enddo
6588 c      write (iout,*) "IRECV ended"
6589 c      call flush(iout)
6590 C Send the number of contacts needed by other processors
6591       do ii=1,ntask_cont_to
6592         iproc=itask_cont_to(ii)
6593         ireq=ireq+1
6594         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6595      &    FG_COMM,req(ireq),IERR)
6596       enddo
6597 c      write (iout,*) "ISEND ended"
6598 c      write (iout,*) "number of requests (nn)",ireq
6599       call flush(iout)
6600       if (ireq.gt.0)
6601      &  call MPI_Waitall(ireq,req,status_array,ierr)
6602 c      write (iout,*)
6603 c     &  "Numbers of contacts to be received from other processors",
6604 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6605 c      call flush(iout)
6606 C Receive contacts
6607       ireq=0
6608       do ii=1,ntask_cont_from
6609         iproc=itask_cont_from(ii)
6610         nn=ncont_recv(ii)
6611 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6612 c     &   " of CONT_TO_COMM group"
6613         call flush(iout)
6614         if (nn.gt.0) then
6615           ireq=ireq+1
6616           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6617      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6618 c          write (iout,*) "ireq,req",ireq,req(ireq)
6619         endif
6620       enddo
6621 C Send the contacts to processors that need them
6622       do ii=1,ntask_cont_to
6623         iproc=itask_cont_to(ii)
6624         nn=ncont_sent(ii)
6625 c        write (iout,*) nn," contacts to processor",iproc,
6626 c     &   " of CONT_TO_COMM group"
6627         if (nn.gt.0) then
6628           ireq=ireq+1
6629           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6630      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6631 c          write (iout,*) "ireq,req",ireq,req(ireq)
6632 c          do i=1,nn
6633 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6634 c          enddo
6635         endif
6636       enddo
6637 c      write (iout,*) "number of requests (contacts)",ireq
6638 c      write (iout,*) "req",(req(i),i=1,4)
6639 c      call flush(iout)
6640       if (ireq.gt.0)
6641      & call MPI_Waitall(ireq,req,status_array,ierr)
6642       do iii=1,ntask_cont_from
6643         iproc=itask_cont_from(iii)
6644         nn=ncont_recv(iii)
6645         if (lprn) then
6646         write (iout,*) "Received",nn," contacts from processor",iproc,
6647      &   " of CONT_FROM_COMM group"
6648         call flush(iout)
6649         do i=1,nn
6650           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6651         enddo
6652         call flush(iout)
6653         endif
6654         do i=1,nn
6655           ii=zapas_recv(1,i,iii)
6656 c Flag the received contacts to prevent double-counting
6657           jj=-zapas_recv(2,i,iii)
6658 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6659 c          call flush(iout)
6660           nnn=num_cont_hb(ii)+1
6661           num_cont_hb(ii)=nnn
6662           jcont_hb(nnn,ii)=jj
6663           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6664           ind=3
6665           do kk=1,3
6666             ind=ind+1
6667             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6668           enddo
6669           do kk=1,2
6670             do ll=1,2
6671               ind=ind+1
6672               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6673             enddo
6674           enddo
6675           do jj=1,5
6676             do kk=1,3
6677               do ll=1,2
6678                 do mm=1,2
6679                   ind=ind+1
6680                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6681                 enddo
6682               enddo
6683             enddo
6684           enddo
6685         enddo
6686       enddo
6687       call flush(iout)
6688       if (lprn) then
6689         write (iout,'(a)') 'Contact function values after receive:'
6690         do i=nnt,nct-2
6691           write (iout,'(2i3,50(1x,i3,5f6.3))')
6692      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6693      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6694         enddo
6695         call flush(iout)
6696       endif
6697    30 continue
6698 #endif
6699       if (lprn) then
6700         write (iout,'(a)') 'Contact function values:'
6701         do i=nnt,nct-2
6702           write (iout,'(2i3,50(1x,i2,5f6.3))')
6703      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6704      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6705         enddo
6706       endif
6707       ecorr=0.0D0
6708       ecorr5=0.0d0
6709       ecorr6=0.0d0
6710 C Remove the loop below after debugging !!!
6711       do i=nnt,nct
6712         do j=1,3
6713           gradcorr(j,i)=0.0D0
6714           gradxorr(j,i)=0.0D0
6715         enddo
6716       enddo
6717 C Calculate the dipole-dipole interaction energies
6718       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6719       do i=iatel_s,iatel_e+1
6720         num_conti=num_cont_hb(i)
6721         do jj=1,num_conti
6722           j=jcont_hb(jj,i)
6723 #ifdef MOMENT
6724           call dipole(i,j,jj)
6725 #endif
6726         enddo
6727       enddo
6728       endif
6729 C Calculate the local-electrostatic correlation terms
6730 c                write (iout,*) "gradcorr5 in eello5 before loop"
6731 c                do iii=1,nres
6732 c                  write (iout,'(i5,3f10.5)')
6733 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6734 c                enddo
6735       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6736 c        write (iout,*) "corr loop i",i
6737         i1=i+1
6738         num_conti=num_cont_hb(i)
6739         num_conti1=num_cont_hb(i+1)
6740         do jj=1,num_conti
6741           j=jcont_hb(jj,i)
6742           jp=iabs(j)
6743           do kk=1,num_conti1
6744             j1=jcont_hb(kk,i1)
6745             jp1=iabs(j1)
6746 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6747 c     &         ' jj=',jj,' kk=',kk
6748 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6749             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6750      &          .or. j.lt.0 .and. j1.gt.0) .and.
6751      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6752 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6753 C The system gains extra energy.
6754               n_corr=n_corr+1
6755               sqd1=dsqrt(d_cont(jj,i))
6756               sqd2=dsqrt(d_cont(kk,i1))
6757               sred_geom = sqd1*sqd2
6758               IF (sred_geom.lt.cutoff_corr) THEN
6759                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6760      &            ekont,fprimcont)
6761 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6762 cd     &         ' jj=',jj,' kk=',kk
6763                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6764                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6765                 do l=1,3
6766                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6767                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6768                 enddo
6769                 n_corr1=n_corr1+1
6770 cd               write (iout,*) 'sred_geom=',sred_geom,
6771 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6772 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6773 cd               write (iout,*) "g_contij",g_contij
6774 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6775 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6776                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6777                 if (wcorr4.gt.0.0d0)
6778      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6779                   if (energy_dec.and.wcorr4.gt.0.0d0)
6780      1                 write (iout,'(a6,4i5,0pf7.3)')
6781      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6782 c                write (iout,*) "gradcorr5 before eello5"
6783 c                do iii=1,nres
6784 c                  write (iout,'(i5,3f10.5)')
6785 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6786 c                enddo
6787                 if (wcorr5.gt.0.0d0)
6788      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6789 c                write (iout,*) "gradcorr5 after eello5"
6790 c                do iii=1,nres
6791 c                  write (iout,'(i5,3f10.5)')
6792 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6793 c                enddo
6794                   if (energy_dec.and.wcorr5.gt.0.0d0)
6795      1                 write (iout,'(a6,4i5,0pf7.3)')
6796      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6797 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6798 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6799                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6800      &               .or. wturn6.eq.0.0d0))then
6801 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6802                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6803                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6804      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6805 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6806 cd     &            'ecorr6=',ecorr6
6807 cd                write (iout,'(4e15.5)') sred_geom,
6808 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6809 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6810 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6811                 else if (wturn6.gt.0.0d0
6812      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6813 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6814                   eturn6=eturn6+eello_turn6(i,jj,kk)
6815                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6816      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6817 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6818                 endif
6819               ENDIF
6820 1111          continue
6821             endif
6822           enddo ! kk
6823         enddo ! jj
6824       enddo ! i
6825       do i=1,nres
6826         num_cont_hb(i)=num_cont_hb_old(i)
6827       enddo
6828 c                write (iout,*) "gradcorr5 in eello5"
6829 c                do iii=1,nres
6830 c                  write (iout,'(i5,3f10.5)')
6831 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6832 c                enddo
6833       return
6834       end
6835 c------------------------------------------------------------------------------
6836       subroutine add_hb_contact_eello(ii,jj,itask)
6837       implicit real*8 (a-h,o-z)
6838       include "DIMENSIONS"
6839       include "COMMON.IOUNITS"
6840       integer max_cont
6841       integer max_dim
6842       parameter (max_cont=maxconts)
6843       parameter (max_dim=70)
6844       include "COMMON.CONTACTS"
6845       double precision zapas(max_dim,maxconts,max_fg_procs),
6846      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6847       common /przechowalnia/ zapas
6848       integer i,j,ii,jj,iproc,itask(4),nn
6849 c      write (iout,*) "itask",itask
6850       do i=1,2
6851         iproc=itask(i)
6852         if (iproc.gt.0) then
6853           do j=1,num_cont_hb(ii)
6854             jjc=jcont_hb(j,ii)
6855 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6856             if (jjc.eq.jj) then
6857               ncont_sent(iproc)=ncont_sent(iproc)+1
6858               nn=ncont_sent(iproc)
6859               zapas(1,nn,iproc)=ii
6860               zapas(2,nn,iproc)=jjc
6861               zapas(3,nn,iproc)=d_cont(j,ii)
6862               ind=3
6863               do kk=1,3
6864                 ind=ind+1
6865                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6866               enddo
6867               do kk=1,2
6868                 do ll=1,2
6869                   ind=ind+1
6870                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6871                 enddo
6872               enddo
6873               do jj=1,5
6874                 do kk=1,3
6875                   do ll=1,2
6876                     do mm=1,2
6877                       ind=ind+1
6878                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6879                     enddo
6880                   enddo
6881                 enddo
6882               enddo
6883               exit
6884             endif
6885           enddo
6886         endif
6887       enddo
6888       return
6889       end
6890 c------------------------------------------------------------------------------
6891       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6892       implicit real*8 (a-h,o-z)
6893       include 'DIMENSIONS'
6894       include 'COMMON.IOUNITS'
6895       include 'COMMON.DERIV'
6896       include 'COMMON.INTERACT'
6897       include 'COMMON.CONTACTS'
6898       double precision gx(3),gx1(3)
6899       logical lprn
6900       lprn=.false.
6901       eij=facont_hb(jj,i)
6902       ekl=facont_hb(kk,k)
6903       ees0pij=ees0p(jj,i)
6904       ees0pkl=ees0p(kk,k)
6905       ees0mij=ees0m(jj,i)
6906       ees0mkl=ees0m(kk,k)
6907       ekont=eij*ekl
6908       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6909 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6910 C Following 4 lines for diagnostics.
6911 cd    ees0pkl=0.0D0
6912 cd    ees0pij=1.0D0
6913 cd    ees0mkl=0.0D0
6914 cd    ees0mij=1.0D0
6915 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6916 c     & 'Contacts ',i,j,
6917 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6918 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6919 c     & 'gradcorr_long'
6920 C Calculate the multi-body contribution to energy.
6921 c      ecorr=ecorr+ekont*ees
6922 C Calculate multi-body contributions to the gradient.
6923       coeffpees0pij=coeffp*ees0pij
6924       coeffmees0mij=coeffm*ees0mij
6925       coeffpees0pkl=coeffp*ees0pkl
6926       coeffmees0mkl=coeffm*ees0mkl
6927       do ll=1,3
6928 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6929         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6930      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6931      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6932         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6933      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6934      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6935 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6936         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6937      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6938      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6939         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6940      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6941      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6942         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6943      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6944      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6945         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6946         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6947         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6948      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6949      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6950         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6951         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6952 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6953       enddo
6954 c      write (iout,*)
6955 cgrad      do m=i+1,j-1
6956 cgrad        do ll=1,3
6957 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6958 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6959 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6960 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6961 cgrad        enddo
6962 cgrad      enddo
6963 cgrad      do m=k+1,l-1
6964 cgrad        do ll=1,3
6965 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6966 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6967 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6968 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6969 cgrad        enddo
6970 cgrad      enddo
6971 c      write (iout,*) "ehbcorr",ekont*ees
6972       ehbcorr=ekont*ees
6973       return
6974       end
6975 #ifdef MOMENT
6976 C---------------------------------------------------------------------------
6977       subroutine dipole(i,j,jj)
6978       implicit real*8 (a-h,o-z)
6979       include 'DIMENSIONS'
6980       include 'COMMON.IOUNITS'
6981       include 'COMMON.CHAIN'
6982       include 'COMMON.FFIELD'
6983       include 'COMMON.DERIV'
6984       include 'COMMON.INTERACT'
6985       include 'COMMON.CONTACTS'
6986       include 'COMMON.TORSION'
6987       include 'COMMON.VAR'
6988       include 'COMMON.GEO'
6989       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6990      &  auxmat(2,2)
6991       iti1 = itortyp(itype(i+1))
6992       if (j.lt.nres-1) then
6993         itj1 = itortyp(itype(j+1))
6994       else
6995         itj1=ntortyp+1
6996       endif
6997       do iii=1,2
6998         dipi(iii,1)=Ub2(iii,i)
6999         dipderi(iii)=Ub2der(iii,i)
7000         dipi(iii,2)=b1(iii,iti1)
7001         dipj(iii,1)=Ub2(iii,j)
7002         dipderj(iii)=Ub2der(iii,j)
7003         dipj(iii,2)=b1(iii,itj1)
7004       enddo
7005       kkk=0
7006       do iii=1,2
7007         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7008         do jjj=1,2
7009           kkk=kkk+1
7010           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7011         enddo
7012       enddo
7013       do kkk=1,5
7014         do lll=1,3
7015           mmm=0
7016           do iii=1,2
7017             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7018      &        auxvec(1))
7019             do jjj=1,2
7020               mmm=mmm+1
7021               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7022             enddo
7023           enddo
7024         enddo
7025       enddo
7026       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7027       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7028       do iii=1,2
7029         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7030       enddo
7031       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7032       do iii=1,2
7033         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7034       enddo
7035       return
7036       end
7037 #endif
7038 C---------------------------------------------------------------------------
7039       subroutine calc_eello(i,j,k,l,jj,kk)
7040 C
7041 C This subroutine computes matrices and vectors needed to calculate
7042 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7043 C
7044       implicit real*8 (a-h,o-z)
7045       include 'DIMENSIONS'
7046       include 'COMMON.IOUNITS'
7047       include 'COMMON.CHAIN'
7048       include 'COMMON.DERIV'
7049       include 'COMMON.INTERACT'
7050       include 'COMMON.CONTACTS'
7051       include 'COMMON.TORSION'
7052       include 'COMMON.VAR'
7053       include 'COMMON.GEO'
7054       include 'COMMON.FFIELD'
7055       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7056      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7057       logical lprn
7058       common /kutas/ lprn
7059 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7060 cd     & ' jj=',jj,' kk=',kk
7061 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7062 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7063 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7064       do iii=1,2
7065         do jjj=1,2
7066           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7067           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7068         enddo
7069       enddo
7070       call transpose2(aa1(1,1),aa1t(1,1))
7071       call transpose2(aa2(1,1),aa2t(1,1))
7072       do kkk=1,5
7073         do lll=1,3
7074           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7075      &      aa1tder(1,1,lll,kkk))
7076           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7077      &      aa2tder(1,1,lll,kkk))
7078         enddo
7079       enddo
7080       if (l.eq.j+1) then
7081 C parallel orientation of the two CA-CA-CA frames.
7082         if (i.gt.1) then
7083           iti=itortyp(itype(i))
7084         else
7085           iti=ntortyp+1
7086         endif
7087         itk1=itortyp(itype(k+1))
7088         itj=itortyp(itype(j))
7089         if (l.lt.nres-1) then
7090           itl1=itortyp(itype(l+1))
7091         else
7092           itl1=ntortyp+1
7093         endif
7094 C A1 kernel(j+1) A2T
7095 cd        do iii=1,2
7096 cd          write (iout,'(3f10.5,5x,3f10.5)')
7097 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7098 cd        enddo
7099         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7100      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7101      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7102 C Following matrices are needed only for 6-th order cumulants
7103         IF (wcorr6.gt.0.0d0) THEN
7104         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7105      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7106      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7107         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7108      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7109      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7110      &   ADtEAderx(1,1,1,1,1,1))
7111         lprn=.false.
7112         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7113      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7114      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7115      &   ADtEA1derx(1,1,1,1,1,1))
7116         ENDIF
7117 C End 6-th order cumulants
7118 cd        lprn=.false.
7119 cd        if (lprn) then
7120 cd        write (2,*) 'In calc_eello6'
7121 cd        do iii=1,2
7122 cd          write (2,*) 'iii=',iii
7123 cd          do kkk=1,5
7124 cd            write (2,*) 'kkk=',kkk
7125 cd            do jjj=1,2
7126 cd              write (2,'(3(2f10.5),5x)')
7127 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7128 cd            enddo
7129 cd          enddo
7130 cd        enddo
7131 cd        endif
7132         call transpose2(EUgder(1,1,k),auxmat(1,1))
7133         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7134         call transpose2(EUg(1,1,k),auxmat(1,1))
7135         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7136         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7137         do iii=1,2
7138           do kkk=1,5
7139             do lll=1,3
7140               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7141      &          EAEAderx(1,1,lll,kkk,iii,1))
7142             enddo
7143           enddo
7144         enddo
7145 C A1T kernel(i+1) A2
7146         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7147      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7148      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7149 C Following matrices are needed only for 6-th order cumulants
7150         IF (wcorr6.gt.0.0d0) THEN
7151         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7152      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7153      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7154         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7155      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7156      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7157      &   ADtEAderx(1,1,1,1,1,2))
7158         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7159      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7160      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7161      &   ADtEA1derx(1,1,1,1,1,2))
7162         ENDIF
7163 C End 6-th order cumulants
7164         call transpose2(EUgder(1,1,l),auxmat(1,1))
7165         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7166         call transpose2(EUg(1,1,l),auxmat(1,1))
7167         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7168         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7169         do iii=1,2
7170           do kkk=1,5
7171             do lll=1,3
7172               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7173      &          EAEAderx(1,1,lll,kkk,iii,2))
7174             enddo
7175           enddo
7176         enddo
7177 C AEAb1 and AEAb2
7178 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7179 C They are needed only when the fifth- or the sixth-order cumulants are
7180 C indluded.
7181         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7182         call transpose2(AEA(1,1,1),auxmat(1,1))
7183         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7184         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7185         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7186         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7187         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7188         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7189         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7190         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7191         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7192         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7193         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7194         call transpose2(AEA(1,1,2),auxmat(1,1))
7195         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7196         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7197         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7198         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7199         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7200         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7201         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7202         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7203         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7204         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7205         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7206 C Calculate the Cartesian derivatives of the vectors.
7207         do iii=1,2
7208           do kkk=1,5
7209             do lll=1,3
7210               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7211               call matvec2(auxmat(1,1),b1(1,iti),
7212      &          AEAb1derx(1,lll,kkk,iii,1,1))
7213               call matvec2(auxmat(1,1),Ub2(1,i),
7214      &          AEAb2derx(1,lll,kkk,iii,1,1))
7215               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7216      &          AEAb1derx(1,lll,kkk,iii,2,1))
7217               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7218      &          AEAb2derx(1,lll,kkk,iii,2,1))
7219               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7220               call matvec2(auxmat(1,1),b1(1,itj),
7221      &          AEAb1derx(1,lll,kkk,iii,1,2))
7222               call matvec2(auxmat(1,1),Ub2(1,j),
7223      &          AEAb2derx(1,lll,kkk,iii,1,2))
7224               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7225      &          AEAb1derx(1,lll,kkk,iii,2,2))
7226               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7227      &          AEAb2derx(1,lll,kkk,iii,2,2))
7228             enddo
7229           enddo
7230         enddo
7231         ENDIF
7232 C End vectors
7233       else
7234 C Antiparallel orientation of the two CA-CA-CA frames.
7235         if (i.gt.1) then
7236           iti=itortyp(itype(i))
7237         else
7238           iti=ntortyp+1
7239         endif
7240         itk1=itortyp(itype(k+1))
7241         itl=itortyp(itype(l))
7242         itj=itortyp(itype(j))
7243         if (j.lt.nres-1) then
7244           itj1=itortyp(itype(j+1))
7245         else
7246           itj1=ntortyp+1
7247         endif
7248 C A2 kernel(j-1)T A1T
7249         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7250      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7251      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7252 C Following matrices are needed only for 6-th order cumulants
7253         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7254      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7255         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7256      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7257      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7258         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7259      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7260      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7261      &   ADtEAderx(1,1,1,1,1,1))
7262         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7263      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7264      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7265      &   ADtEA1derx(1,1,1,1,1,1))
7266         ENDIF
7267 C End 6-th order cumulants
7268         call transpose2(EUgder(1,1,k),auxmat(1,1))
7269         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7270         call transpose2(EUg(1,1,k),auxmat(1,1))
7271         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7272         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7273         do iii=1,2
7274           do kkk=1,5
7275             do lll=1,3
7276               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7277      &          EAEAderx(1,1,lll,kkk,iii,1))
7278             enddo
7279           enddo
7280         enddo
7281 C A2T kernel(i+1)T A1
7282         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7283      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7284      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7285 C Following matrices are needed only for 6-th order cumulants
7286         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7287      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7288         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7289      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7290      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7291         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7292      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7293      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7294      &   ADtEAderx(1,1,1,1,1,2))
7295         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7296      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7297      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7298      &   ADtEA1derx(1,1,1,1,1,2))
7299         ENDIF
7300 C End 6-th order cumulants
7301         call transpose2(EUgder(1,1,j),auxmat(1,1))
7302         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7303         call transpose2(EUg(1,1,j),auxmat(1,1))
7304         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7305         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7306         do iii=1,2
7307           do kkk=1,5
7308             do lll=1,3
7309               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7310      &          EAEAderx(1,1,lll,kkk,iii,2))
7311             enddo
7312           enddo
7313         enddo
7314 C AEAb1 and AEAb2
7315 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7316 C They are needed only when the fifth- or the sixth-order cumulants are
7317 C indluded.
7318         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7319      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7320         call transpose2(AEA(1,1,1),auxmat(1,1))
7321         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7322         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7323         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7324         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7325         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7326         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7327         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7328         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7329         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7330         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7331         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7332         call transpose2(AEA(1,1,2),auxmat(1,1))
7333         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7334         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7335         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7336         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7337         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7338         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7339         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7340         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7341         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7342         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7343         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7344 C Calculate the Cartesian derivatives of the vectors.
7345         do iii=1,2
7346           do kkk=1,5
7347             do lll=1,3
7348               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7349               call matvec2(auxmat(1,1),b1(1,iti),
7350      &          AEAb1derx(1,lll,kkk,iii,1,1))
7351               call matvec2(auxmat(1,1),Ub2(1,i),
7352      &          AEAb2derx(1,lll,kkk,iii,1,1))
7353               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7354      &          AEAb1derx(1,lll,kkk,iii,2,1))
7355               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7356      &          AEAb2derx(1,lll,kkk,iii,2,1))
7357               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7358               call matvec2(auxmat(1,1),b1(1,itl),
7359      &          AEAb1derx(1,lll,kkk,iii,1,2))
7360               call matvec2(auxmat(1,1),Ub2(1,l),
7361      &          AEAb2derx(1,lll,kkk,iii,1,2))
7362               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7363      &          AEAb1derx(1,lll,kkk,iii,2,2))
7364               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7365      &          AEAb2derx(1,lll,kkk,iii,2,2))
7366             enddo
7367           enddo
7368         enddo
7369         ENDIF
7370 C End vectors
7371       endif
7372       return
7373       end
7374 C---------------------------------------------------------------------------
7375       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7376      &  KK,KKderg,AKA,AKAderg,AKAderx)
7377       implicit none
7378       integer nderg
7379       logical transp
7380       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7381      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7382      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7383       integer iii,kkk,lll
7384       integer jjj,mmm
7385       logical lprn
7386       common /kutas/ lprn
7387       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7388       do iii=1,nderg
7389         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7390      &    AKAderg(1,1,iii))
7391       enddo
7392 cd      if (lprn) write (2,*) 'In kernel'
7393       do kkk=1,5
7394 cd        if (lprn) write (2,*) 'kkk=',kkk
7395         do lll=1,3
7396           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7397      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7398 cd          if (lprn) then
7399 cd            write (2,*) 'lll=',lll
7400 cd            write (2,*) 'iii=1'
7401 cd            do jjj=1,2
7402 cd              write (2,'(3(2f10.5),5x)')
7403 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7404 cd            enddo
7405 cd          endif
7406           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7407      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7408 cd          if (lprn) then
7409 cd            write (2,*) 'lll=',lll
7410 cd            write (2,*) 'iii=2'
7411 cd            do jjj=1,2
7412 cd              write (2,'(3(2f10.5),5x)')
7413 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7414 cd            enddo
7415 cd          endif
7416         enddo
7417       enddo
7418       return
7419       end
7420 C---------------------------------------------------------------------------
7421       double precision function eello4(i,j,k,l,jj,kk)
7422       implicit real*8 (a-h,o-z)
7423       include 'DIMENSIONS'
7424       include 'COMMON.IOUNITS'
7425       include 'COMMON.CHAIN'
7426       include 'COMMON.DERIV'
7427       include 'COMMON.INTERACT'
7428       include 'COMMON.CONTACTS'
7429       include 'COMMON.TORSION'
7430       include 'COMMON.VAR'
7431       include 'COMMON.GEO'
7432       double precision pizda(2,2),ggg1(3),ggg2(3)
7433 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7434 cd        eello4=0.0d0
7435 cd        return
7436 cd      endif
7437 cd      print *,'eello4:',i,j,k,l,jj,kk
7438 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7439 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7440 cold      eij=facont_hb(jj,i)
7441 cold      ekl=facont_hb(kk,k)
7442 cold      ekont=eij*ekl
7443       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7444 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7445       gcorr_loc(k-1)=gcorr_loc(k-1)
7446      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7447       if (l.eq.j+1) then
7448         gcorr_loc(l-1)=gcorr_loc(l-1)
7449      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7450       else
7451         gcorr_loc(j-1)=gcorr_loc(j-1)
7452      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7453       endif
7454       do iii=1,2
7455         do kkk=1,5
7456           do lll=1,3
7457             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7458      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7459 cd            derx(lll,kkk,iii)=0.0d0
7460           enddo
7461         enddo
7462       enddo
7463 cd      gcorr_loc(l-1)=0.0d0
7464 cd      gcorr_loc(j-1)=0.0d0
7465 cd      gcorr_loc(k-1)=0.0d0
7466 cd      eel4=1.0d0
7467 cd      write (iout,*)'Contacts have occurred for peptide groups',
7468 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7469 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7470       if (j.lt.nres-1) then
7471         j1=j+1
7472         j2=j-1
7473       else
7474         j1=j-1
7475         j2=j-2
7476       endif
7477       if (l.lt.nres-1) then
7478         l1=l+1
7479         l2=l-1
7480       else
7481         l1=l-1
7482         l2=l-2
7483       endif
7484       do ll=1,3
7485 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7486 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7487         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7488         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7489 cgrad        ghalf=0.5d0*ggg1(ll)
7490         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7491         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7492         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7493         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7494         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7495         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7496 cgrad        ghalf=0.5d0*ggg2(ll)
7497         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7498         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7499         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7500         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7501         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7502         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7503       enddo
7504 cgrad      do m=i+1,j-1
7505 cgrad        do ll=1,3
7506 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7507 cgrad        enddo
7508 cgrad      enddo
7509 cgrad      do m=k+1,l-1
7510 cgrad        do ll=1,3
7511 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7512 cgrad        enddo
7513 cgrad      enddo
7514 cgrad      do m=i+2,j2
7515 cgrad        do ll=1,3
7516 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7517 cgrad        enddo
7518 cgrad      enddo
7519 cgrad      do m=k+2,l2
7520 cgrad        do ll=1,3
7521 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7522 cgrad        enddo
7523 cgrad      enddo
7524 cd      do iii=1,nres-3
7525 cd        write (2,*) iii,gcorr_loc(iii)
7526 cd      enddo
7527       eello4=ekont*eel4
7528 cd      write (2,*) 'ekont',ekont
7529 cd      write (iout,*) 'eello4',ekont*eel4
7530       return
7531       end
7532 C---------------------------------------------------------------------------
7533       double precision function eello5(i,j,k,l,jj,kk)
7534       implicit real*8 (a-h,o-z)
7535       include 'DIMENSIONS'
7536       include 'COMMON.IOUNITS'
7537       include 'COMMON.CHAIN'
7538       include 'COMMON.DERIV'
7539       include 'COMMON.INTERACT'
7540       include 'COMMON.CONTACTS'
7541       include 'COMMON.TORSION'
7542       include 'COMMON.VAR'
7543       include 'COMMON.GEO'
7544       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7545       double precision ggg1(3),ggg2(3)
7546 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7547 C                                                                              C
7548 C                            Parallel chains                                   C
7549 C                                                                              C
7550 C          o             o                   o             o                   C
7551 C         /l\           / \             \   / \           / \   /              C
7552 C        /   \         /   \             \ /   \         /   \ /               C
7553 C       j| o |l1       | o |              o| o |         | o |o                C
7554 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7555 C      \i/   \         /   \ /             /   \         /   \                 C
7556 C       o    k1             o                                                  C
7557 C         (I)          (II)                (III)          (IV)                 C
7558 C                                                                              C
7559 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7560 C                                                                              C
7561 C                            Antiparallel chains                               C
7562 C                                                                              C
7563 C          o             o                   o             o                   C
7564 C         /j\           / \             \   / \           / \   /              C
7565 C        /   \         /   \             \ /   \         /   \ /               C
7566 C      j1| o |l        | o |              o| o |         | o |o                C
7567 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7568 C      \i/   \         /   \ /             /   \         /   \                 C
7569 C       o     k1            o                                                  C
7570 C         (I)          (II)                (III)          (IV)                 C
7571 C                                                                              C
7572 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7573 C                                                                              C
7574 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7575 C                                                                              C
7576 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7577 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7578 cd        eello5=0.0d0
7579 cd        return
7580 cd      endif
7581 cd      write (iout,*)
7582 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7583 cd     &   ' and',k,l
7584       itk=itortyp(itype(k))
7585       itl=itortyp(itype(l))
7586       itj=itortyp(itype(j))
7587       eello5_1=0.0d0
7588       eello5_2=0.0d0
7589       eello5_3=0.0d0
7590       eello5_4=0.0d0
7591 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7592 cd     &   eel5_3_num,eel5_4_num)
7593       do iii=1,2
7594         do kkk=1,5
7595           do lll=1,3
7596             derx(lll,kkk,iii)=0.0d0
7597           enddo
7598         enddo
7599       enddo
7600 cd      eij=facont_hb(jj,i)
7601 cd      ekl=facont_hb(kk,k)
7602 cd      ekont=eij*ekl
7603 cd      write (iout,*)'Contacts have occurred for peptide groups',
7604 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7605 cd      goto 1111
7606 C Contribution from the graph I.
7607 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7608 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7609       call transpose2(EUg(1,1,k),auxmat(1,1))
7610       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7611       vv(1)=pizda(1,1)-pizda(2,2)
7612       vv(2)=pizda(1,2)+pizda(2,1)
7613       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7614      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7615 C Explicit gradient in virtual-dihedral angles.
7616       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7617      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7618      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7619       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7620       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7621       vv(1)=pizda(1,1)-pizda(2,2)
7622       vv(2)=pizda(1,2)+pizda(2,1)
7623       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7624      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7625      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7626       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7627       vv(1)=pizda(1,1)-pizda(2,2)
7628       vv(2)=pizda(1,2)+pizda(2,1)
7629       if (l.eq.j+1) then
7630         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7631      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7632      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7633       else
7634         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7635      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7636      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7637       endif
7638 C Cartesian gradient
7639       do iii=1,2
7640         do kkk=1,5
7641           do lll=1,3
7642             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7643      &        pizda(1,1))
7644             vv(1)=pizda(1,1)-pizda(2,2)
7645             vv(2)=pizda(1,2)+pizda(2,1)
7646             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7647      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7648      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7649           enddo
7650         enddo
7651       enddo
7652 c      goto 1112
7653 c1111  continue
7654 C Contribution from graph II
7655       call transpose2(EE(1,1,itk),auxmat(1,1))
7656       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7657       vv(1)=pizda(1,1)+pizda(2,2)
7658       vv(2)=pizda(2,1)-pizda(1,2)
7659       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7660      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7661 C Explicit gradient in virtual-dihedral angles.
7662       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7663      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7664       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7665       vv(1)=pizda(1,1)+pizda(2,2)
7666       vv(2)=pizda(2,1)-pizda(1,2)
7667       if (l.eq.j+1) then
7668         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7669      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7670      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7671       else
7672         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7673      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7674      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7675       endif
7676 C Cartesian gradient
7677       do iii=1,2
7678         do kkk=1,5
7679           do lll=1,3
7680             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7681      &        pizda(1,1))
7682             vv(1)=pizda(1,1)+pizda(2,2)
7683             vv(2)=pizda(2,1)-pizda(1,2)
7684             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7685      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7686      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7687           enddo
7688         enddo
7689       enddo
7690 cd      goto 1112
7691 cd1111  continue
7692       if (l.eq.j+1) then
7693 cd        goto 1110
7694 C Parallel orientation
7695 C Contribution from graph III
7696         call transpose2(EUg(1,1,l),auxmat(1,1))
7697         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7698         vv(1)=pizda(1,1)-pizda(2,2)
7699         vv(2)=pizda(1,2)+pizda(2,1)
7700         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7701      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7702 C Explicit gradient in virtual-dihedral angles.
7703         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7704      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7705      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7706         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7707         vv(1)=pizda(1,1)-pizda(2,2)
7708         vv(2)=pizda(1,2)+pizda(2,1)
7709         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7710      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7711      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7712         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7713         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7714         vv(1)=pizda(1,1)-pizda(2,2)
7715         vv(2)=pizda(1,2)+pizda(2,1)
7716         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7717      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7718      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7719 C Cartesian gradient
7720         do iii=1,2
7721           do kkk=1,5
7722             do lll=1,3
7723               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7724      &          pizda(1,1))
7725               vv(1)=pizda(1,1)-pizda(2,2)
7726               vv(2)=pizda(1,2)+pizda(2,1)
7727               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7728      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7729      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7730             enddo
7731           enddo
7732         enddo
7733 cd        goto 1112
7734 C Contribution from graph IV
7735 cd1110    continue
7736         call transpose2(EE(1,1,itl),auxmat(1,1))
7737         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7738         vv(1)=pizda(1,1)+pizda(2,2)
7739         vv(2)=pizda(2,1)-pizda(1,2)
7740         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7741      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7742 C Explicit gradient in virtual-dihedral angles.
7743         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7744      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7745         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7746         vv(1)=pizda(1,1)+pizda(2,2)
7747         vv(2)=pizda(2,1)-pizda(1,2)
7748         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7749      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7750      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7751 C Cartesian gradient
7752         do iii=1,2
7753           do kkk=1,5
7754             do lll=1,3
7755               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7756      &          pizda(1,1))
7757               vv(1)=pizda(1,1)+pizda(2,2)
7758               vv(2)=pizda(2,1)-pizda(1,2)
7759               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7760      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7761      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7762             enddo
7763           enddo
7764         enddo
7765       else
7766 C Antiparallel orientation
7767 C Contribution from graph III
7768 c        goto 1110
7769         call transpose2(EUg(1,1,j),auxmat(1,1))
7770         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7771         vv(1)=pizda(1,1)-pizda(2,2)
7772         vv(2)=pizda(1,2)+pizda(2,1)
7773         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7774      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7775 C Explicit gradient in virtual-dihedral angles.
7776         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7777      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7778      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7779         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7780         vv(1)=pizda(1,1)-pizda(2,2)
7781         vv(2)=pizda(1,2)+pizda(2,1)
7782         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7783      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7784      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7785         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7786         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7787         vv(1)=pizda(1,1)-pizda(2,2)
7788         vv(2)=pizda(1,2)+pizda(2,1)
7789         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7790      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7791      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7792 C Cartesian gradient
7793         do iii=1,2
7794           do kkk=1,5
7795             do lll=1,3
7796               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7797      &          pizda(1,1))
7798               vv(1)=pizda(1,1)-pizda(2,2)
7799               vv(2)=pizda(1,2)+pizda(2,1)
7800               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7801      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7802      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7803             enddo
7804           enddo
7805         enddo
7806 cd        goto 1112
7807 C Contribution from graph IV
7808 1110    continue
7809         call transpose2(EE(1,1,itj),auxmat(1,1))
7810         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7811         vv(1)=pizda(1,1)+pizda(2,2)
7812         vv(2)=pizda(2,1)-pizda(1,2)
7813         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7814      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7815 C Explicit gradient in virtual-dihedral angles.
7816         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7817      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7818         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7819         vv(1)=pizda(1,1)+pizda(2,2)
7820         vv(2)=pizda(2,1)-pizda(1,2)
7821         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7822      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7823      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7824 C Cartesian gradient
7825         do iii=1,2
7826           do kkk=1,5
7827             do lll=1,3
7828               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7829      &          pizda(1,1))
7830               vv(1)=pizda(1,1)+pizda(2,2)
7831               vv(2)=pizda(2,1)-pizda(1,2)
7832               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7833      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7834      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7835             enddo
7836           enddo
7837         enddo
7838       endif
7839 1112  continue
7840       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7841 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7842 cd        write (2,*) 'ijkl',i,j,k,l
7843 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7844 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7845 cd      endif
7846 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7847 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7848 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7849 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7850       if (j.lt.nres-1) then
7851         j1=j+1
7852         j2=j-1
7853       else
7854         j1=j-1
7855         j2=j-2
7856       endif
7857       if (l.lt.nres-1) then
7858         l1=l+1
7859         l2=l-1
7860       else
7861         l1=l-1
7862         l2=l-2
7863       endif
7864 cd      eij=1.0d0
7865 cd      ekl=1.0d0
7866 cd      ekont=1.0d0
7867 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7868 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7869 C        summed up outside the subrouine as for the other subroutines
7870 C        handling long-range interactions. The old code is commented out
7871 C        with "cgrad" to keep track of changes.
7872       do ll=1,3
7873 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7874 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7875         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7876         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7877 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7878 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7879 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7880 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7881 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7882 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7883 c     &   gradcorr5ij,
7884 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7885 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7886 cgrad        ghalf=0.5d0*ggg1(ll)
7887 cd        ghalf=0.0d0
7888         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7889         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7890         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7891         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7892         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7893         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7894 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7895 cgrad        ghalf=0.5d0*ggg2(ll)
7896 cd        ghalf=0.0d0
7897         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7898         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7899         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7900         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7901         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7902         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7903       enddo
7904 cd      goto 1112
7905 cgrad      do m=i+1,j-1
7906 cgrad        do ll=1,3
7907 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7908 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7909 cgrad        enddo
7910 cgrad      enddo
7911 cgrad      do m=k+1,l-1
7912 cgrad        do ll=1,3
7913 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7914 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7915 cgrad        enddo
7916 cgrad      enddo
7917 c1112  continue
7918 cgrad      do m=i+2,j2
7919 cgrad        do ll=1,3
7920 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7921 cgrad        enddo
7922 cgrad      enddo
7923 cgrad      do m=k+2,l2
7924 cgrad        do ll=1,3
7925 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7926 cgrad        enddo
7927 cgrad      enddo
7928 cd      do iii=1,nres-3
7929 cd        write (2,*) iii,g_corr5_loc(iii)
7930 cd      enddo
7931       eello5=ekont*eel5
7932 cd      write (2,*) 'ekont',ekont
7933 cd      write (iout,*) 'eello5',ekont*eel5
7934       return
7935       end
7936 c--------------------------------------------------------------------------
7937       double precision function eello6(i,j,k,l,jj,kk)
7938       implicit real*8 (a-h,o-z)
7939       include 'DIMENSIONS'
7940       include 'COMMON.IOUNITS'
7941       include 'COMMON.CHAIN'
7942       include 'COMMON.DERIV'
7943       include 'COMMON.INTERACT'
7944       include 'COMMON.CONTACTS'
7945       include 'COMMON.TORSION'
7946       include 'COMMON.VAR'
7947       include 'COMMON.GEO'
7948       include 'COMMON.FFIELD'
7949       double precision ggg1(3),ggg2(3)
7950 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7951 cd        eello6=0.0d0
7952 cd        return
7953 cd      endif
7954 cd      write (iout,*)
7955 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7956 cd     &   ' and',k,l
7957       eello6_1=0.0d0
7958       eello6_2=0.0d0
7959       eello6_3=0.0d0
7960       eello6_4=0.0d0
7961       eello6_5=0.0d0
7962       eello6_6=0.0d0
7963 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7964 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7965       do iii=1,2
7966         do kkk=1,5
7967           do lll=1,3
7968             derx(lll,kkk,iii)=0.0d0
7969           enddo
7970         enddo
7971       enddo
7972 cd      eij=facont_hb(jj,i)
7973 cd      ekl=facont_hb(kk,k)
7974 cd      ekont=eij*ekl
7975 cd      eij=1.0d0
7976 cd      ekl=1.0d0
7977 cd      ekont=1.0d0
7978       if (l.eq.j+1) then
7979         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7980         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7981         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7982         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7983         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7984         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7985       else
7986         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7987         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7988         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7989         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7990         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7991           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7992         else
7993           eello6_5=0.0d0
7994         endif
7995         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7996       endif
7997 C If turn contributions are considered, they will be handled separately.
7998       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7999 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8000 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8001 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8002 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8003 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8004 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8005 cd      goto 1112
8006       if (j.lt.nres-1) then
8007         j1=j+1
8008         j2=j-1
8009       else
8010         j1=j-1
8011         j2=j-2
8012       endif
8013       if (l.lt.nres-1) then
8014         l1=l+1
8015         l2=l-1
8016       else
8017         l1=l-1
8018         l2=l-2
8019       endif
8020       do ll=1,3
8021 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8022 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8023 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8024 cgrad        ghalf=0.5d0*ggg1(ll)
8025 cd        ghalf=0.0d0
8026         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8027         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8028         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8029         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8030         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8031         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8032         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8033         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8034 cgrad        ghalf=0.5d0*ggg2(ll)
8035 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8036 cd        ghalf=0.0d0
8037         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8038         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8039         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8040         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8041         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8042         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8043       enddo
8044 cd      goto 1112
8045 cgrad      do m=i+1,j-1
8046 cgrad        do ll=1,3
8047 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8048 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8049 cgrad        enddo
8050 cgrad      enddo
8051 cgrad      do m=k+1,l-1
8052 cgrad        do ll=1,3
8053 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8054 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8055 cgrad        enddo
8056 cgrad      enddo
8057 cgrad1112  continue
8058 cgrad      do m=i+2,j2
8059 cgrad        do ll=1,3
8060 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8061 cgrad        enddo
8062 cgrad      enddo
8063 cgrad      do m=k+2,l2
8064 cgrad        do ll=1,3
8065 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8066 cgrad        enddo
8067 cgrad      enddo
8068 cd      do iii=1,nres-3
8069 cd        write (2,*) iii,g_corr6_loc(iii)
8070 cd      enddo
8071       eello6=ekont*eel6
8072 cd      write (2,*) 'ekont',ekont
8073 cd      write (iout,*) 'eello6',ekont*eel6
8074       return
8075       end
8076 c--------------------------------------------------------------------------
8077       double precision function eello6_graph1(i,j,k,l,imat,swap)
8078       implicit real*8 (a-h,o-z)
8079       include 'DIMENSIONS'
8080       include 'COMMON.IOUNITS'
8081       include 'COMMON.CHAIN'
8082       include 'COMMON.DERIV'
8083       include 'COMMON.INTERACT'
8084       include 'COMMON.CONTACTS'
8085       include 'COMMON.TORSION'
8086       include 'COMMON.VAR'
8087       include 'COMMON.GEO'
8088       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8089       logical swap
8090       logical lprn
8091       common /kutas/ lprn
8092 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8093 C
8094 C      Parallel       Antiparallel
8095 C
8096 C          o             o
8097 C         /l\           /j\
8098 C        /   \         /   \
8099 C       /| o |         | o |\
8100 C     \ j|/k\|  /   \  |/k\|l /
8101 C      \ /   \ /     \ /   \ /
8102 C       o     o       o     o
8103 C       i             i
8104 C
8105 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8106       itk=itortyp(itype(k))
8107       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8108       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8109       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8110       call transpose2(EUgC(1,1,k),auxmat(1,1))
8111       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8112       vv1(1)=pizda1(1,1)-pizda1(2,2)
8113       vv1(2)=pizda1(1,2)+pizda1(2,1)
8114       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8115       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8116       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8117       s5=scalar2(vv(1),Dtobr2(1,i))
8118 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8119       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8120       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8121      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8122      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8123      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8124      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8125      & +scalar2(vv(1),Dtobr2der(1,i)))
8126       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8127       vv1(1)=pizda1(1,1)-pizda1(2,2)
8128       vv1(2)=pizda1(1,2)+pizda1(2,1)
8129       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8130       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8131       if (l.eq.j+1) then
8132         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8133      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8134      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8135      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8136      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8137       else
8138         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8139      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8140      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8141      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8142      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8143       endif
8144       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8145       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8146       vv1(1)=pizda1(1,1)-pizda1(2,2)
8147       vv1(2)=pizda1(1,2)+pizda1(2,1)
8148       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8149      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8150      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8151      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8152       do iii=1,2
8153         if (swap) then
8154           ind=3-iii
8155         else
8156           ind=iii
8157         endif
8158         do kkk=1,5
8159           do lll=1,3
8160             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8161             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8162             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8163             call transpose2(EUgC(1,1,k),auxmat(1,1))
8164             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8165      &        pizda1(1,1))
8166             vv1(1)=pizda1(1,1)-pizda1(2,2)
8167             vv1(2)=pizda1(1,2)+pizda1(2,1)
8168             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8169             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8170      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8171             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8172      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8173             s5=scalar2(vv(1),Dtobr2(1,i))
8174             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8175           enddo
8176         enddo
8177       enddo
8178       return
8179       end
8180 c----------------------------------------------------------------------------
8181       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8182       implicit real*8 (a-h,o-z)
8183       include 'DIMENSIONS'
8184       include 'COMMON.IOUNITS'
8185       include 'COMMON.CHAIN'
8186       include 'COMMON.DERIV'
8187       include 'COMMON.INTERACT'
8188       include 'COMMON.CONTACTS'
8189       include 'COMMON.TORSION'
8190       include 'COMMON.VAR'
8191       include 'COMMON.GEO'
8192       logical swap
8193       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8194      & auxvec1(2),auxvec2(1),auxmat1(2,2)
8195       logical lprn
8196       common /kutas/ lprn
8197 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8198 C                                                                              C
8199 C      Parallel       Antiparallel                                             C
8200 C                                                                              C
8201 C          o             o                                                     C
8202 C     \   /l\           /j\   /                                                C
8203 C      \ /   \         /   \ /                                                 C
8204 C       o| o |         | o |o                                                  C
8205 C     \ j|/k\|      \  |/k\|l                                                  C
8206 C      \ /   \       \ /   \                                                   C
8207 C       o             o                                                        C
8208 C       i             i                                                        C
8209 C                                                                              C
8210 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8211 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8212 C AL 7/4/01 s1 would occur in the sixth-order moment,
8213 C           but not in a cluster cumulant
8214 #ifdef MOMENT
8215       s1=dip(1,jj,i)*dip(1,kk,k)
8216 #endif
8217       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8218       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8219       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8220       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8221       call transpose2(EUg(1,1,k),auxmat(1,1))
8222       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8223       vv(1)=pizda(1,1)-pizda(2,2)
8224       vv(2)=pizda(1,2)+pizda(2,1)
8225       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8226 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8227 #ifdef MOMENT
8228       eello6_graph2=-(s1+s2+s3+s4)
8229 #else
8230       eello6_graph2=-(s2+s3+s4)
8231 #endif
8232 c      eello6_graph2=-s3
8233 C Derivatives in gamma(i-1)
8234       if (i.gt.1) then
8235 #ifdef MOMENT
8236         s1=dipderg(1,jj,i)*dip(1,kk,k)
8237 #endif
8238         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8239         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8240         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8241         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8242 #ifdef MOMENT
8243         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8244 #else
8245         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8246 #endif
8247 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8248       endif
8249 C Derivatives in gamma(k-1)
8250 #ifdef MOMENT
8251       s1=dip(1,jj,i)*dipderg(1,kk,k)
8252 #endif
8253       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8254       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8255       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8256       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8257       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8258       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8259       vv(1)=pizda(1,1)-pizda(2,2)
8260       vv(2)=pizda(1,2)+pizda(2,1)
8261       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8262 #ifdef MOMENT
8263       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8264 #else
8265       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8266 #endif
8267 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8268 C Derivatives in gamma(j-1) or gamma(l-1)
8269       if (j.gt.1) then
8270 #ifdef MOMENT
8271         s1=dipderg(3,jj,i)*dip(1,kk,k)
8272 #endif
8273         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8274         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8275         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8276         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8277         vv(1)=pizda(1,1)-pizda(2,2)
8278         vv(2)=pizda(1,2)+pizda(2,1)
8279         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8280 #ifdef MOMENT
8281         if (swap) then
8282           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8283         else
8284           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8285         endif
8286 #endif
8287         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8288 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8289       endif
8290 C Derivatives in gamma(l-1) or gamma(j-1)
8291       if (l.gt.1) then
8292 #ifdef MOMENT
8293         s1=dip(1,jj,i)*dipderg(3,kk,k)
8294 #endif
8295         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8296         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8297         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8298         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8299         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8300         vv(1)=pizda(1,1)-pizda(2,2)
8301         vv(2)=pizda(1,2)+pizda(2,1)
8302         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8303 #ifdef MOMENT
8304         if (swap) then
8305           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8306         else
8307           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8308         endif
8309 #endif
8310         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8311 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8312       endif
8313 C Cartesian derivatives.
8314       if (lprn) then
8315         write (2,*) 'In eello6_graph2'
8316         do iii=1,2
8317           write (2,*) 'iii=',iii
8318           do kkk=1,5
8319             write (2,*) 'kkk=',kkk
8320             do jjj=1,2
8321               write (2,'(3(2f10.5),5x)')
8322      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8323             enddo
8324           enddo
8325         enddo
8326       endif
8327       do iii=1,2
8328         do kkk=1,5
8329           do lll=1,3
8330 #ifdef MOMENT
8331             if (iii.eq.1) then
8332               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8333             else
8334               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8335             endif
8336 #endif
8337             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8338      &        auxvec(1))
8339             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8340             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8341      &        auxvec(1))
8342             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8343             call transpose2(EUg(1,1,k),auxmat(1,1))
8344             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8345      &        pizda(1,1))
8346             vv(1)=pizda(1,1)-pizda(2,2)
8347             vv(2)=pizda(1,2)+pizda(2,1)
8348             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8349 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8350 #ifdef MOMENT
8351             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8352 #else
8353             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8354 #endif
8355             if (swap) then
8356               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8357             else
8358               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8359             endif
8360           enddo
8361         enddo
8362       enddo
8363       return
8364       end
8365 c----------------------------------------------------------------------------
8366       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8367       implicit real*8 (a-h,o-z)
8368       include 'DIMENSIONS'
8369       include 'COMMON.IOUNITS'
8370       include 'COMMON.CHAIN'
8371       include 'COMMON.DERIV'
8372       include 'COMMON.INTERACT'
8373       include 'COMMON.CONTACTS'
8374       include 'COMMON.TORSION'
8375       include 'COMMON.VAR'
8376       include 'COMMON.GEO'
8377       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8378       logical swap
8379 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8380 C                                                                              C
8381 C      Parallel       Antiparallel                                             C
8382 C                                                                              C
8383 C          o             o                                                     C
8384 C         /l\   /   \   /j\                                                    C
8385 C        /   \ /     \ /   \                                                   C
8386 C       /| o |o       o| o |\                                                  C
8387 C       j|/k\|  /      |/k\|l /                                                C
8388 C        /   \ /       /   \ /                                                 C
8389 C       /     o       /     o                                                  C
8390 C       i             i                                                        C
8391 C                                                                              C
8392 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8393 C
8394 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8395 C           energy moment and not to the cluster cumulant.
8396       iti=itortyp(itype(i))
8397       if (j.lt.nres-1) then
8398         itj1=itortyp(itype(j+1))
8399       else
8400         itj1=ntortyp+1
8401       endif
8402       itk=itortyp(itype(k))
8403       itk1=itortyp(itype(k+1))
8404       if (l.lt.nres-1) then
8405         itl1=itortyp(itype(l+1))
8406       else
8407         itl1=ntortyp+1
8408       endif
8409 #ifdef MOMENT
8410       s1=dip(4,jj,i)*dip(4,kk,k)
8411 #endif
8412       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8413       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8414       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8415       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8416       call transpose2(EE(1,1,itk),auxmat(1,1))
8417       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8418       vv(1)=pizda(1,1)+pizda(2,2)
8419       vv(2)=pizda(2,1)-pizda(1,2)
8420       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8421 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8422 cd     & "sum",-(s2+s3+s4)
8423 #ifdef MOMENT
8424       eello6_graph3=-(s1+s2+s3+s4)
8425 #else
8426       eello6_graph3=-(s2+s3+s4)
8427 #endif
8428 c      eello6_graph3=-s4
8429 C Derivatives in gamma(k-1)
8430       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8431       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8432       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8433       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8434 C Derivatives in gamma(l-1)
8435       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8436       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8437       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8438       vv(1)=pizda(1,1)+pizda(2,2)
8439       vv(2)=pizda(2,1)-pizda(1,2)
8440       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8441       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8442 C Cartesian derivatives.
8443       do iii=1,2
8444         do kkk=1,5
8445           do lll=1,3
8446 #ifdef MOMENT
8447             if (iii.eq.1) then
8448               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8449             else
8450               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8451             endif
8452 #endif
8453             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8454      &        auxvec(1))
8455             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8456             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8457      &        auxvec(1))
8458             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8459             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8460      &        pizda(1,1))
8461             vv(1)=pizda(1,1)+pizda(2,2)
8462             vv(2)=pizda(2,1)-pizda(1,2)
8463             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8464 #ifdef MOMENT
8465             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8466 #else
8467             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8468 #endif
8469             if (swap) then
8470               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8471             else
8472               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8473             endif
8474 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8475           enddo
8476         enddo
8477       enddo
8478       return
8479       end
8480 c----------------------------------------------------------------------------
8481       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8482       implicit real*8 (a-h,o-z)
8483       include 'DIMENSIONS'
8484       include 'COMMON.IOUNITS'
8485       include 'COMMON.CHAIN'
8486       include 'COMMON.DERIV'
8487       include 'COMMON.INTERACT'
8488       include 'COMMON.CONTACTS'
8489       include 'COMMON.TORSION'
8490       include 'COMMON.VAR'
8491       include 'COMMON.GEO'
8492       include 'COMMON.FFIELD'
8493       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8494      & auxvec1(2),auxmat1(2,2)
8495       logical swap
8496 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8497 C                                                                              C
8498 C      Parallel       Antiparallel                                             C
8499 C                                                                              C
8500 C          o             o                                                     C
8501 C         /l\   /   \   /j\                                                    C
8502 C        /   \ /     \ /   \                                                   C
8503 C       /| o |o       o| o |\                                                  C
8504 C     \ j|/k\|      \  |/k\|l                                                  C
8505 C      \ /   \       \ /   \                                                   C
8506 C       o     \       o     \                                                  C
8507 C       i             i                                                        C
8508 C                                                                              C
8509 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8510 C
8511 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8512 C           energy moment and not to the cluster cumulant.
8513 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8514       iti=itortyp(itype(i))
8515       itj=itortyp(itype(j))
8516       if (j.lt.nres-1) then
8517         itj1=itortyp(itype(j+1))
8518       else
8519         itj1=ntortyp+1
8520       endif
8521       itk=itortyp(itype(k))
8522       if (k.lt.nres-1) then
8523         itk1=itortyp(itype(k+1))
8524       else
8525         itk1=ntortyp+1
8526       endif
8527       itl=itortyp(itype(l))
8528       if (l.lt.nres-1) then
8529         itl1=itortyp(itype(l+1))
8530       else
8531         itl1=ntortyp+1
8532       endif
8533 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8534 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8535 cd     & ' itl',itl,' itl1',itl1
8536 #ifdef MOMENT
8537       if (imat.eq.1) then
8538         s1=dip(3,jj,i)*dip(3,kk,k)
8539       else
8540         s1=dip(2,jj,j)*dip(2,kk,l)
8541       endif
8542 #endif
8543       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8544       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8545       if (j.eq.l+1) then
8546         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8547         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8548       else
8549         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8550         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8551       endif
8552       call transpose2(EUg(1,1,k),auxmat(1,1))
8553       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8554       vv(1)=pizda(1,1)-pizda(2,2)
8555       vv(2)=pizda(2,1)+pizda(1,2)
8556       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8557 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8558 #ifdef MOMENT
8559       eello6_graph4=-(s1+s2+s3+s4)
8560 #else
8561       eello6_graph4=-(s2+s3+s4)
8562 #endif
8563 C Derivatives in gamma(i-1)
8564       if (i.gt.1) then
8565 #ifdef MOMENT
8566         if (imat.eq.1) then
8567           s1=dipderg(2,jj,i)*dip(3,kk,k)
8568         else
8569           s1=dipderg(4,jj,j)*dip(2,kk,l)
8570         endif
8571 #endif
8572         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8573         if (j.eq.l+1) then
8574           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8575           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8576         else
8577           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8578           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8579         endif
8580         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8581         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8582 cd          write (2,*) 'turn6 derivatives'
8583 #ifdef MOMENT
8584           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8585 #else
8586           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8587 #endif
8588         else
8589 #ifdef MOMENT
8590           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8591 #else
8592           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8593 #endif
8594         endif
8595       endif
8596 C Derivatives in gamma(k-1)
8597 #ifdef MOMENT
8598       if (imat.eq.1) then
8599         s1=dip(3,jj,i)*dipderg(2,kk,k)
8600       else
8601         s1=dip(2,jj,j)*dipderg(4,kk,l)
8602       endif
8603 #endif
8604       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8605       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8606       if (j.eq.l+1) then
8607         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8608         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8609       else
8610         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8611         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8612       endif
8613       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8614       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8615       vv(1)=pizda(1,1)-pizda(2,2)
8616       vv(2)=pizda(2,1)+pizda(1,2)
8617       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8618       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8619 #ifdef MOMENT
8620         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8621 #else
8622         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8623 #endif
8624       else
8625 #ifdef MOMENT
8626         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8627 #else
8628         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8629 #endif
8630       endif
8631 C Derivatives in gamma(j-1) or gamma(l-1)
8632       if (l.eq.j+1 .and. l.gt.1) then
8633         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8634         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8635         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8636         vv(1)=pizda(1,1)-pizda(2,2)
8637         vv(2)=pizda(2,1)+pizda(1,2)
8638         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8639         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8640       else if (j.gt.1) then
8641         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8642         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8643         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8644         vv(1)=pizda(1,1)-pizda(2,2)
8645         vv(2)=pizda(2,1)+pizda(1,2)
8646         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8647         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8648           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8649         else
8650           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8651         endif
8652       endif
8653 C Cartesian derivatives.
8654       do iii=1,2
8655         do kkk=1,5
8656           do lll=1,3
8657 #ifdef MOMENT
8658             if (iii.eq.1) then
8659               if (imat.eq.1) then
8660                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8661               else
8662                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8663               endif
8664             else
8665               if (imat.eq.1) then
8666                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8667               else
8668                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8669               endif
8670             endif
8671 #endif
8672             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8673      &        auxvec(1))
8674             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8675             if (j.eq.l+1) then
8676               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8677      &          b1(1,itj1),auxvec(1))
8678               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8679             else
8680               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8681      &          b1(1,itl1),auxvec(1))
8682               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8683             endif
8684             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8685      &        pizda(1,1))
8686             vv(1)=pizda(1,1)-pizda(2,2)
8687             vv(2)=pizda(2,1)+pizda(1,2)
8688             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8689             if (swap) then
8690               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8691 #ifdef MOMENT
8692                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8693      &             -(s1+s2+s4)
8694 #else
8695                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8696      &             -(s2+s4)
8697 #endif
8698                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8699               else
8700 #ifdef MOMENT
8701                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8702 #else
8703                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8704 #endif
8705                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8706               endif
8707             else
8708 #ifdef MOMENT
8709               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8710 #else
8711               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8712 #endif
8713               if (l.eq.j+1) then
8714                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8715               else
8716                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8717               endif
8718             endif
8719           enddo
8720         enddo
8721       enddo
8722       return
8723       end
8724 c----------------------------------------------------------------------------
8725       double precision function eello_turn6(i,jj,kk)
8726       implicit real*8 (a-h,o-z)
8727       include 'DIMENSIONS'
8728       include 'COMMON.IOUNITS'
8729       include 'COMMON.CHAIN'
8730       include 'COMMON.DERIV'
8731       include 'COMMON.INTERACT'
8732       include 'COMMON.CONTACTS'
8733       include 'COMMON.TORSION'
8734       include 'COMMON.VAR'
8735       include 'COMMON.GEO'
8736       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8737      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8738      &  ggg1(3),ggg2(3)
8739       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8740      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8741 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8742 C           the respective energy moment and not to the cluster cumulant.
8743       s1=0.0d0
8744       s8=0.0d0
8745       s13=0.0d0
8746 c
8747       eello_turn6=0.0d0
8748       j=i+4
8749       k=i+1
8750       l=i+3
8751       iti=itortyp(itype(i))
8752       itk=itortyp(itype(k))
8753       itk1=itortyp(itype(k+1))
8754       itl=itortyp(itype(l))
8755       itj=itortyp(itype(j))
8756 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8757 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8758 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8759 cd        eello6=0.0d0
8760 cd        return
8761 cd      endif
8762 cd      write (iout,*)
8763 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8764 cd     &   ' and',k,l
8765 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8766       do iii=1,2
8767         do kkk=1,5
8768           do lll=1,3
8769             derx_turn(lll,kkk,iii)=0.0d0
8770           enddo
8771         enddo
8772       enddo
8773 cd      eij=1.0d0
8774 cd      ekl=1.0d0
8775 cd      ekont=1.0d0
8776       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8777 cd      eello6_5=0.0d0
8778 cd      write (2,*) 'eello6_5',eello6_5
8779 #ifdef MOMENT
8780       call transpose2(AEA(1,1,1),auxmat(1,1))
8781       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8782       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8783       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8784 #endif
8785       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8786       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8787       s2 = scalar2(b1(1,itk),vtemp1(1))
8788 #ifdef MOMENT
8789       call transpose2(AEA(1,1,2),atemp(1,1))
8790       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8791       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8792       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8793 #endif
8794       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8795       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8796       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8797 #ifdef MOMENT
8798       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8799       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8800       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8801       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8802       ss13 = scalar2(b1(1,itk),vtemp4(1))
8803       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8804 #endif
8805 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8806 c      s1=0.0d0
8807 c      s2=0.0d0
8808 c      s8=0.0d0
8809 c      s12=0.0d0
8810 c      s13=0.0d0
8811       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8812 C Derivatives in gamma(i+2)
8813       s1d =0.0d0
8814       s8d =0.0d0
8815 #ifdef MOMENT
8816       call transpose2(AEA(1,1,1),auxmatd(1,1))
8817       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8818       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8819       call transpose2(AEAderg(1,1,2),atempd(1,1))
8820       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8821       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8822 #endif
8823       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8824       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8825       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8826 c      s1d=0.0d0
8827 c      s2d=0.0d0
8828 c      s8d=0.0d0
8829 c      s12d=0.0d0
8830 c      s13d=0.0d0
8831       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8832 C Derivatives in gamma(i+3)
8833 #ifdef MOMENT
8834       call transpose2(AEA(1,1,1),auxmatd(1,1))
8835       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8836       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8837       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8838 #endif
8839       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8840       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8841       s2d = scalar2(b1(1,itk),vtemp1d(1))
8842 #ifdef MOMENT
8843       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8844       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8845 #endif
8846       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8847 #ifdef MOMENT
8848       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8849       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8850       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8851 #endif
8852 c      s1d=0.0d0
8853 c      s2d=0.0d0
8854 c      s8d=0.0d0
8855 c      s12d=0.0d0
8856 c      s13d=0.0d0
8857 #ifdef MOMENT
8858       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8859      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8860 #else
8861       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8862      &               -0.5d0*ekont*(s2d+s12d)
8863 #endif
8864 C Derivatives in gamma(i+4)
8865       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8866       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8867       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8868 #ifdef MOMENT
8869       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8870       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8871       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8872 #endif
8873 c      s1d=0.0d0
8874 c      s2d=0.0d0
8875 c      s8d=0.0d0
8876 C      s12d=0.0d0
8877 c      s13d=0.0d0
8878 #ifdef MOMENT
8879       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8880 #else
8881       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8882 #endif
8883 C Derivatives in gamma(i+5)
8884 #ifdef MOMENT
8885       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8886       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8887       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8888 #endif
8889       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8890       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8891       s2d = scalar2(b1(1,itk),vtemp1d(1))
8892 #ifdef MOMENT
8893       call transpose2(AEA(1,1,2),atempd(1,1))
8894       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8895       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8896 #endif
8897       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8898       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8899 #ifdef MOMENT
8900       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8901       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8902       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8903 #endif
8904 c      s1d=0.0d0
8905 c      s2d=0.0d0
8906 c      s8d=0.0d0
8907 c      s12d=0.0d0
8908 c      s13d=0.0d0
8909 #ifdef MOMENT
8910       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8911      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8912 #else
8913       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8914      &               -0.5d0*ekont*(s2d+s12d)
8915 #endif
8916 C Cartesian derivatives
8917       do iii=1,2
8918         do kkk=1,5
8919           do lll=1,3
8920 #ifdef MOMENT
8921             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8922             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8923             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8924 #endif
8925             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8926             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8927      &          vtemp1d(1))
8928             s2d = scalar2(b1(1,itk),vtemp1d(1))
8929 #ifdef MOMENT
8930             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8931             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8932             s8d = -(atempd(1,1)+atempd(2,2))*
8933      &           scalar2(cc(1,1,itl),vtemp2(1))
8934 #endif
8935             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8936      &           auxmatd(1,1))
8937             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8938             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8939 c      s1d=0.0d0
8940 c      s2d=0.0d0
8941 c      s8d=0.0d0
8942 c      s12d=0.0d0
8943 c      s13d=0.0d0
8944 #ifdef MOMENT
8945             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8946      &        - 0.5d0*(s1d+s2d)
8947 #else
8948             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8949      &        - 0.5d0*s2d
8950 #endif
8951 #ifdef MOMENT
8952             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8953      &        - 0.5d0*(s8d+s12d)
8954 #else
8955             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8956      &        - 0.5d0*s12d
8957 #endif
8958           enddo
8959         enddo
8960       enddo
8961 #ifdef MOMENT
8962       do kkk=1,5
8963         do lll=1,3
8964           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8965      &      achuj_tempd(1,1))
8966           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8967           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8968           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8969           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8970           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8971      &      vtemp4d(1))
8972           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8973           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8974           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8975         enddo
8976       enddo
8977 #endif
8978 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8979 cd     &  16*eel_turn6_num
8980 cd      goto 1112
8981       if (j.lt.nres-1) then
8982         j1=j+1
8983         j2=j-1
8984       else
8985         j1=j-1
8986         j2=j-2
8987       endif
8988       if (l.lt.nres-1) then
8989         l1=l+1
8990         l2=l-1
8991       else
8992         l1=l-1
8993         l2=l-2
8994       endif
8995       do ll=1,3
8996 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
8997 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
8998 cgrad        ghalf=0.5d0*ggg1(ll)
8999 cd        ghalf=0.0d0
9000         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9001         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9002         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9003      &    +ekont*derx_turn(ll,2,1)
9004         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9005         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9006      &    +ekont*derx_turn(ll,4,1)
9007         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9008         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9009         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9010 cgrad        ghalf=0.5d0*ggg2(ll)
9011 cd        ghalf=0.0d0
9012         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9013      &    +ekont*derx_turn(ll,2,2)
9014         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9015         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9016      &    +ekont*derx_turn(ll,4,2)
9017         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9018         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9019         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9020       enddo
9021 cd      goto 1112
9022 cgrad      do m=i+1,j-1
9023 cgrad        do ll=1,3
9024 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9025 cgrad        enddo
9026 cgrad      enddo
9027 cgrad      do m=k+1,l-1
9028 cgrad        do ll=1,3
9029 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9030 cgrad        enddo
9031 cgrad      enddo
9032 cgrad1112  continue
9033 cgrad      do m=i+2,j2
9034 cgrad        do ll=1,3
9035 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9036 cgrad        enddo
9037 cgrad      enddo
9038 cgrad      do m=k+2,l2
9039 cgrad        do ll=1,3
9040 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9041 cgrad        enddo
9042 cgrad      enddo
9043 cd      do iii=1,nres-3
9044 cd        write (2,*) iii,g_corr6_loc(iii)
9045 cd      enddo
9046       eello_turn6=ekont*eel_turn6
9047 cd      write (2,*) 'ekont',ekont
9048 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9049       return
9050       end
9051
9052 C-----------------------------------------------------------------------------
9053       double precision function scalar(u,v)
9054 !DIR$ INLINEALWAYS scalar
9055 #ifndef OSF
9056 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9057 #endif
9058       implicit none
9059       double precision u(3),v(3)
9060 cd      double precision sc
9061 cd      integer i
9062 cd      sc=0.0d0
9063 cd      do i=1,3
9064 cd        sc=sc+u(i)*v(i)
9065 cd      enddo
9066 cd      scalar=sc
9067
9068       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9069       return
9070       end
9071 crc-------------------------------------------------
9072       SUBROUTINE MATVEC2(A1,V1,V2)
9073 !DIR$ INLINEALWAYS MATVEC2
9074 #ifndef OSF
9075 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9076 #endif
9077       implicit real*8 (a-h,o-z)
9078       include 'DIMENSIONS'
9079       DIMENSION A1(2,2),V1(2),V2(2)
9080 c      DO 1 I=1,2
9081 c        VI=0.0
9082 c        DO 3 K=1,2
9083 c    3     VI=VI+A1(I,K)*V1(K)
9084 c        Vaux(I)=VI
9085 c    1 CONTINUE
9086
9087       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9088       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9089
9090       v2(1)=vaux1
9091       v2(2)=vaux2
9092       END
9093 C---------------------------------------
9094       SUBROUTINE MATMAT2(A1,A2,A3)
9095 #ifndef OSF
9096 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9097 #endif
9098       implicit real*8 (a-h,o-z)
9099       include 'DIMENSIONS'
9100       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9101 c      DIMENSION AI3(2,2)
9102 c        DO  J=1,2
9103 c          A3IJ=0.0
9104 c          DO K=1,2
9105 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9106 c          enddo
9107 c          A3(I,J)=A3IJ
9108 c       enddo
9109 c      enddo
9110
9111       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9112       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9113       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9114       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9115
9116       A3(1,1)=AI3_11
9117       A3(2,1)=AI3_21
9118       A3(1,2)=AI3_12
9119       A3(2,2)=AI3_22
9120       END
9121
9122 c-------------------------------------------------------------------------
9123       double precision function scalar2(u,v)
9124 !DIR$ INLINEALWAYS scalar2
9125       implicit none
9126       double precision u(2),v(2)
9127       double precision sc
9128       integer i
9129       scalar2=u(1)*v(1)+u(2)*v(2)
9130       return
9131       end
9132
9133 C-----------------------------------------------------------------------------
9134
9135       subroutine transpose2(a,at)
9136 !DIR$ INLINEALWAYS transpose2
9137 #ifndef OSF
9138 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9139 #endif
9140       implicit none
9141       double precision a(2,2),at(2,2)
9142       at(1,1)=a(1,1)
9143       at(1,2)=a(2,1)
9144       at(2,1)=a(1,2)
9145       at(2,2)=a(2,2)
9146       return
9147       end
9148 c--------------------------------------------------------------------------
9149       subroutine transpose(n,a,at)
9150       implicit none
9151       integer n,i,j
9152       double precision a(n,n),at(n,n)
9153       do i=1,n
9154         do j=1,n
9155           at(j,i)=a(i,j)
9156         enddo
9157       enddo
9158       return
9159       end
9160 C---------------------------------------------------------------------------
9161       subroutine prodmat3(a1,a2,kk,transp,prod)
9162 !DIR$ INLINEALWAYS prodmat3
9163 #ifndef OSF
9164 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9165 #endif
9166       implicit none
9167       integer i,j
9168       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9169       logical transp
9170 crc      double precision auxmat(2,2),prod_(2,2)
9171
9172       if (transp) then
9173 crc        call transpose2(kk(1,1),auxmat(1,1))
9174 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9175 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9176
9177            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9178      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9179            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9180      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9181            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9182      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9183            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9184      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9185
9186       else
9187 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9188 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9189
9190            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9191      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9192            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9193      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9194            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9195      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9196            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9197      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9198
9199       endif
9200 c      call transpose2(a2(1,1),a2t(1,1))
9201
9202 crc      print *,transp
9203 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9204 crc      print *,((prod(i,j),i=1,2),j=1,2)
9205
9206       return
9207       end
9208