source/unres/src_MD/energy_p_new_barrier.F

   1       subroutine etotal(energia)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4 #ifndef ISNAN
   5       external proc_proc
   6 #ifdef WINPGI
   7 cMS$ATTRIBUTES C ::  proc_proc
   8 #endif
   9 #endif
  10 #ifdef MPI
  11       include "mpif.h"
  12       double precision weights_(n_ene)
  13 #endif
  14       include 'COMMON.SETUP'
  15       include 'COMMON.IOUNITS'
  16       double precision energia(0:n_ene)
  17       include 'COMMON.LOCAL'
  18       include 'COMMON.FFIELD'
  19       include 'COMMON.DERIV'
  20       include 'COMMON.INTERACT'
  21       include 'COMMON.SBRIDGE'
  22       include 'COMMON.CHAIN'
  23       include 'COMMON.VAR'
  24       include 'COMMON.MD'
  25       include 'COMMON.CONTROL'
  26       include 'COMMON.TIME1'
  27 #ifdef MPI
  28 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  29 c     & " nfgtasks",nfgtasks
  30       if (nfgtasks.gt.1) then
  31 #ifdef MPI
  32         time00=MPI_Wtime()
  33 #else
  34         time00=tcpu()
  35 #endif
  36 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  37         if (fg_rank.eq.0) then
  38           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  39 c          print *,"Processor",myrank," BROADCAST iorder"
  40 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  41 C FG slaves as WEIGHTS array.
  42           weights_(1)=wsc
  43           weights_(2)=wscp
  44           weights_(3)=welec
  45           weights_(4)=wcorr
  46           weights_(5)=wcorr5
  47           weights_(6)=wcorr6
  48           weights_(7)=wel_loc
  49           weights_(8)=wturn3
  50           weights_(9)=wturn4
  51           weights_(10)=wturn6
  52           weights_(11)=wang
  53           weights_(12)=wscloc
  54           weights_(13)=wtor
  55           weights_(14)=wtor_d
  56           weights_(15)=wstrain
  57           weights_(16)=wvdwpp
  58           weights_(17)=wbond
  59           weights_(18)=scal14
  60           weights_(21)=wsccor
  61           weights_(22)=wsct
  62 C FG Master broadcasts the WEIGHTS_ array
  63           call MPI_Bcast(weights_(1),n_ene,
  64      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  65         else
  66 C FG slaves receive the WEIGHTS array
  67           call MPI_Bcast(weights(1),n_ene,
  68      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  69           wsc=weights(1)
  70           wscp=weights(2)
  71           welec=weights(3)
  72           wcorr=weights(4)
  73           wcorr5=weights(5)
  74           wcorr6=weights(6)
  75           wel_loc=weights(7)
  76           wturn3=weights(8)
  77           wturn4=weights(9)
  78           wturn6=weights(10)
  79           wang=weights(11)
  80           wscloc=weights(12)
  81           wtor=weights(13)
  82           wtor_d=weights(14)
  83           wstrain=weights(15)
  84           wvdwpp=weights(16)
  85           wbond=weights(17)
  86           scal14=weights(18)
  87           wsccor=weights(21)
  88           wsct=weights(22)
  89         endif
  90         time_Bcast=time_Bcast+MPI_Wtime()-time00
  91         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  92 c        call chainbuild_cart
  93       endif
  94 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
  95 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  96 #else
  97 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  98 c        call int_from_cart1(.false.)
  99 c      endif
 100 #endif
 101 #ifdef TIMING
 102 #ifdef MPI
 103       time00=MPI_Wtime()
 104 #else
 105       time00=tcpu()
 106 #endif
 107 #endif
 108 C
 109 C Compute the side-chain and electrostatic interaction energy
 110 C
 111       goto (101,102,103,104,105,106) ipot
 112 C Lennard-Jones potential.
 113   101 call elj(evdw,evdw_p,evdw_m)
 114 cd    print '(a)','Exit ELJ'
 115       goto 107
 116 C Lennard-Jones-Kihara potential (shifted).
 117   102 call eljk(evdw,evdw_p,evdw_m)
 118       goto 107
 119 C Berne-Pechukas potential (dilated LJ, angular dependence).
 120   103 call ebp(evdw,evdw_p,evdw_m)
 121       goto 107
 122 C Gay-Berne potential (shifted LJ, angular dependence).
 123   104 call egb(evdw,evdw_p,evdw_m)
 124       goto 107
 125 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 126   105 call egbv(evdw,evdw_p,evdw_m)
 127       goto 107
 128 C Soft-sphere potential
 129   106 call e_softsphere(evdw)
 130 C
 131 C Calculate electrostatic (H-bonding) energy of the main chain.
 132 C
 133   107 continue
 134 c      print *,"Processor",myrank," computed USCSC"
 135 #ifdef TIMING
 136 #ifdef MPI
 137       time01=MPI_Wtime()
 138 #else
 139       time00=tcpu()
 140 #endif
 141 #endif
 142       call vec_and_deriv
 143 #ifdef TIMING
 144 #ifdef MPI
 145       time_vec=time_vec+MPI_Wtime()-time01
 146 #else
 147       time_vec=time_vec+tcpu()-time01
 148 #endif
 149 #endif
 150 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 151       if (ipot.lt.6) then
 152 #ifdef SPLITELE
 153          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 154      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 155      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 156      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 157 #else
 158          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 159      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 160      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 161      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 162 #endif
 163             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 164          else
 165             ees=0.0d0
 166             evdw1=0.0d0
 167             eel_loc=0.0d0
 168             eello_turn3=0.0d0
 169             eello_turn4=0.0d0
 170          endif
 171       else
 172 c        write (iout,*) "Soft-spheer ELEC potential"
 173         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 174      &   eello_turn4)
 175       endif
 176 c      print *,"Processor",myrank," computed UELEC"
 177 C
 178 C Calculate excluded-volume interaction energy between peptide groups
 179 C and side chains.
 180 C
 181       if (ipot.lt.6) then
 182        if(wscp.gt.0d0) then
 183         call escp(evdw2,evdw2_14)
 184        else
 185         evdw2=0
 186         evdw2_14=0
 187        endif
 188       else
 189 c        write (iout,*) "Soft-sphere SCP potential"
 190         call escp_soft_sphere(evdw2,evdw2_14)
 191       endif
 192 c
 193 c Calculate the bond-stretching energy
 194 c
 195       call ebond(estr)
 196 C
 197 C Calculate the disulfide-bridge and other energy and the contributions
 198 C from other distance constraints.
 199 cd    print *,'Calling EHPB'
 200       call edis(ehpb)
 201 cd    print *,'EHPB exitted succesfully.'
 202 C
 203 C Calculate the virtual-bond-angle energy.
 204 C
 205       if (wang.gt.0d0) then
 206         call ebend(ebe)
 207       else
 208         ebe=0
 209       endif
 210 c      print *,"Processor",myrank," computed UB"
 211 C
 212 C Calculate the SC local energy.
 213 C
 214       call esc(escloc)
 215 c      print *,"Processor",myrank," computed USC"
 216 C
 217 C Calculate the virtual-bond torsional energy.
 218 C
 219 cd    print *,'nterm=',nterm
 220       if (wtor.gt.0) then
 221        call etor(etors,edihcnstr)
 222       else
 223        etors=0
 224        edihcnstr=0
 225       endif
 226 c      print *,"Processor",myrank," computed Utor"
 227 C
 228 C 6/23/01 Calculate double-torsional energy
 229 C
 230       if (wtor_d.gt.0) then
 231        call etor_d(etors_d)
 232       else
 233        etors_d=0
 234       endif
 235 c      print *,"Processor",myrank," computed Utord"
 236 C
 237 C 21/5/07 Calculate local sicdechain correlation energy
 238 C
 239       if (wsccor.gt.0.0d0) then
 240         call eback_sc_corr(esccor)
 241       else
 242         esccor=0.0d0
 243       endif
 244 c      print *,"Processor",myrank," computed Usccorr"
 245 C
 246 C 12/1/95 Multi-body terms
 247 C
 248       n_corr=0
 249       n_corr1=0
 250       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 251      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 252          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 253 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 254 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 255       else
 256          ecorr=0.0d0
 257          ecorr5=0.0d0
 258          ecorr6=0.0d0
 259          eturn6=0.0d0
 260       endif
 261       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 262          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 263 cd         write (iout,*) "multibody_hb ecorr",ecorr
 264       endif
 265 c      print *,"Processor",myrank," computed Ucorr"
 266 C
 267 C If performing constraint dynamics, call the constraint energy
 268 C  after the equilibration time
 269       if(usampl.and.totT.gt.eq_time) then
 270          call EconstrQ
 271          call Econstr_back
 272       else
 273          Uconst=0.0d0
 274          Uconst_back=0.0d0
 275       endif
 276 #ifdef TIMING
 277 #ifdef MPI
 278       time_enecalc=time_enecalc+MPI_Wtime()-time00
 279 #else
 280       time_enecalc=time_enecalc+tcpu()-time00
 281 #endif
 282 #endif
 283 c      print *,"Processor",myrank," computed Uconstr"
 284 #ifdef TIMING
 285 #ifdef MPI
 286       time00=MPI_Wtime()
 287 #else
 288       time00=tcpu()
 289 #endif
 290 #endif
 291 c
 292 C Sum the energies
 293 C
 294       energia(1)=evdw
 295 #ifdef SCP14
 296       energia(2)=evdw2-evdw2_14
 297       energia(18)=evdw2_14
 298 #else
 299       energia(2)=evdw2
 300       energia(18)=0.0d0
 301 #endif
 302 #ifdef SPLITELE
 303       energia(3)=ees
 304       energia(16)=evdw1
 305 #else
 306       energia(3)=ees+evdw1
 307       energia(16)=0.0d0
 308 #endif
 309       energia(4)=ecorr
 310       energia(5)=ecorr5
 311       energia(6)=ecorr6
 312       energia(7)=eel_loc
 313       energia(8)=eello_turn3
 314       energia(9)=eello_turn4
 315       energia(10)=eturn6
 316       energia(11)=ebe
 317       energia(12)=escloc
 318       energia(13)=etors
 319       energia(14)=etors_d
 320       energia(15)=ehpb
 321       energia(19)=edihcnstr
 322       energia(17)=estr
 323       energia(20)=Uconst+Uconst_back
 324       energia(21)=esccor
 325       energia(22)=evdw_p
 326       energia(23)=evdw_m
 327 c      print *," Processor",myrank," calls SUM_ENERGY"
 328       call sum_energy(energia,.true.)
 329 c      print *," Processor",myrank," left SUM_ENERGY"
 330 #ifdef TIMING
 331 #ifdef MPI
 332       time_sumene=time_sumene+MPI_Wtime()-time00
 333 #else
 334       time_sumene=time_sumene+tcpu()-time00
 335 #endif
 336 #endif
 337       return
 338       end
 339 c-------------------------------------------------------------------------------
 340       subroutine sum_energy(energia,reduce)
 341       implicit real*8 (a-h,o-z)
 342       include 'DIMENSIONS'
 343 #ifndef ISNAN
 344       external proc_proc
 345 #ifdef WINPGI
 346 cMS$ATTRIBUTES C ::  proc_proc
 347 #endif
 348 #endif
 349 #ifdef MPI
 350       include "mpif.h"
 351 #endif
 352       include 'COMMON.SETUP'
 353       include 'COMMON.IOUNITS'
 354       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 355       include 'COMMON.FFIELD'
 356       include 'COMMON.DERIV'
 357       include 'COMMON.INTERACT'
 358       include 'COMMON.SBRIDGE'
 359       include 'COMMON.CHAIN'
 360       include 'COMMON.VAR'
 361       include 'COMMON.CONTROL'
 362       include 'COMMON.TIME1'
 363       logical reduce
 364 #ifdef MPI
 365       if (nfgtasks.gt.1 .and. reduce) then
 366 #ifdef DEBUG
 367         write (iout,*) "energies before REDUCE"
 368         call enerprint(energia)
 369         call flush(iout)
 370 #endif
 371         do i=0,n_ene
 372           enebuff(i)=energia(i)
 373         enddo
 374         time00=MPI_Wtime()
 375         call MPI_Barrier(FG_COMM,IERR)
 376         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 377         time00=MPI_Wtime()
 378         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 379      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 380 #ifdef DEBUG
 381         write (iout,*) "energies after REDUCE"
 382         call enerprint(energia)
 383         call flush(iout)
 384 #endif
 385         time_Reduce=time_Reduce+MPI_Wtime()-time00
 386       endif
 387       if (fg_rank.eq.0) then
 388 #endif
 389 #ifdef TSCSC
 390       evdw=energia(22)+wsct*energia(23)
 391 #else
 392       evdw=energia(1)
 393 #endif
 394 #ifdef SCP14
 395       evdw2=energia(2)+energia(18)
 396       evdw2_14=energia(18)
 397 #else
 398       evdw2=energia(2)
 399 #endif
 400 #ifdef SPLITELE
 401       ees=energia(3)
 402       evdw1=energia(16)
 403 #else
 404       ees=energia(3)
 405       evdw1=0.0d0
 406 #endif
 407       ecorr=energia(4)
 408       ecorr5=energia(5)
 409       ecorr6=energia(6)
 410       eel_loc=energia(7)
 411       eello_turn3=energia(8)
 412       eello_turn4=energia(9)
 413       eturn6=energia(10)
 414       ebe=energia(11)
 415       escloc=energia(12)
 416       etors=energia(13)
 417       etors_d=energia(14)
 418       ehpb=energia(15)
 419       edihcnstr=energia(19)
 420       estr=energia(17)
 421       Uconst=energia(20)
 422       esccor=energia(21)
 423 #ifdef SPLITELE
 424       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 425      & +wang*ebe+wtor*etors+wscloc*escloc
 426      & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5
 427      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 428      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 429      & +wbond*estr+Uconst+wsccor*esccor
 430 #else
 431       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 432      & +wang*ebe+wtor*etors+wscloc*escloc
 433      & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5
 434      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 435      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 436      & +wbond*estr+Uconst+wsccor*esccor
 437 #endif
 438       energia(0)=etot
 439 c detecting NaNQ
 440 #ifdef ISNAN
 441 #ifdef AIX
 442       if (isnan(etot).ne.0) energia(0)=1.0d+99
 443 #else
 444       if (isnan(etot)) energia(0)=1.0d+99
 445 #endif
 446 #else
 447       i=0
 448 #ifdef WINPGI
 449       idumm=proc_proc(etot,i)
 450 #else
 451       call proc_proc(etot,i)
 452 #endif
 453       if(i.eq.1)energia(0)=1.0d+99
 454 #endif
 455 #ifdef MPI
 456       endif
 457 #endif
 458       return
 459       end
 460 c-------------------------------------------------------------------------------
 461       subroutine sum_gradient
 462       implicit real*8 (a-h,o-z)
 463       include 'DIMENSIONS'
 464 #ifndef ISNAN
 465       external proc_proc
 466 #ifdef WINPGI
 467 cMS$ATTRIBUTES C ::  proc_proc
 468 #endif
 469 #endif
 470 #ifdef MPI
 471       include 'mpif.h'
 472 #endif
 473       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 474      &  glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres)
 475       include 'COMMON.SETUP'
 476       include 'COMMON.IOUNITS'
 477       include 'COMMON.FFIELD'
 478       include 'COMMON.DERIV'
 479       include 'COMMON.INTERACT'
 480       include 'COMMON.SBRIDGE'
 481       include 'COMMON.CHAIN'
 482       include 'COMMON.VAR'
 483       include 'COMMON.CONTROL'
 484       include 'COMMON.TIME1'
 485       include 'COMMON.MAXGRAD'
 486       include 'COMMON.SCCOR'
 487 #ifdef TIMING
 488 #ifdef MPI
 489       time01=MPI_Wtime()
 490 #else
 491       time01=tcpu()
 492 #endif
 493 #endif
 494 #ifdef DEBUG
 495       write (iout,*) "sum_gradient gvdwc, gvdwx"
 496       do i=1,nres
 497         write (iout,'(i3,3f10.5,5x,3f10.5,5x,3f10.5,5x,3f10.5)')
 498      &   i,(gvdwx(j,i),j=1,3),(gvdwcT(j,i),j=1,3),(gvdwc(j,i),j=1,3),
 499      &   (gvdwcT(j,i),j=1,3)
 500       enddo
 501       call flush(iout)
 502 #endif
 503 #ifdef MPI
 504 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 505         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 506      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 507 #endif
 508 C
 509 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 510 C            in virtual-bond-vector coordinates
 511 C
 512 #ifdef DEBUG
 513 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 514 c      do i=1,nres-1
 515 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 516 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 517 c      enddo
 518 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 519 c      do i=1,nres-1
 520 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 521 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 522 c      enddo
 523       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 524       do i=1,nres
 525         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 526      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 527      &   g_corr5_loc(i)
 528       enddo
 529       call flush(iout)
 530 #endif
 531 #ifdef SPLITELE
 532 #ifdef TSCSC
 533       do i=1,nct
 534         do j=1,3
 535           gradbufc(j,i)=wsc*gvdwc(j,i)+wsc*wscT*gvdwcT(j,i)+
 536      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 537      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 538      &                wel_loc*gel_loc_long(j,i)+
 539      &                wcorr*gradcorr_long(j,i)+
 540      &                wcorr5*gradcorr5_long(j,i)+
 541      &                wcorr6*gradcorr6_long(j,i)+
 542      &                wturn6*gcorr6_turn_long(j,i)+
 543      &                wstrain*ghpbc(j,i)
 544         enddo
 545       enddo
 546 #else
 547       do i=1,nct
 548         do j=1,3
 549           gradbufc(j,i)=wsc*gvdwc(j,i)+
 550      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 551      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 552      &                wel_loc*gel_loc_long(j,i)+
 553      &                wcorr*gradcorr_long(j,i)+
 554      &                wcorr5*gradcorr5_long(j,i)+
 555      &                wcorr6*gradcorr6_long(j,i)+
 556      &                wturn6*gcorr6_turn_long(j,i)+
 557      &                wstrain*ghpbc(j,i)
 558         enddo
 559       enddo
 560 #endif
 561 #else
 562       do i=1,nct
 563         do j=1,3
 564           gradbufc(j,i)=wsc*gvdwc(j,i)+
 565      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 566      &                welec*gelc_long(j,i)+
 567      &                wbond*gradb(j,i)+
 568      &                wel_loc*gel_loc_long(j,i)+
 569      &                wcorr*gradcorr_long(j,i)+
 570      &                wcorr5*gradcorr5_long(j,i)+
 571      &                wcorr6*gradcorr6_long(j,i)+
 572      &                wturn6*gcorr6_turn_long(j,i)+
 573      &                wstrain*ghpbc(j,i)
 574         enddo
 575       enddo
 576 #endif
 577 #ifdef MPI
 578       if (nfgtasks.gt.1) then
 579       time00=MPI_Wtime()
 580 #ifdef DEBUG
 581       write (iout,*) "gradbufc before allreduce"
 582       do i=1,nres
 583         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 584       enddo
 585       call flush(iout)
 586 #endif
 587       do i=1,nres
 588         do j=1,3
 589           gradbufc_sum(j,i)=gradbufc(j,i)
 590         enddo
 591       enddo
 592 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 593 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 594 c      time_reduce=time_reduce+MPI_Wtime()-time00
 595 #ifdef DEBUG
 596 c      write (iout,*) "gradbufc_sum after allreduce"
 597 c      do i=1,nres
 598 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 599 c      enddo
 600 c      call flush(iout)
 601 #endif
 602 #ifdef TIMING
 603 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 604 #endif
 605       do i=nnt,nres
 606         do k=1,3
 607           gradbufc(k,i)=0.0d0
 608         enddo
 609       enddo
 610 #ifdef DEBUG
 611       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 612       write (iout,*) (i," jgrad_start",jgrad_start(i),
 613      &                  " jgrad_end  ",jgrad_end(i),
 614      &                  i=igrad_start,igrad_end)
 615 #endif
 616 c
 617 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 618 c do not parallelize this part.
 619 c
 620 c      do i=igrad_start,igrad_end
 621 c        do j=jgrad_start(i),jgrad_end(i)
 622 c          do k=1,3
 623 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 624 c          enddo
 625 c        enddo
 626 c      enddo
 627       do j=1,3
 628         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 629       enddo
 630       do i=nres-2,nnt,-1
 631         do j=1,3
 632           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 633         enddo
 634       enddo
 635 #ifdef DEBUG
 636       write (iout,*) "gradbufc after summing"
 637       do i=1,nres
 638         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 639       enddo
 640       call flush(iout)
 641 #endif
 642       else
 643 #endif
 644 #ifdef DEBUG
 645       write (iout,*) "gradbufc"
 646       do i=1,nres
 647         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 648       enddo
 649       call flush(iout)
 650 #endif
 651       do i=1,nres
 652         do j=1,3
 653           gradbufc_sum(j,i)=gradbufc(j,i)
 654           gradbufc(j,i)=0.0d0
 655         enddo
 656       enddo
 657       do j=1,3
 658         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 659       enddo
 660       do i=nres-2,nnt,-1
 661         do j=1,3
 662           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 663         enddo
 664       enddo
 665 c      do i=nnt,nres-1
 666 c        do k=1,3
 667 c          gradbufc(k,i)=0.0d0
 668 c        enddo
 669 c        do j=i+1,nres
 670 c          do k=1,3
 671 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 672 c          enddo
 673 c        enddo
 674 c      enddo
 675 #ifdef DEBUG
 676       write (iout,*) "gradbufc after summing"
 677       do i=1,nres
 678         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 679       enddo
 680       call flush(iout)
 681 #endif
 682 #ifdef MPI
 683       endif
 684 #endif
 685       do k=1,3
 686         gradbufc(k,nres)=0.0d0
 687       enddo
 688       do i=1,nct
 689         do j=1,3
 690 #ifdef SPLITELE
 691           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 692      &                wel_loc*gel_loc(j,i)+
 693      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 694      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 695      &                wel_loc*gel_loc_long(j,i)+
 696      &                wcorr*gradcorr_long(j,i)+
 697      &                wcorr5*gradcorr5_long(j,i)+
 698      &                wcorr6*gradcorr6_long(j,i)+
 699      &                wturn6*gcorr6_turn_long(j,i))+
 700      &                wbond*gradb(j,i)+
 701      &                wcorr*gradcorr(j,i)+
 702      &                wturn3*gcorr3_turn(j,i)+
 703      &                wturn4*gcorr4_turn(j,i)+
 704      &                wcorr5*gradcorr5(j,i)+
 705      &                wcorr6*gradcorr6(j,i)+
 706      &                wturn6*gcorr6_turn(j,i)+
 707      &                wsccor*gsccorc(j,i)
 708      &               +wscloc*gscloc(j,i)
 709 #else
 710           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 711      &                wel_loc*gel_loc(j,i)+
 712      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 713      &                welec*gelc_long(j,i)+
 714      &                wel_loc*gel_loc_long(j,i)+
 715      &                wcorr*gcorr_long(j,i)+
 716      &                wcorr5*gradcorr5_long(j,i)+
 717      &                wcorr6*gradcorr6_long(j,i)+
 718      &                wturn6*gcorr6_turn_long(j,i))+
 719      &                wbond*gradb(j,i)+
 720      &                wcorr*gradcorr(j,i)+
 721      &                wturn3*gcorr3_turn(j,i)+
 722      &                wturn4*gcorr4_turn(j,i)+
 723      &                wcorr5*gradcorr5(j,i)+
 724      &                wcorr6*gradcorr6(j,i)+
 725      &                wturn6*gcorr6_turn(j,i)+
 726      &                wsccor*gsccorc(j,i)
 727      &               +wscloc*gscloc(j,i)
 728 #endif
 729 #ifdef TSCSC
 730           gradx(j,i,icg)=wsc*gvdwx(j,i)+wsc*wscT*gvdwxT(j,i)+
 731      &                  wscp*gradx_scp(j,i)+
 732      &                  wbond*gradbx(j,i)+
 733      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 734      &                  wsccor*gsccorx(j,i)
 735      &                 +wscloc*gsclocx(j,i)
 736 #else
 737           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 738      &                  wbond*gradbx(j,i)+
 739      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 740      &                  wsccor*gsccorx(j,i)
 741      &                 +wscloc*gsclocx(j,i)
 742 #endif
 743         enddo
 744       enddo
 745 #ifdef DEBUG
 746       write (iout,*) "gloc before adding corr"
 747       do i=1,4*nres
 748         write (iout,*) i,gloc(i,icg)
 749       enddo
 750 #endif
 751       do i=1,nres-3
 752         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 753      &   +wcorr5*g_corr5_loc(i)
 754      &   +wcorr6*g_corr6_loc(i)
 755      &   +wturn4*gel_loc_turn4(i)
 756      &   +wturn3*gel_loc_turn3(i)
 757      &   +wturn6*gel_loc_turn6(i)
 758      &   +wel_loc*gel_loc_loc(i)
 759       enddo
 760 #ifdef DEBUG
 761       write (iout,*) "gloc after adding corr"
 762       do i=1,4*nres
 763         write (iout,*) i,gloc(i,icg)
 764       enddo
 765 #endif
 766 #ifdef MPI
 767       if (nfgtasks.gt.1) then
 768         do j=1,3
 769           do i=1,nres
 770             gradbufc(j,i)=gradc(j,i,icg)
 771             gradbufx(j,i)=gradx(j,i,icg)
 772           enddo
 773         enddo
 774         do i=1,4*nres
 775           glocbuf(i)=gloc(i,icg)
 776         enddo
 777 #define DEBUG
 778 #ifdef DEBUG
 779       write (iout,*) "gloc_sc before reduce"
 780       do i=1,nres
 781        do j=1,3
 782         write (iout,*) i,j,gloc_sc(j,i,icg)
 783        enddo
 784       enddo
 785 #endif
 786 #undef DEBUG
 787         do i=1,nres
 788          do j=1,3
 789           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 790          enddo
 791         enddo
 792         time00=MPI_Wtime()
 793         call MPI_Barrier(FG_COMM,IERR)
 794         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 795         time00=MPI_Wtime()
 796         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 797      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 798         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 799      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 800         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 801      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 802         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 803      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 804         time_reduce=time_reduce+MPI_Wtime()-time00
 805 #define DEBUG
 806 #ifdef DEBUG
 807       write (iout,*) "gloc_sc after reduce"
 808       do i=1,nres
 809        do j=1,3
 810         write (iout,*) i,j,gloc_sc(j,i,icg)
 811        enddo
 812       enddo
 813 #endif
 814 #undef DEBUG
 815 #ifdef DEBUG
 816       write (iout,*) "gloc after reduce"
 817       do i=1,4*nres
 818         write (iout,*) i,gloc(i,icg)
 819       enddo
 820 #endif
 821       endif
 822 #endif
 823       if (gnorm_check) then
 824 c
 825 c Compute the maximum elements of the gradient
 826 c
 827       gvdwc_max=0.0d0
 828       gvdwc_scp_max=0.0d0
 829       gelc_max=0.0d0
 830       gvdwpp_max=0.0d0
 831       gradb_max=0.0d0
 832       ghpbc_max=0.0d0
 833       gradcorr_max=0.0d0
 834       gel_loc_max=0.0d0
 835       gcorr3_turn_max=0.0d0
 836       gcorr4_turn_max=0.0d0
 837       gradcorr5_max=0.0d0
 838       gradcorr6_max=0.0d0
 839       gcorr6_turn_max=0.0d0
 840       gsccorc_max=0.0d0
 841       gscloc_max=0.0d0
 842       gvdwx_max=0.0d0
 843       gradx_scp_max=0.0d0
 844       ghpbx_max=0.0d0
 845       gradxorr_max=0.0d0
 846       gsccorx_max=0.0d0
 847       gsclocx_max=0.0d0
 848       do i=1,nct
 849         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 850         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 851 #ifdef TSCSC
 852         gvdwc_norm=dsqrt(scalar(gvdwcT(1,i),gvdwcT(1,i)))
 853         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 854 #endif
 855         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 856         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 857      &   gvdwc_scp_max=gvdwc_scp_norm
 858         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 859         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 860         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 861         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 862         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 863         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 864         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 865         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 866         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 867         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 868         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 869         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 870         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 871      &    gcorr3_turn(1,i)))
 872         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 873      &    gcorr3_turn_max=gcorr3_turn_norm
 874         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 875      &    gcorr4_turn(1,i)))
 876         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 877      &    gcorr4_turn_max=gcorr4_turn_norm
 878         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 879         if (gradcorr5_norm.gt.gradcorr5_max)
 880      &    gradcorr5_max=gradcorr5_norm
 881         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 882         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 883         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 884      &    gcorr6_turn(1,i)))
 885         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 886      &    gcorr6_turn_max=gcorr6_turn_norm
 887         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 888         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 889         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 890         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 891         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 892         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 893 #ifdef TSCSC
 894         gvdwx_norm=dsqrt(scalar(gvdwxT(1,i),gvdwxT(1,i)))
 895         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 896 #endif
 897         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 898         if (gradx_scp_norm.gt.gradx_scp_max)
 899      &    gradx_scp_max=gradx_scp_norm
 900         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 901         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 902         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 903         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 904         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 905         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 906         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 907         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 908       enddo
 909       if (gradout) then
 910 #ifdef AIX
 911         open(istat,file=statname,position="append")
 912 #else
 913         open(istat,file=statname,access="append")
 914 #endif
 915         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 916      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 917      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 918      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 919      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 920      &     gsccorx_max,gsclocx_max
 921         close(istat)
 922         if (gvdwc_max.gt.1.0d4) then
 923           write (iout,*) "gvdwc gvdwx gradb gradbx"
 924           do i=nnt,nct
 925             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 926      &        gradb(j,i),gradbx(j,i),j=1,3)
 927           enddo
 928           call pdbout(0.0d0,'cipiszcze',iout)
 929           call flush(iout)
 930         endif
 931       endif
 932       endif
 933 #ifdef DEBUG
 934       write (iout,*) "gradc gradx gloc"
 935       do i=1,nres
 936         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 937      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 938       enddo
 939 #endif
 940 #ifdef TIMING
 941 #ifdef MPI
 942       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 943 #else
 944       time_sumgradient=time_sumgradient+tcpu()-time01
 945 #endif
 946 #endif
 947       return
 948       end
 949 c-------------------------------------------------------------------------------
 950       subroutine rescale_weights(t_bath)
 951       implicit real*8 (a-h,o-z)
 952       include 'DIMENSIONS'
 953       include 'COMMON.IOUNITS'
 954       include 'COMMON.FFIELD'
 955       include 'COMMON.SBRIDGE'
 956       double precision kfac /2.4d0/
 957       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 958 c      facT=temp0/t_bath
 959 c      facT=2*temp0/(t_bath+temp0)
 960       if (rescale_mode.eq.0) then
 961         facT=1.0d0
 962         facT2=1.0d0
 963         facT3=1.0d0
 964         facT4=1.0d0
 965         facT5=1.0d0
 966       else if (rescale_mode.eq.1) then
 967         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 968         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 969         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 970         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 971         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 972       else if (rescale_mode.eq.2) then
 973         x=t_bath/temp0
 974         x2=x*x
 975         x3=x2*x
 976         x4=x3*x
 977         x5=x4*x
 978         facT=licznik/dlog(dexp(x)+dexp(-x))
 979         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 980         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 981         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 982         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 983       else
 984         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 985         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 986 #ifdef MPI
 987        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 988 #endif
 989        stop 555
 990       endif
 991       welec=weights(3)*fact
 992       wcorr=weights(4)*fact3
 993       wcorr5=weights(5)*fact4
 994       wcorr6=weights(6)*fact5
 995       wel_loc=weights(7)*fact2
 996       wturn3=weights(8)*fact2
 997       wturn4=weights(9)*fact3
 998       wturn6=weights(10)*fact5
 999       wtor=weights(13)*fact
1000       wtor_d=weights(14)*fact2
1001       wsccor=weights(21)*fact
1002 #ifdef TSCSC
1003 c      wsct=t_bath/temp0
1004       wsct=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
1005 #endif
1006       return
1007       end
1008 C------------------------------------------------------------------------
1009       subroutine enerprint(energia)
1010       implicit real*8 (a-h,o-z)
1011       include 'DIMENSIONS'
1012       include 'COMMON.IOUNITS'
1013       include 'COMMON.FFIELD'
1014       include 'COMMON.SBRIDGE'
1015       include 'COMMON.MD'
1016       double precision energia(0:n_ene)
1017       etot=energia(0)
1018 #ifdef TSCSC
1019       evdw=energia(22)+wsct*energia(23)
1020 #else
1021       evdw=energia(1)
1022 #endif
1023       evdw2=energia(2)
1024 #ifdef SCP14
1025       evdw2=energia(2)+energia(18)
1026 #else
1027       evdw2=energia(2)
1028 #endif
1029       ees=energia(3)
1030 #ifdef SPLITELE
1031       evdw1=energia(16)
1032 #endif
1033       ecorr=energia(4)
1034       ecorr5=energia(5)
1035       ecorr6=energia(6)
1036       eel_loc=energia(7)
1037       eello_turn3=energia(8)
1038       eello_turn4=energia(9)
1039       eello_turn6=energia(10)
1040       ebe=energia(11)
1041       escloc=energia(12)
1042       etors=energia(13)
1043       etors_d=energia(14)
1044       ehpb=energia(15)
1045       edihcnstr=energia(19)
1046       estr=energia(17)
1047       Uconst=energia(20)
1048       esccor=energia(21)
1049 #ifdef SPLITELE
1050       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1051      &  estr,wbond,ebe,wang,
1052      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1053      &  ecorr,wcorr,
1054      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1055      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
1056      &  edihcnstr,ebr*nss,
1057      &  Uconst,etot
1058    10 format (/'Virtual-chain energies:'//
1059      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1060      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1061      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1062      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
1063      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1064      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1065      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1066      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1067      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1068      & 'EHPB=  ',1pE16.6,' WEIGHT=',1pD16.6,
1069      & ' (SS bridges & dist. cnstr.)'/
1070      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1071      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1072      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1073      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1074      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1075      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1076      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1077      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1078      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1079      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1080      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1081      & 'ETOT=  ',1pE16.6,' (total)')
1082 #else
1083       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1084      &  estr,wbond,ebe,wang,
1085      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1086      &  ecorr,wcorr,
1087      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1088      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1089      &  ebr*nss,Uconst,etot
1090    10 format (/'Virtual-chain energies:'//
1091      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1092      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1093      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1094      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1095      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1096      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1097      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1098      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1099      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1100      & ' (SS bridges & dist. cnstr.)'/
1101      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1102      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1103      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1104      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1105      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1106      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1107      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1108      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1109      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1110      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1111      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1112      & 'ETOT=  ',1pE16.6,' (total)')
1113 #endif
1114       return
1115       end
1116 C-----------------------------------------------------------------------
1117       subroutine elj(evdw,evdw_p,evdw_m)
1118 C
1119 C This subroutine calculates the interaction energy of nonbonded side chains
1120 C assuming the LJ potential of interaction.
1121 C
1122       implicit real*8 (a-h,o-z)
1123       include 'DIMENSIONS'
1124       parameter (accur=1.0d-10)
1125       include 'COMMON.GEO'
1126       include 'COMMON.VAR'
1127       include 'COMMON.LOCAL'
1128       include 'COMMON.CHAIN'
1129       include 'COMMON.DERIV'
1130       include 'COMMON.INTERACT'
1131       include 'COMMON.TORSION'
1132       include 'COMMON.SBRIDGE'
1133       include 'COMMON.NAMES'
1134       include 'COMMON.IOUNITS'
1135       include 'COMMON.CONTACTS'
1136       dimension gg(3)
1137 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1138       evdw=0.0D0
1139       do i=iatsc_s,iatsc_e
1140         itypi=iabs(itype(i))
1141         itypi1=iabs(itype(i+1))
1142         xi=c(1,nres+i)
1143         yi=c(2,nres+i)
1144         zi=c(3,nres+i)
1145 C Change 12/1/95
1146         num_conti=0
1147 C
1148 C Calculate SC interaction energy.
1149 C
1150         do iint=1,nint_gr(i)
1151 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1152 cd   &                  'iend=',iend(i,iint)
1153           do j=istart(i,iint),iend(i,iint)
1154             itypj=iabs(itype(j))
1155             xj=c(1,nres+j)-xi
1156             yj=c(2,nres+j)-yi
1157             zj=c(3,nres+j)-zi
1158 C Change 12/1/95 to calculate four-body interactions
1159             rij=xj*xj+yj*yj+zj*zj
1160             rrij=1.0D0/rij
1161 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1162             eps0ij=eps(itypi,itypj)
1163             fac=rrij**expon2
1164             e1=fac*fac*aa(itypi,itypj)
1165             e2=fac*bb(itypi,itypj)
1166             evdwij=e1+e2
1167 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1168 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1169 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1170 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1171 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1172 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1173 #ifdef TSCSC
1174             if (bb(itypi,itypj).gt.0) then
1175                evdw_p=evdw_p+evdwij
1176             else
1177                evdw_m=evdw_m+evdwij
1178             endif
1179 #else
1180             evdw=evdw+evdwij
1181 #endif
1182 C
1183 C Calculate the components of the gradient in DC and X
1184 C
1185             fac=-rrij*(e1+evdwij)
1186             gg(1)=xj*fac
1187             gg(2)=yj*fac
1188             gg(3)=zj*fac
1189 #ifdef TSCSC
1190             if (bb(itypi,itypj).gt.0.0d0) then
1191               do k=1,3
1192                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1193                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1194                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1195                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1196               enddo
1197             else
1198               do k=1,3
1199                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1200                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1201                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1202                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1203               enddo
1204             endif
1205 #else
1206             do k=1,3
1207               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1208               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1209               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1210               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1211             enddo
1212 #endif
1213 cgrad            do k=i,j-1
1214 cgrad              do l=1,3
1215 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1216 cgrad              enddo
1217 cgrad            enddo
1218 C
1219 C 12/1/95, revised on 5/20/97
1220 C
1221 C Calculate the contact function. The ith column of the array JCONT will
1222 C contain the numbers of atoms that make contacts with the atom I (of numbers
1223 C greater than I). The arrays FACONT and GACONT will contain the values of
1224 C the contact function and its derivative.
1225 C
1226 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1227 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1228 C Uncomment next line, if the correlation interactions are contact function only
1229             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1230               rij=dsqrt(rij)
1231               sigij=sigma(itypi,itypj)
1232               r0ij=rs0(itypi,itypj)
1233 C
1234 C Check whether the SC's are not too far to make a contact.
1235 C
1236               rcut=1.5d0*r0ij
1237               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1238 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1239 C
1240               if (fcont.gt.0.0D0) then
1241 C If the SC-SC distance if close to sigma, apply spline.
1242 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1243 cAdam &             fcont1,fprimcont1)
1244 cAdam           fcont1=1.0d0-fcont1
1245 cAdam           if (fcont1.gt.0.0d0) then
1246 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1247 cAdam             fcont=fcont*fcont1
1248 cAdam           endif
1249 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1250 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1251 cga             do k=1,3
1252 cga               gg(k)=gg(k)*eps0ij
1253 cga             enddo
1254 cga             eps0ij=-evdwij*eps0ij
1255 C Uncomment for AL's type of SC correlation interactions.
1256 cadam           eps0ij=-evdwij
1257                 num_conti=num_conti+1
1258                 jcont(num_conti,i)=j
1259                 facont(num_conti,i)=fcont*eps0ij
1260                 fprimcont=eps0ij*fprimcont/rij
1261                 fcont=expon*fcont
1262 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1263 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1264 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1265 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1266                 gacont(1,num_conti,i)=-fprimcont*xj
1267                 gacont(2,num_conti,i)=-fprimcont*yj
1268                 gacont(3,num_conti,i)=-fprimcont*zj
1269 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1270 cd              write (iout,'(2i3,3f10.5)')
1271 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1272               endif
1273             endif
1274           enddo      ! j
1275         enddo        ! iint
1276 C Change 12/1/95
1277         num_cont(i)=num_conti
1278       enddo          ! i
1279       do i=1,nct
1280         do j=1,3
1281           gvdwc(j,i)=expon*gvdwc(j,i)
1282           gvdwx(j,i)=expon*gvdwx(j,i)
1283         enddo
1284       enddo
1285 C******************************************************************************
1286 C
1287 C                              N O T E !!!
1288 C
1289 C To save time, the factor of EXPON has been extracted from ALL components
1290 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1291 C use!
1292 C
1293 C******************************************************************************
1294       return
1295       end
1296 C-----------------------------------------------------------------------------
1297       subroutine eljk(evdw,evdw_p,evdw_m)
1298 C
1299 C This subroutine calculates the interaction energy of nonbonded side chains
1300 C assuming the LJK potential of interaction.
1301 C
1302       implicit real*8 (a-h,o-z)
1303       include 'DIMENSIONS'
1304       include 'COMMON.GEO'
1305       include 'COMMON.VAR'
1306       include 'COMMON.LOCAL'
1307       include 'COMMON.CHAIN'
1308       include 'COMMON.DERIV'
1309       include 'COMMON.INTERACT'
1310       include 'COMMON.IOUNITS'
1311       include 'COMMON.NAMES'
1312       dimension gg(3)
1313       logical scheck
1314 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1315       evdw=0.0D0
1316       do i=iatsc_s,iatsc_e
1317         itypi=iabs(itype(i))
1318         itypi1=iabs(itype(i+1))
1319         xi=c(1,nres+i)
1320         yi=c(2,nres+i)
1321         zi=c(3,nres+i)
1322 C
1323 C Calculate SC interaction energy.
1324 C
1325         do iint=1,nint_gr(i)
1326           do j=istart(i,iint),iend(i,iint)
1327             itypj=iabs(itype(j))
1328             xj=c(1,nres+j)-xi
1329             yj=c(2,nres+j)-yi
1330             zj=c(3,nres+j)-zi
1331             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1332             fac_augm=rrij**expon
1333             e_augm=augm(itypi,itypj)*fac_augm
1334             r_inv_ij=dsqrt(rrij)
1335             rij=1.0D0/r_inv_ij
1336             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1337             fac=r_shift_inv**expon
1338             e1=fac*fac*aa(itypi,itypj)
1339             e2=fac*bb(itypi,itypj)
1340             evdwij=e_augm+e1+e2
1341 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1342 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1343 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1344 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1345 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1346 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1347 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1348 #ifdef TSCSC
1349             if (bb(itypi,itypj).gt.0) then
1350                evdw_p=evdw_p+evdwij
1351             else
1352                evdw_m=evdw_m+evdwij
1353             endif
1354 #else
1355             evdw=evdw+evdwij
1356 #endif
1357 C
1358 C Calculate the components of the gradient in DC and X
1359 C
1360             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1361             gg(1)=xj*fac
1362             gg(2)=yj*fac
1363             gg(3)=zj*fac
1364 #ifdef TSCSC
1365             if (bb(itypi,itypj).gt.0.0d0) then
1366               do k=1,3
1367                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1368                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1369                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1370                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1371               enddo
1372             else
1373               do k=1,3
1374                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1375                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1376                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1377                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1378               enddo
1379             endif
1380 #else
1381             do k=1,3
1382               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1383               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1384               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1385               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1386             enddo
1387 #endif
1388 cgrad            do k=i,j-1
1389 cgrad              do l=1,3
1390 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1391 cgrad              enddo
1392 cgrad            enddo
1393           enddo      ! j
1394         enddo        ! iint
1395       enddo          ! i
1396       do i=1,nct
1397         do j=1,3
1398           gvdwc(j,i)=expon*gvdwc(j,i)
1399           gvdwx(j,i)=expon*gvdwx(j,i)
1400         enddo
1401       enddo
1402       return
1403       end
1404 C-----------------------------------------------------------------------------
1405       subroutine ebp(evdw,evdw_p,evdw_m)
1406 C
1407 C This subroutine calculates the interaction energy of nonbonded side chains
1408 C assuming the Berne-Pechukas potential of interaction.
1409 C
1410       implicit real*8 (a-h,o-z)
1411       include 'DIMENSIONS'
1412       include 'COMMON.GEO'
1413       include 'COMMON.VAR'
1414       include 'COMMON.LOCAL'
1415       include 'COMMON.CHAIN'
1416       include 'COMMON.DERIV'
1417       include 'COMMON.NAMES'
1418       include 'COMMON.INTERACT'
1419       include 'COMMON.IOUNITS'
1420       include 'COMMON.CALC'
1421       common /srutu/ icall
1422 c     double precision rrsave(maxdim)
1423       logical lprn
1424       evdw=0.0D0
1425 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1426       evdw=0.0D0
1427 c     if (icall.eq.0) then
1428 c       lprn=.true.
1429 c     else
1430         lprn=.false.
1431 c     endif
1432       ind=0
1433       do i=iatsc_s,iatsc_e
1434         itypi=iabs(itype(i))
1435         itypi1=iabs(itype(i+1))
1436         xi=c(1,nres+i)
1437         yi=c(2,nres+i)
1438         zi=c(3,nres+i)
1439         dxi=dc_norm(1,nres+i)
1440         dyi=dc_norm(2,nres+i)
1441         dzi=dc_norm(3,nres+i)
1442 c        dsci_inv=dsc_inv(itypi)
1443         dsci_inv=vbld_inv(i+nres)
1444 C
1445 C Calculate SC interaction energy.
1446 C
1447         do iint=1,nint_gr(i)
1448           do j=istart(i,iint),iend(i,iint)
1449             ind=ind+1
1450             itypj=itype(j)
1451 c            dscj_inv=dsc_inv(itypj)
1452             dscj_inv=vbld_inv(j+nres)
1453             chi1=chi(itypi,itypj)
1454             chi2=chi(itypj,itypi)
1455             chi12=chi1*chi2
1456             chip1=chip(itypi)
1457             chip2=chip(itypj)
1458             chip12=chip1*chip2
1459             alf1=alp(itypi)
1460             alf2=alp(itypj)
1461             alf12=0.5D0*(alf1+alf2)
1462 C For diagnostics only!!!
1463 c           chi1=0.0D0
1464 c           chi2=0.0D0
1465 c           chi12=0.0D0
1466 c           chip1=0.0D0
1467 c           chip2=0.0D0
1468 c           chip12=0.0D0
1469 c           alf1=0.0D0
1470 c           alf2=0.0D0
1471 c           alf12=0.0D0
1472             xj=c(1,nres+j)-xi
1473             yj=c(2,nres+j)-yi
1474             zj=c(3,nres+j)-zi
1475             dxj=dc_norm(1,nres+j)
1476             dyj=dc_norm(2,nres+j)
1477             dzj=dc_norm(3,nres+j)
1478             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1479 cd          if (icall.eq.0) then
1480 cd            rrsave(ind)=rrij
1481 cd          else
1482 cd            rrij=rrsave(ind)
1483 cd          endif
1484             rij=dsqrt(rrij)
1485 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1486             call sc_angular
1487 C Calculate whole angle-dependent part of epsilon and contributions
1488 C to its derivatives
1489             fac=(rrij*sigsq)**expon2
1490             e1=fac*fac*aa(itypi,itypj)
1491             e2=fac*bb(itypi,itypj)
1492             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1493             eps2der=evdwij*eps3rt
1494             eps3der=evdwij*eps2rt
1495             evdwij=evdwij*eps2rt*eps3rt
1496 #ifdef TSCSC
1497             if (bb(itypi,itypj).gt.0) then
1498                evdw_p=evdw_p+evdwij
1499             else
1500                evdw_m=evdw_m+evdwij
1501             endif
1502 #else
1503             evdw=evdw+evdwij
1504 #endif
1505             if (lprn) then
1506             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1507             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1508 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1509 cd     &        restyp(itypi),i,restyp(itypj),j,
1510 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1511 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1512 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1513 cd     &        evdwij
1514             endif
1515 C Calculate gradient components.
1516             e1=e1*eps1*eps2rt**2*eps3rt**2
1517             fac=-expon*(e1+evdwij)
1518             sigder=fac/sigsq
1519             fac=rrij*fac
1520 C Calculate radial part of the gradient
1521             gg(1)=xj*fac
1522             gg(2)=yj*fac
1523             gg(3)=zj*fac
1524 C Calculate the angular part of the gradient and sum add the contributions
1525 C to the appropriate components of the Cartesian gradient.
1526 #ifdef TSCSC
1527             if (bb(itypi,itypj).gt.0) then
1528                call sc_grad
1529             else
1530                call sc_grad_T
1531             endif
1532 #else
1533             call sc_grad
1534 #endif
1535           enddo      ! j
1536         enddo        ! iint
1537       enddo          ! i
1538 c     stop
1539       return
1540       end
1541 C-----------------------------------------------------------------------------
1542       subroutine egb(evdw,evdw_p,evdw_m)
1543 C
1544 C This subroutine calculates the interaction energy of nonbonded side chains
1545 C assuming the Gay-Berne potential of interaction.
1546 C
1547       implicit real*8 (a-h,o-z)
1548       include 'DIMENSIONS'
1549       include 'COMMON.GEO'
1550       include 'COMMON.VAR'
1551       include 'COMMON.LOCAL'
1552       include 'COMMON.CHAIN'
1553       include 'COMMON.DERIV'
1554       include 'COMMON.NAMES'
1555       include 'COMMON.INTERACT'
1556       include 'COMMON.IOUNITS'
1557       include 'COMMON.CALC'
1558       include 'COMMON.CONTROL'
1559       logical lprn
1560       evdw=0.0D0
1561 ccccc      energy_dec=.false.
1562 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1563       evdw=0.0D0
1564       evdw_p=0.0D0
1565       evdw_m=0.0D0
1566       lprn=.false.
1567 c     if (icall.eq.0) lprn=.false.
1568       ind=0
1569       do i=iatsc_s,iatsc_e
1570         itypi=iabs(itype(i))
1571         itypi1=iabs(itype(i+1))
1572         xi=c(1,nres+i)
1573         yi=c(2,nres+i)
1574         zi=c(3,nres+i)
1575         dxi=dc_norm(1,nres+i)
1576         dyi=dc_norm(2,nres+i)
1577         dzi=dc_norm(3,nres+i)
1578 c        dsci_inv=dsc_inv(itypi)
1579         dsci_inv=vbld_inv(i+nres)
1580 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1581 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1582 C
1583 C Calculate SC interaction energy.
1584 C
1585         do iint=1,nint_gr(i)
1586           do j=istart(i,iint),iend(i,iint)
1587             ind=ind+1
1588             itypj=iabs(itype(j))
1589 c            dscj_inv=dsc_inv(itypj)
1590             dscj_inv=vbld_inv(j+nres)
1591 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1592 c     &       1.0d0/vbld(j+nres)
1593 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1594             sig0ij=sigma(itypi,itypj)
1595             chi1=chi(itypi,itypj)
1596             chi2=chi(itypj,itypi)
1597             chi12=chi1*chi2
1598             chip1=chip(itypi)
1599             chip2=chip(itypj)
1600             chip12=chip1*chip2
1601             alf1=alp(itypi)
1602             alf2=alp(itypj)
1603             alf12=0.5D0*(alf1+alf2)
1604 C For diagnostics only!!!
1605 c           chi1=0.0D0
1606 c           chi2=0.0D0
1607 c           chi12=0.0D0
1608 c           chip1=0.0D0
1609 c           chip2=0.0D0
1610 c           chip12=0.0D0
1611 c           alf1=0.0D0
1612 c           alf2=0.0D0
1613 c           alf12=0.0D0
1614             xj=c(1,nres+j)-xi
1615             yj=c(2,nres+j)-yi
1616             zj=c(3,nres+j)-zi
1617             dxj=dc_norm(1,nres+j)
1618             dyj=dc_norm(2,nres+j)
1619             dzj=dc_norm(3,nres+j)
1620 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1621 c            write (iout,*) "j",j," dc_norm",
1622 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1623             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1624             rij=dsqrt(rrij)
1625 C Calculate angle-dependent terms of energy and contributions to their
1626 C derivatives.
1627             call sc_angular
1628             sigsq=1.0D0/sigsq
1629             sig=sig0ij*dsqrt(sigsq)
1630             rij_shift=1.0D0/rij-sig+sig0ij
1631 c for diagnostics; uncomment
1632 c            rij_shift=1.2*sig0ij
1633 C I hate to put IF's in the loops, but here don't have another choice!!!!
1634             if (rij_shift.le.0.0D0) then
1635               evdw=1.0D20
1636 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1637 cd     &        restyp(itypi),i,restyp(itypj),j,
1638 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1639               return
1640             endif
1641             sigder=-sig*sigsq
1642 c---------------------------------------------------------------
1643             rij_shift=1.0D0/rij_shift
1644             fac=rij_shift**expon
1645             e1=fac*fac*aa(itypi,itypj)
1646             e2=fac*bb(itypi,itypj)
1647             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1648             eps2der=evdwij*eps3rt
1649             eps3der=evdwij*eps2rt
1650 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1651 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1652             evdwij=evdwij*eps2rt*eps3rt
1653 #ifdef TSCSC
1654             if (bb(itypi,itypj).gt.0) then
1655                evdw_p=evdw_p+evdwij
1656             else
1657                evdw_m=evdw_m+evdwij
1658             endif
1659 #else
1660             evdw=evdw+evdwij
1661 #endif
1662             if (lprn) then
1663             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1664             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1665             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1666      &        restyp(itypi),i,restyp(itypj),j,
1667      &        epsi,sigm,chi1,chi2,chip1,chip2,
1668      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1669      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1670      &        evdwij
1671             endif
1672
1673             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1674      &                        'evdw',i,j,evdwij
1675
1676 C Calculate gradient components.
1677             e1=e1*eps1*eps2rt**2*eps3rt**2
1678             fac=-expon*(e1+evdwij)*rij_shift
1679             sigder=fac*sigder
1680             fac=rij*fac
1681 c            fac=0.0d0
1682 C Calculate the radial part of the gradient
1683             gg(1)=xj*fac
1684             gg(2)=yj*fac
1685             gg(3)=zj*fac
1686 C Calculate angular part of the gradient.
1687 #ifdef TSCSC
1688             if (bb(itypi,itypj).gt.0) then
1689                call sc_grad
1690             else
1691                call sc_grad_T
1692             endif
1693 #else
1694             call sc_grad
1695 #endif
1696           enddo      ! j
1697         enddo        ! iint
1698       enddo          ! i
1699 c      write (iout,*) "Number of loop steps in EGB:",ind
1700 cccc      energy_dec=.false.
1701       return
1702       end
1703 C-----------------------------------------------------------------------------
1704       subroutine egbv(evdw,evdw_p,evdw_m)
1705 C
1706 C This subroutine calculates the interaction energy of nonbonded side chains
1707 C assuming the Gay-Berne-Vorobjev potential of interaction.
1708 C
1709       implicit real*8 (a-h,o-z)
1710       include 'DIMENSIONS'
1711       include 'COMMON.GEO'
1712       include 'COMMON.VAR'
1713       include 'COMMON.LOCAL'
1714       include 'COMMON.CHAIN'
1715       include 'COMMON.DERIV'
1716       include 'COMMON.NAMES'
1717       include 'COMMON.INTERACT'
1718       include 'COMMON.IOUNITS'
1719       include 'COMMON.CALC'
1720       common /srutu/ icall
1721       logical lprn
1722       evdw=0.0D0
1723 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1724       evdw=0.0D0
1725       lprn=.false.
1726 c     if (icall.eq.0) lprn=.true.
1727       ind=0
1728       do i=iatsc_s,iatsc_e
1729         itypi=iabs(itype(i))
1730         itypi1=iabs(itype(i+1))
1731         xi=c(1,nres+i)
1732         yi=c(2,nres+i)
1733         zi=c(3,nres+i)
1734         dxi=dc_norm(1,nres+i)
1735         dyi=dc_norm(2,nres+i)
1736         dzi=dc_norm(3,nres+i)
1737 c        dsci_inv=dsc_inv(itypi)
1738         dsci_inv=vbld_inv(i+nres)
1739 C
1740 C Calculate SC interaction energy.
1741 C
1742         do iint=1,nint_gr(i)
1743           do j=istart(i,iint),iend(i,iint)
1744             ind=ind+1
1745             itypj=iabs(itype(j))
1746 c            dscj_inv=dsc_inv(itypj)
1747             dscj_inv=vbld_inv(j+nres)
1748             sig0ij=sigma(itypi,itypj)
1749             r0ij=r0(itypi,itypj)
1750             chi1=chi(itypi,itypj)
1751             chi2=chi(itypj,itypi)
1752             chi12=chi1*chi2
1753             chip1=chip(itypi)
1754             chip2=chip(itypj)
1755             chip12=chip1*chip2
1756             alf1=alp(itypi)
1757             alf2=alp(itypj)
1758             alf12=0.5D0*(alf1+alf2)
1759 C For diagnostics only!!!
1760 c           chi1=0.0D0
1761 c           chi2=0.0D0
1762 c           chi12=0.0D0
1763 c           chip1=0.0D0
1764 c           chip2=0.0D0
1765 c           chip12=0.0D0
1766 c           alf1=0.0D0
1767 c           alf2=0.0D0
1768 c           alf12=0.0D0
1769             xj=c(1,nres+j)-xi
1770             yj=c(2,nres+j)-yi
1771             zj=c(3,nres+j)-zi
1772             dxj=dc_norm(1,nres+j)
1773             dyj=dc_norm(2,nres+j)
1774             dzj=dc_norm(3,nres+j)
1775             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1776             rij=dsqrt(rrij)
1777 C Calculate angle-dependent terms of energy and contributions to their
1778 C derivatives.
1779             call sc_angular
1780             sigsq=1.0D0/sigsq
1781             sig=sig0ij*dsqrt(sigsq)
1782             rij_shift=1.0D0/rij-sig+r0ij
1783 C I hate to put IF's in the loops, but here don't have another choice!!!!
1784             if (rij_shift.le.0.0D0) then
1785               evdw=1.0D20
1786               return
1787             endif
1788             sigder=-sig*sigsq
1789 c---------------------------------------------------------------
1790             rij_shift=1.0D0/rij_shift
1791             fac=rij_shift**expon
1792             e1=fac*fac*aa(itypi,itypj)
1793             e2=fac*bb(itypi,itypj)
1794             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1795             eps2der=evdwij*eps3rt
1796             eps3der=evdwij*eps2rt
1797             fac_augm=rrij**expon
1798             e_augm=augm(itypi,itypj)*fac_augm
1799             evdwij=evdwij*eps2rt*eps3rt
1800 #ifdef TSCSC
1801             if (bb(itypi,itypj).gt.0) then
1802                evdw_p=evdw_p+evdwij+e_augm
1803             else
1804                evdw_m=evdw_m+evdwij+e_augm
1805             endif
1806 #else
1807             evdw=evdw+evdwij+e_augm
1808 #endif
1809             if (lprn) then
1810             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1811             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1812             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1813      &        restyp(itypi),i,restyp(itypj),j,
1814      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1815      &        chi1,chi2,chip1,chip2,
1816      &        eps1,eps2rt**2,eps3rt**2,
1817      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1818      &        evdwij+e_augm
1819             endif
1820 C Calculate gradient components.
1821             e1=e1*eps1*eps2rt**2*eps3rt**2
1822             fac=-expon*(e1+evdwij)*rij_shift
1823             sigder=fac*sigder
1824             fac=rij*fac-2*expon*rrij*e_augm
1825 C Calculate the radial part of the gradient
1826             gg(1)=xj*fac
1827             gg(2)=yj*fac
1828             gg(3)=zj*fac
1829 C Calculate angular part of the gradient.
1830 #ifdef TSCSC
1831             if (bb(itypi,itypj).gt.0) then
1832                call sc_grad
1833             else
1834                call sc_grad_T
1835             endif
1836 #else
1837             call sc_grad
1838 #endif
1839           enddo      ! j
1840         enddo        ! iint
1841       enddo          ! i
1842       end
1843 C-----------------------------------------------------------------------------
1844       subroutine sc_angular
1845 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1846 C om12. Called by ebp, egb, and egbv.
1847       implicit none
1848       include 'COMMON.CALC'
1849       include 'COMMON.IOUNITS'
1850       erij(1)=xj*rij
1851       erij(2)=yj*rij
1852       erij(3)=zj*rij
1853       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1854       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1855       om12=dxi*dxj+dyi*dyj+dzi*dzj
1856       chiom12=chi12*om12
1857 C Calculate eps1(om12) and its derivative in om12
1858       faceps1=1.0D0-om12*chiom12
1859       faceps1_inv=1.0D0/faceps1
1860       eps1=dsqrt(faceps1_inv)
1861 C Following variable is eps1*deps1/dom12
1862       eps1_om12=faceps1_inv*chiom12
1863 c diagnostics only
1864 c      faceps1_inv=om12
1865 c      eps1=om12
1866 c      eps1_om12=1.0d0
1867 c      write (iout,*) "om12",om12," eps1",eps1
1868 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1869 C and om12.
1870       om1om2=om1*om2
1871       chiom1=chi1*om1
1872       chiom2=chi2*om2
1873       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1874       sigsq=1.0D0-facsig*faceps1_inv
1875       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1876       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1877       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1878 c diagnostics only
1879 c      sigsq=1.0d0
1880 c      sigsq_om1=0.0d0
1881 c      sigsq_om2=0.0d0
1882 c      sigsq_om12=0.0d0
1883 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1884 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1885 c     &    " eps1",eps1
1886 C Calculate eps2 and its derivatives in om1, om2, and om12.
1887       chipom1=chip1*om1
1888       chipom2=chip2*om2
1889       chipom12=chip12*om12
1890       facp=1.0D0-om12*chipom12
1891       facp_inv=1.0D0/facp
1892       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1893 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1894 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1895 C Following variable is the square root of eps2
1896       eps2rt=1.0D0-facp1*facp_inv
1897 C Following three variables are the derivatives of the square root of eps
1898 C in om1, om2, and om12.
1899       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1900       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1901       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1902 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1903       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1904 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1905 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1906 c     &  " eps2rt_om12",eps2rt_om12
1907 C Calculate whole angle-dependent part of epsilon and contributions
1908 C to its derivatives
1909       return
1910       end
1911
1912 C----------------------------------------------------------------------------
1913       subroutine sc_grad_T
1914       implicit real*8 (a-h,o-z)
1915       include 'DIMENSIONS'
1916       include 'COMMON.CHAIN'
1917       include 'COMMON.DERIV'
1918       include 'COMMON.CALC'
1919       include 'COMMON.IOUNITS'
1920       double precision dcosom1(3),dcosom2(3)
1921       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1922       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1923       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1924      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1925 c diagnostics only
1926 c      eom1=0.0d0
1927 c      eom2=0.0d0
1928 c      eom12=evdwij*eps1_om12
1929 c end diagnostics
1930 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1931 c     &  " sigder",sigder
1932 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1933 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1934       do k=1,3
1935         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1936         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1937       enddo
1938       do k=1,3
1939         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1940       enddo
1941 c      write (iout,*) "gg",(gg(k),k=1,3)
1942       do k=1,3
1943         gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1944      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1945      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1946         gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1947      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1948      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1949 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1950 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1951 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1952 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1953       enddo
1954 C
1955 C Calculate the components of the gradient in DC and X
1956 C
1957 cgrad      do k=i,j-1
1958 cgrad        do l=1,3
1959 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1960 cgrad        enddo
1961 cgrad      enddo
1962       do l=1,3
1963         gvdwcT(l,i)=gvdwcT(l,i)-gg(l)
1964         gvdwcT(l,j)=gvdwcT(l,j)+gg(l)
1965       enddo
1966       return
1967       end
1968
1969 C----------------------------------------------------------------------------
1970       subroutine sc_grad
1971       implicit real*8 (a-h,o-z)
1972       include 'DIMENSIONS'
1973       include 'COMMON.CHAIN'
1974       include 'COMMON.DERIV'
1975       include 'COMMON.CALC'
1976       include 'COMMON.IOUNITS'
1977       double precision dcosom1(3),dcosom2(3)
1978       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1979       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1980       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1981      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1982 c diagnostics only
1983 c      eom1=0.0d0
1984 c      eom2=0.0d0
1985 c      eom12=evdwij*eps1_om12
1986 c end diagnostics
1987 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1988 c     &  " sigder",sigder
1989 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1990 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1991       do k=1,3
1992         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1993         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1994       enddo
1995       do k=1,3
1996         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1997       enddo
1998 c      write (iout,*) "gg",(gg(k),k=1,3)
1999       do k=1,3
2000         gvdwx(k,i)=gvdwx(k,i)-gg(k)
2001      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2002      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2003         gvdwx(k,j)=gvdwx(k,j)+gg(k)
2004      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2005      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2006 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2007 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2008 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2009 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2010       enddo
2011 C
2012 C Calculate the components of the gradient in DC and X
2013 C
2014 cgrad      do k=i,j-1
2015 cgrad        do l=1,3
2016 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2017 cgrad        enddo
2018 cgrad      enddo
2019       do l=1,3
2020         gvdwc(l,i)=gvdwc(l,i)-gg(l)
2021         gvdwc(l,j)=gvdwc(l,j)+gg(l)
2022       enddo
2023       return
2024       end
2025 C-----------------------------------------------------------------------
2026       subroutine e_softsphere(evdw)
2027 C
2028 C This subroutine calculates the interaction energy of nonbonded side chains
2029 C assuming the LJ potential of interaction.
2030 C
2031       implicit real*8 (a-h,o-z)
2032       include 'DIMENSIONS'
2033       parameter (accur=1.0d-10)
2034       include 'COMMON.GEO'
2035       include 'COMMON.VAR'
2036       include 'COMMON.LOCAL'
2037       include 'COMMON.CHAIN'
2038       include 'COMMON.DERIV'
2039       include 'COMMON.INTERACT'
2040       include 'COMMON.TORSION'
2041       include 'COMMON.SBRIDGE'
2042       include 'COMMON.NAMES'
2043       include 'COMMON.IOUNITS'
2044       include 'COMMON.CONTACTS'
2045       dimension gg(3)
2046 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2047       evdw=0.0D0
2048       do i=iatsc_s,iatsc_e
2049         itypi=iabs(itype(i))
2050         itypi1=iabs(itype(i+1))
2051         xi=c(1,nres+i)
2052         yi=c(2,nres+i)
2053         zi=c(3,nres+i)
2054 C
2055 C Calculate SC interaction energy.
2056 C
2057         do iint=1,nint_gr(i)
2058 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2059 cd   &                  'iend=',iend(i,iint)
2060           do j=istart(i,iint),iend(i,iint)
2061             itypj=iabs(itype(j))
2062             xj=c(1,nres+j)-xi
2063             yj=c(2,nres+j)-yi
2064             zj=c(3,nres+j)-zi
2065             rij=xj*xj+yj*yj+zj*zj
2066 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2067             r0ij=r0(itypi,itypj)
2068             r0ijsq=r0ij*r0ij
2069 c            print *,i,j,r0ij,dsqrt(rij)
2070             if (rij.lt.r0ijsq) then
2071               evdwij=0.25d0*(rij-r0ijsq)**2
2072               fac=rij-r0ijsq
2073             else
2074               evdwij=0.0d0
2075               fac=0.0d0
2076             endif
2077             evdw=evdw+evdwij
2078 C
2079 C Calculate the components of the gradient in DC and X
2080 C
2081             gg(1)=xj*fac
2082             gg(2)=yj*fac
2083             gg(3)=zj*fac
2084             do k=1,3
2085               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2086               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2087               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2088               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2089             enddo
2090 cgrad            do k=i,j-1
2091 cgrad              do l=1,3
2092 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2093 cgrad              enddo
2094 cgrad            enddo
2095           enddo ! j
2096         enddo ! iint
2097       enddo ! i
2098       return
2099       end
2100 C--------------------------------------------------------------------------
2101       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2102      &              eello_turn4)
2103 C
2104 C Soft-sphere potential of p-p interaction
2105 C
2106       implicit real*8 (a-h,o-z)
2107       include 'DIMENSIONS'
2108       include 'COMMON.CONTROL'
2109       include 'COMMON.IOUNITS'
2110       include 'COMMON.GEO'
2111       include 'COMMON.VAR'
2112       include 'COMMON.LOCAL'
2113       include 'COMMON.CHAIN'
2114       include 'COMMON.DERIV'
2115       include 'COMMON.INTERACT'
2116       include 'COMMON.CONTACTS'
2117       include 'COMMON.TORSION'
2118       include 'COMMON.VECTORS'
2119       include 'COMMON.FFIELD'
2120       dimension ggg(3)
2121 cd      write(iout,*) 'In EELEC_soft_sphere'
2122       ees=0.0D0
2123       evdw1=0.0D0
2124       eel_loc=0.0d0
2125       eello_turn3=0.0d0
2126       eello_turn4=0.0d0
2127       ind=0
2128       do i=iatel_s,iatel_e
2129         dxi=dc(1,i)
2130         dyi=dc(2,i)
2131         dzi=dc(3,i)
2132         xmedi=c(1,i)+0.5d0*dxi
2133         ymedi=c(2,i)+0.5d0*dyi
2134         zmedi=c(3,i)+0.5d0*dzi
2135         num_conti=0
2136 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2137         do j=ielstart(i),ielend(i)
2138           ind=ind+1
2139           iteli=itel(i)
2140           itelj=itel(j)
2141           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2142           r0ij=rpp(iteli,itelj)
2143           r0ijsq=r0ij*r0ij
2144           dxj=dc(1,j)
2145           dyj=dc(2,j)
2146           dzj=dc(3,j)
2147           xj=c(1,j)+0.5D0*dxj-xmedi
2148           yj=c(2,j)+0.5D0*dyj-ymedi
2149           zj=c(3,j)+0.5D0*dzj-zmedi
2150           rij=xj*xj+yj*yj+zj*zj
2151           if (rij.lt.r0ijsq) then
2152             evdw1ij=0.25d0*(rij-r0ijsq)**2
2153             fac=rij-r0ijsq
2154           else
2155             evdw1ij=0.0d0
2156             fac=0.0d0
2157           endif
2158           evdw1=evdw1+evdw1ij
2159 C
2160 C Calculate contributions to the Cartesian gradient.
2161 C
2162           ggg(1)=fac*xj
2163           ggg(2)=fac*yj
2164           ggg(3)=fac*zj
2165           do k=1,3
2166             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2167             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2168           enddo
2169 *
2170 * Loop over residues i+1 thru j-1.
2171 *
2172 cgrad          do k=i+1,j-1
2173 cgrad            do l=1,3
2174 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2175 cgrad            enddo
2176 cgrad          enddo
2177         enddo ! j
2178       enddo   ! i
2179 cgrad      do i=nnt,nct-1
2180 cgrad        do k=1,3
2181 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2182 cgrad        enddo
2183 cgrad        do j=i+1,nct-1
2184 cgrad          do k=1,3
2185 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2186 cgrad          enddo
2187 cgrad        enddo
2188 cgrad      enddo
2189       return
2190       end
2191 c------------------------------------------------------------------------------
2192       subroutine vec_and_deriv
2193       implicit real*8 (a-h,o-z)
2194       include 'DIMENSIONS'
2195 #ifdef MPI
2196       include 'mpif.h'
2197 #endif
2198       include 'COMMON.IOUNITS'
2199       include 'COMMON.GEO'
2200       include 'COMMON.VAR'
2201       include 'COMMON.LOCAL'
2202       include 'COMMON.CHAIN'
2203       include 'COMMON.VECTORS'
2204       include 'COMMON.SETUP'
2205       include 'COMMON.TIME1'
2206       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2207 C Compute the local reference systems. For reference system (i), the
2208 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2209 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2210 #ifdef PARVEC
2211       do i=ivec_start,ivec_end
2212 #else
2213       do i=1,nres-1
2214 #endif
2215           if (i.eq.nres-1) then
2216 C Case of the last full residue
2217 C Compute the Z-axis
2218             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2219             costh=dcos(pi-theta(nres))
2220             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2221             do k=1,3
2222               uz(k,i)=fac*uz(k,i)
2223             enddo
2224 C Compute the derivatives of uz
2225             uzder(1,1,1)= 0.0d0
2226             uzder(2,1,1)=-dc_norm(3,i-1)
2227             uzder(3,1,1)= dc_norm(2,i-1)
2228             uzder(1,2,1)= dc_norm(3,i-1)
2229             uzder(2,2,1)= 0.0d0
2230             uzder(3,2,1)=-dc_norm(1,i-1)
2231             uzder(1,3,1)=-dc_norm(2,i-1)
2232             uzder(2,3,1)= dc_norm(1,i-1)
2233             uzder(3,3,1)= 0.0d0
2234             uzder(1,1,2)= 0.0d0
2235             uzder(2,1,2)= dc_norm(3,i)
2236             uzder(3,1,2)=-dc_norm(2,i)
2237             uzder(1,2,2)=-dc_norm(3,i)
2238             uzder(2,2,2)= 0.0d0
2239             uzder(3,2,2)= dc_norm(1,i)
2240             uzder(1,3,2)= dc_norm(2,i)
2241             uzder(2,3,2)=-dc_norm(1,i)
2242             uzder(3,3,2)= 0.0d0
2243 C Compute the Y-axis
2244             facy=fac
2245             do k=1,3
2246               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2247             enddo
2248 C Compute the derivatives of uy
2249             do j=1,3
2250               do k=1,3
2251                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2252      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2253                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2254               enddo
2255               uyder(j,j,1)=uyder(j,j,1)-costh
2256               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2257             enddo
2258             do j=1,2
2259               do k=1,3
2260                 do l=1,3
2261                   uygrad(l,k,j,i)=uyder(l,k,j)
2262                   uzgrad(l,k,j,i)=uzder(l,k,j)
2263                 enddo
2264               enddo
2265             enddo
2266             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2267             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2268             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2269             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2270           else
2271 C Other residues
2272 C Compute the Z-axis
2273             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2274             costh=dcos(pi-theta(i+2))
2275             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2276             do k=1,3
2277               uz(k,i)=fac*uz(k,i)
2278             enddo
2279 C Compute the derivatives of uz
2280             uzder(1,1,1)= 0.0d0
2281             uzder(2,1,1)=-dc_norm(3,i+1)
2282             uzder(3,1,1)= dc_norm(2,i+1)
2283             uzder(1,2,1)= dc_norm(3,i+1)
2284             uzder(2,2,1)= 0.0d0
2285             uzder(3,2,1)=-dc_norm(1,i+1)
2286             uzder(1,3,1)=-dc_norm(2,i+1)
2287             uzder(2,3,1)= dc_norm(1,i+1)
2288             uzder(3,3,1)= 0.0d0
2289             uzder(1,1,2)= 0.0d0
2290             uzder(2,1,2)= dc_norm(3,i)
2291             uzder(3,1,2)=-dc_norm(2,i)
2292             uzder(1,2,2)=-dc_norm(3,i)
2293             uzder(2,2,2)= 0.0d0
2294             uzder(3,2,2)= dc_norm(1,i)
2295             uzder(1,3,2)= dc_norm(2,i)
2296             uzder(2,3,2)=-dc_norm(1,i)
2297             uzder(3,3,2)= 0.0d0
2298 C Compute the Y-axis
2299             facy=fac
2300             do k=1,3
2301               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2302             enddo
2303 C Compute the derivatives of uy
2304             do j=1,3
2305               do k=1,3
2306                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2307      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2308                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2309               enddo
2310               uyder(j,j,1)=uyder(j,j,1)-costh
2311               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2312             enddo
2313             do j=1,2
2314               do k=1,3
2315                 do l=1,3
2316                   uygrad(l,k,j,i)=uyder(l,k,j)
2317                   uzgrad(l,k,j,i)=uzder(l,k,j)
2318                 enddo
2319               enddo
2320             enddo
2321             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2322             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2323             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2324             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2325           endif
2326       enddo
2327       do i=1,nres-1
2328         vbld_inv_temp(1)=vbld_inv(i+1)
2329         if (i.lt.nres-1) then
2330           vbld_inv_temp(2)=vbld_inv(i+2)
2331           else
2332           vbld_inv_temp(2)=vbld_inv(i)
2333           endif
2334         do j=1,2
2335           do k=1,3
2336             do l=1,3
2337               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2338               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2339             enddo
2340           enddo
2341         enddo
2342       enddo
2343 #if defined(PARVEC) && defined(MPI)
2344       if (nfgtasks1.gt.1) then
2345         time00=MPI_Wtime()
2346 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2347 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2348 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2349         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2350      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2351      &   FG_COMM1,IERR)
2352         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2353      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2354      &   FG_COMM1,IERR)
2355         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2356      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2357      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2358         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2359      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2360      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2361         time_gather=time_gather+MPI_Wtime()-time00
2362       endif
2363 c      if (fg_rank.eq.0) then
2364 c        write (iout,*) "Arrays UY and UZ"
2365 c        do i=1,nres-1
2366 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2367 c     &     (uz(k,i),k=1,3)
2368 c        enddo
2369 c      endif
2370 #endif
2371       return
2372       end
2373 C-----------------------------------------------------------------------------
2374       subroutine check_vecgrad
2375       implicit real*8 (a-h,o-z)
2376       include 'DIMENSIONS'
2377       include 'COMMON.IOUNITS'
2378       include 'COMMON.GEO'
2379       include 'COMMON.VAR'
2380       include 'COMMON.LOCAL'
2381       include 'COMMON.CHAIN'
2382       include 'COMMON.VECTORS'
2383       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2384       dimension uyt(3,maxres),uzt(3,maxres)
2385       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2386       double precision delta /1.0d-7/
2387       call vec_and_deriv
2388 cd      do i=1,nres
2389 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2390 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2391 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2392 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2393 cd     &     (dc_norm(if90,i),if90=1,3)
2394 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2395 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2396 cd          write(iout,'(a)')
2397 cd      enddo
2398       do i=1,nres
2399         do j=1,2
2400           do k=1,3
2401             do l=1,3
2402               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2403               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2404             enddo
2405           enddo
2406         enddo
2407       enddo
2408       call vec_and_deriv
2409       do i=1,nres
2410         do j=1,3
2411           uyt(j,i)=uy(j,i)
2412           uzt(j,i)=uz(j,i)
2413         enddo
2414       enddo
2415       do i=1,nres
2416 cd        write (iout,*) 'i=',i
2417         do k=1,3
2418           erij(k)=dc_norm(k,i)
2419         enddo
2420         do j=1,3
2421           do k=1,3
2422             dc_norm(k,i)=erij(k)
2423           enddo
2424           dc_norm(j,i)=dc_norm(j,i)+delta
2425 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2426 c          do k=1,3
2427 c            dc_norm(k,i)=dc_norm(k,i)/fac
2428 c          enddo
2429 c          write (iout,*) (dc_norm(k,i),k=1,3)
2430 c          write (iout,*) (erij(k),k=1,3)
2431           call vec_and_deriv
2432           do k=1,3
2433             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2434             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2435             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2436             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2437           enddo
2438 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2439 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2440 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2441         enddo
2442         do k=1,3
2443           dc_norm(k,i)=erij(k)
2444         enddo
2445 cd        do k=1,3
2446 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2447 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2448 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2449 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2450 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2451 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2452 cd          write (iout,'(a)')
2453 cd        enddo
2454       enddo
2455       return
2456       end
2457 C--------------------------------------------------------------------------
2458       subroutine set_matrices
2459       implicit real*8 (a-h,o-z)
2460       include 'DIMENSIONS'
2461 #ifdef MPI
2462       include "mpif.h"
2463       include "COMMON.SETUP"
2464       integer IERR
2465       integer status(MPI_STATUS_SIZE)
2466 #endif
2467       include 'COMMON.IOUNITS'
2468       include 'COMMON.GEO'
2469       include 'COMMON.VAR'
2470       include 'COMMON.LOCAL'
2471       include 'COMMON.CHAIN'
2472       include 'COMMON.DERIV'
2473       include 'COMMON.INTERACT'
2474       include 'COMMON.CONTACTS'
2475       include 'COMMON.TORSION'
2476       include 'COMMON.VECTORS'
2477       include 'COMMON.FFIELD'
2478       double precision auxvec(2),auxmat(2,2)
2479 C
2480 C Compute the virtual-bond-torsional-angle dependent quantities needed
2481 C to calculate the el-loc multibody terms of various order.
2482 C
2483 #ifdef PARMAT
2484       do i=ivec_start+2,ivec_end+2
2485 #else
2486       do i=3,nres+1
2487 #endif
2488         if (i .lt. nres+1) then
2489           sin1=dsin(phi(i))
2490           cos1=dcos(phi(i))
2491           sintab(i-2)=sin1
2492           costab(i-2)=cos1
2493           obrot(1,i-2)=cos1
2494           obrot(2,i-2)=sin1
2495           sin2=dsin(2*phi(i))
2496           cos2=dcos(2*phi(i))
2497           sintab2(i-2)=sin2
2498           costab2(i-2)=cos2
2499           obrot2(1,i-2)=cos2
2500           obrot2(2,i-2)=sin2
2501           Ug(1,1,i-2)=-cos1
2502           Ug(1,2,i-2)=-sin1
2503           Ug(2,1,i-2)=-sin1
2504           Ug(2,2,i-2)= cos1
2505           Ug2(1,1,i-2)=-cos2
2506           Ug2(1,2,i-2)=-sin2
2507           Ug2(2,1,i-2)=-sin2
2508           Ug2(2,2,i-2)= cos2
2509         else
2510           costab(i-2)=1.0d0
2511           sintab(i-2)=0.0d0
2512           obrot(1,i-2)=1.0d0
2513           obrot(2,i-2)=0.0d0
2514           obrot2(1,i-2)=0.0d0
2515           obrot2(2,i-2)=0.0d0
2516           Ug(1,1,i-2)=1.0d0
2517           Ug(1,2,i-2)=0.0d0
2518           Ug(2,1,i-2)=0.0d0
2519           Ug(2,2,i-2)=1.0d0
2520           Ug2(1,1,i-2)=0.0d0
2521           Ug2(1,2,i-2)=0.0d0
2522           Ug2(2,1,i-2)=0.0d0
2523           Ug2(2,2,i-2)=0.0d0
2524         endif
2525         if (i .gt. 3 .and. i .lt. nres+1) then
2526           obrot_der(1,i-2)=-sin1
2527           obrot_der(2,i-2)= cos1
2528           Ugder(1,1,i-2)= sin1
2529           Ugder(1,2,i-2)=-cos1
2530           Ugder(2,1,i-2)=-cos1
2531           Ugder(2,2,i-2)=-sin1
2532           dwacos2=cos2+cos2
2533           dwasin2=sin2+sin2
2534           obrot2_der(1,i-2)=-dwasin2
2535           obrot2_der(2,i-2)= dwacos2
2536           Ug2der(1,1,i-2)= dwasin2
2537           Ug2der(1,2,i-2)=-dwacos2
2538           Ug2der(2,1,i-2)=-dwacos2
2539           Ug2der(2,2,i-2)=-dwasin2
2540         else
2541           obrot_der(1,i-2)=0.0d0
2542           obrot_der(2,i-2)=0.0d0
2543           Ugder(1,1,i-2)=0.0d0
2544           Ugder(1,2,i-2)=0.0d0
2545           Ugder(2,1,i-2)=0.0d0
2546           Ugder(2,2,i-2)=0.0d0
2547           obrot2_der(1,i-2)=0.0d0
2548           obrot2_der(2,i-2)=0.0d0
2549           Ug2der(1,1,i-2)=0.0d0
2550           Ug2der(1,2,i-2)=0.0d0
2551           Ug2der(2,1,i-2)=0.0d0
2552           Ug2der(2,2,i-2)=0.0d0
2553         endif
2554 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2555         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2556           iti = itortyp(itype(i-2))
2557         else
2558           iti=ntortyp+1
2559         endif
2560 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2561         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2562           iti1 = itortyp(itype(i-1))
2563         else
2564           iti1=ntortyp+1
2565         endif
2566 cd        write (iout,*) '*******i',i,' iti1',iti
2567 cd        write (iout,*) 'b1',b1(:,iti)
2568 cd        write (iout,*) 'b2',b2(:,iti)
2569 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2570 c        if (i .gt. iatel_s+2) then
2571         if (i .gt. nnt+2) then
2572           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2573           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2574           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2575      &    then
2576           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2577           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2578           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2579           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2580           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2581           endif
2582         else
2583           do k=1,2
2584             Ub2(k,i-2)=0.0d0
2585             Ctobr(k,i-2)=0.0d0
2586             Dtobr2(k,i-2)=0.0d0
2587             do l=1,2
2588               EUg(l,k,i-2)=0.0d0
2589               CUg(l,k,i-2)=0.0d0
2590               DUg(l,k,i-2)=0.0d0
2591               DtUg2(l,k,i-2)=0.0d0
2592             enddo
2593           enddo
2594         endif
2595         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2596         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2597         do k=1,2
2598           muder(k,i-2)=Ub2der(k,i-2)
2599         enddo
2600 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2601         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2602           iti1 = itortyp(itype(i-1))
2603         else
2604           iti1=ntortyp+1
2605         endif
2606         do k=1,2
2607           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2608         enddo
2609 cd        write (iout,*) 'mu ',mu(:,i-2)
2610 cd        write (iout,*) 'mu1',mu1(:,i-2)
2611 cd        write (iout,*) 'mu2',mu2(:,i-2)
2612         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2613      &  then
2614         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2615         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2616         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2617         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2618         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2619 C Vectors and matrices dependent on a single virtual-bond dihedral.
2620         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2621         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2622         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2623         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2624         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2625         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2626         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2627         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2628         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2629         endif
2630       enddo
2631 C Matrices dependent on two consecutive virtual-bond dihedrals.
2632 C The order of matrices is from left to right.
2633       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2634      &then
2635 c      do i=max0(ivec_start,2),ivec_end
2636       do i=2,nres-1
2637         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2638         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2639         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2640         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2641         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2642         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2643         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2644         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2645       enddo
2646       endif
2647 #if defined(MPI) && defined(PARMAT)
2648 #ifdef DEBUG
2649 c      if (fg_rank.eq.0) then
2650         write (iout,*) "Arrays UG and UGDER before GATHER"
2651         do i=1,nres-1
2652           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2653      &     ((ug(l,k,i),l=1,2),k=1,2),
2654      &     ((ugder(l,k,i),l=1,2),k=1,2)
2655         enddo
2656         write (iout,*) "Arrays UG2 and UG2DER"
2657         do i=1,nres-1
2658           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2659      &     ((ug2(l,k,i),l=1,2),k=1,2),
2660      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2661         enddo
2662         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2663         do i=1,nres-1
2664           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2665      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2666      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2667         enddo
2668         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2669         do i=1,nres-1
2670           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2671      &     costab(i),sintab(i),costab2(i),sintab2(i)
2672         enddo
2673         write (iout,*) "Array MUDER"
2674         do i=1,nres-1
2675           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2676         enddo
2677 c      endif
2678 #endif
2679       if (nfgtasks.gt.1) then
2680         time00=MPI_Wtime()
2681 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2682 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2683 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2684 #ifdef MATGATHER
2685         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2686      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2687      &   FG_COMM1,IERR)
2688         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2689      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2690      &   FG_COMM1,IERR)
2691         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2692      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2693      &   FG_COMM1,IERR)
2694         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2695      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2696      &   FG_COMM1,IERR)
2697         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2698      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2699      &   FG_COMM1,IERR)
2700         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2701      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2702      &   FG_COMM1,IERR)
2703         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2704      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2705      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2706         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2707      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2708      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2709         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2710      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2711      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2712         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2713      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2714      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2715         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2716      &  then
2717         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2718      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2719      &   FG_COMM1,IERR)
2720         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2721      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2722      &   FG_COMM1,IERR)
2723         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2724      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2725      &   FG_COMM1,IERR)
2726        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2727      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2728      &   FG_COMM1,IERR)
2729         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2730      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2731      &   FG_COMM1,IERR)
2732         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2733      &   ivec_count(fg_rank1),
2734      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2735      &   FG_COMM1,IERR)
2736         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2737      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2738      &   FG_COMM1,IERR)
2739         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2740      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2741      &   FG_COMM1,IERR)
2742         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2743      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2744      &   FG_COMM1,IERR)
2745         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2746      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2747      &   FG_COMM1,IERR)
2748         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2749      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2750      &   FG_COMM1,IERR)
2751         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2752      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2753      &   FG_COMM1,IERR)
2754         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2755      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2756      &   FG_COMM1,IERR)
2757         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2758      &   ivec_count(fg_rank1),
2759      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2760      &   FG_COMM1,IERR)
2761         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2762      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2763      &   FG_COMM1,IERR)
2764        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2765      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2766      &   FG_COMM1,IERR)
2767         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2768      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2769      &   FG_COMM1,IERR)
2770        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2771      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2772      &   FG_COMM1,IERR)
2773         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2774      &   ivec_count(fg_rank1),
2775      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2776      &   FG_COMM1,IERR)
2777         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2778      &   ivec_count(fg_rank1),
2779      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2780      &   FG_COMM1,IERR)
2781         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2782      &   ivec_count(fg_rank1),
2783      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2784      &   MPI_MAT2,FG_COMM1,IERR)
2785         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2786      &   ivec_count(fg_rank1),
2787      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2788      &   MPI_MAT2,FG_COMM1,IERR)
2789         endif
2790 #else
2791 c Passes matrix info through the ring
2792       isend=fg_rank1
2793       irecv=fg_rank1-1
2794       if (irecv.lt.0) irecv=nfgtasks1-1
2795       iprev=irecv
2796       inext=fg_rank1+1
2797       if (inext.ge.nfgtasks1) inext=0
2798       do i=1,nfgtasks1-1
2799 c        write (iout,*) "isend",isend," irecv",irecv
2800 c        call flush(iout)
2801         lensend=lentyp(isend)
2802         lenrecv=lentyp(irecv)
2803 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2804 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2805 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2806 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2807 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2808 c        write (iout,*) "Gather ROTAT1"
2809 c        call flush(iout)
2810 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2811 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2812 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2813 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2814 c        write (iout,*) "Gather ROTAT2"
2815 c        call flush(iout)
2816         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2817      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2818      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2819      &   iprev,4400+irecv,FG_COMM,status,IERR)
2820 c        write (iout,*) "Gather ROTAT_OLD"
2821 c        call flush(iout)
2822         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2823      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2824      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2825      &   iprev,5500+irecv,FG_COMM,status,IERR)
2826 c        write (iout,*) "Gather PRECOMP11"
2827 c        call flush(iout)
2828         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2829      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2830      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2831      &   iprev,6600+irecv,FG_COMM,status,IERR)
2832 c        write (iout,*) "Gather PRECOMP12"
2833 c        call flush(iout)
2834         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2835      &  then
2836         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2837      &   MPI_ROTAT2(lensend),inext,7700+isend,
2838      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2839      &   iprev,7700+irecv,FG_COMM,status,IERR)
2840 c        write (iout,*) "Gather PRECOMP21"
2841 c        call flush(iout)
2842         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2843      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2844      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2845      &   iprev,8800+irecv,FG_COMM,status,IERR)
2846 c        write (iout,*) "Gather PRECOMP22"
2847 c        call flush(iout)
2848         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2849      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2850      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2851      &   MPI_PRECOMP23(lenrecv),
2852      &   iprev,9900+irecv,FG_COMM,status,IERR)
2853 c        write (iout,*) "Gather PRECOMP23"
2854 c        call flush(iout)
2855         endif
2856         isend=irecv
2857         irecv=irecv-1
2858         if (irecv.lt.0) irecv=nfgtasks1-1
2859       enddo
2860 #endif
2861         time_gather=time_gather+MPI_Wtime()-time00
2862       endif
2863 #ifdef DEBUG
2864 c      if (fg_rank.eq.0) then
2865         write (iout,*) "Arrays UG and UGDER"
2866         do i=1,nres-1
2867           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2868      &     ((ug(l,k,i),l=1,2),k=1,2),
2869      &     ((ugder(l,k,i),l=1,2),k=1,2)
2870         enddo
2871         write (iout,*) "Arrays UG2 and UG2DER"
2872         do i=1,nres-1
2873           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2874      &     ((ug2(l,k,i),l=1,2),k=1,2),
2875      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2876         enddo
2877         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2878         do i=1,nres-1
2879           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2880      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2881      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2882         enddo
2883         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2884         do i=1,nres-1
2885           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2886      &     costab(i),sintab(i),costab2(i),sintab2(i)
2887         enddo
2888         write (iout,*) "Array MUDER"
2889         do i=1,nres-1
2890           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2891         enddo
2892 c      endif
2893 #endif
2894 #endif
2895 cd      do i=1,nres
2896 cd        iti = itortyp(itype(i))
2897 cd        write (iout,*) i
2898 cd        do j=1,2
2899 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2900 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2901 cd        enddo
2902 cd      enddo
2903       return
2904       end
2905 C--------------------------------------------------------------------------
2906       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2907 C
2908 C This subroutine calculates the average interaction energy and its gradient
2909 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2910 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2911 C The potential depends both on the distance of peptide-group centers and on
2912 C the orientation of the CA-CA virtual bonds.
2913 C
2914       implicit real*8 (a-h,o-z)
2915 #ifdef MPI
2916       include 'mpif.h'
2917 #endif
2918       include 'DIMENSIONS'
2919       include 'COMMON.CONTROL'
2920       include 'COMMON.SETUP'
2921       include 'COMMON.IOUNITS'
2922       include 'COMMON.GEO'
2923       include 'COMMON.VAR'
2924       include 'COMMON.LOCAL'
2925       include 'COMMON.CHAIN'
2926       include 'COMMON.DERIV'
2927       include 'COMMON.INTERACT'
2928       include 'COMMON.CONTACTS'
2929       include 'COMMON.TORSION'
2930       include 'COMMON.VECTORS'
2931       include 'COMMON.FFIELD'
2932       include 'COMMON.TIME1'
2933       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2934      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2935       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2936      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2937       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2938      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2939      &    num_conti,j1,j2
2940 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2941 #ifdef MOMENT
2942       double precision scal_el /1.0d0/
2943 #else
2944       double precision scal_el /0.5d0/
2945 #endif
2946 C 12/13/98
2947 C 13-go grudnia roku pamietnego...
2948       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2949      &                   0.0d0,1.0d0,0.0d0,
2950      &                   0.0d0,0.0d0,1.0d0/
2951 cd      write(iout,*) 'In EELEC'
2952 cd      do i=1,nloctyp
2953 cd        write(iout,*) 'Type',i
2954 cd        write(iout,*) 'B1',B1(:,i)
2955 cd        write(iout,*) 'B2',B2(:,i)
2956 cd        write(iout,*) 'CC',CC(:,:,i)
2957 cd        write(iout,*) 'DD',DD(:,:,i)
2958 cd        write(iout,*) 'EE',EE(:,:,i)
2959 cd      enddo
2960 cd      call check_vecgrad
2961 cd      stop
2962       if (icheckgrad.eq.1) then
2963         do i=1,nres-1
2964           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2965           do k=1,3
2966             dc_norm(k,i)=dc(k,i)*fac
2967           enddo
2968 c          write (iout,*) 'i',i,' fac',fac
2969         enddo
2970       endif
2971       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2972      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2973      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2974 c        call vec_and_deriv
2975 #ifdef TIMING
2976         time01=MPI_Wtime()
2977 #endif
2978         call set_matrices
2979 #ifdef TIMING
2980         time_mat=time_mat+MPI_Wtime()-time01
2981 #endif
2982       endif
2983 cd      do i=1,nres-1
2984 cd        write (iout,*) 'i=',i
2985 cd        do k=1,3
2986 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2987 cd        enddo
2988 cd        do k=1,3
2989 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2990 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2991 cd        enddo
2992 cd      enddo
2993       t_eelecij=0.0d0
2994       ees=0.0D0
2995       evdw1=0.0D0
2996       eel_loc=0.0d0
2997       eello_turn3=0.0d0
2998       eello_turn4=0.0d0
2999       ind=0
3000       do i=1,nres
3001         num_cont_hb(i)=0
3002       enddo
3003 cd      print '(a)','Enter EELEC'
3004 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3005       do i=1,nres
3006         gel_loc_loc(i)=0.0d0
3007         gcorr_loc(i)=0.0d0
3008       enddo
3009 c
3010 c
3011 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3012 C
3013 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3014 C
3015       do i=iturn3_start,iturn3_end
3016         dxi=dc(1,i)
3017         dyi=dc(2,i)
3018         dzi=dc(3,i)
3019         dx_normi=dc_norm(1,i)
3020         dy_normi=dc_norm(2,i)
3021         dz_normi=dc_norm(3,i)
3022         xmedi=c(1,i)+0.5d0*dxi
3023         ymedi=c(2,i)+0.5d0*dyi
3024         zmedi=c(3,i)+0.5d0*dzi
3025         num_conti=0
3026         call eelecij(i,i+2,ees,evdw1,eel_loc)
3027         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3028         num_cont_hb(i)=num_conti
3029       enddo
3030       do i=iturn4_start,iturn4_end
3031         dxi=dc(1,i)
3032         dyi=dc(2,i)
3033         dzi=dc(3,i)
3034         dx_normi=dc_norm(1,i)
3035         dy_normi=dc_norm(2,i)
3036         dz_normi=dc_norm(3,i)
3037         xmedi=c(1,i)+0.5d0*dxi
3038         ymedi=c(2,i)+0.5d0*dyi
3039         zmedi=c(3,i)+0.5d0*dzi
3040         num_conti=num_cont_hb(i)
3041         call eelecij(i,i+3,ees,evdw1,eel_loc)
3042         if (wturn4.gt.0.0d0) call eturn4(i,eello_turn4)
3043         num_cont_hb(i)=num_conti
3044       enddo   ! i
3045 c
3046 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3047 c
3048       do i=iatel_s,iatel_e
3049         dxi=dc(1,i)
3050         dyi=dc(2,i)
3051         dzi=dc(3,i)
3052         dx_normi=dc_norm(1,i)
3053         dy_normi=dc_norm(2,i)
3054         dz_normi=dc_norm(3,i)
3055         xmedi=c(1,i)+0.5d0*dxi
3056         ymedi=c(2,i)+0.5d0*dyi
3057         zmedi=c(3,i)+0.5d0*dzi
3058 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3059         num_conti=num_cont_hb(i)
3060         do j=ielstart(i),ielend(i)
3061           call eelecij(i,j,ees,evdw1,eel_loc)
3062         enddo ! j
3063         num_cont_hb(i)=num_conti
3064       enddo   ! i
3065 c      write (iout,*) "Number of loop steps in EELEC:",ind
3066 cd      do i=1,nres
3067 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3068 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3069 cd      enddo
3070 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3071 ccc      eel_loc=eel_loc+eello_turn3
3072 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3073       return
3074       end
3075 C-------------------------------------------------------------------------------
3076       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3077       implicit real*8 (a-h,o-z)
3078       include 'DIMENSIONS'
3079 #ifdef MPI
3080       include "mpif.h"
3081 #endif
3082       include 'COMMON.CONTROL'
3083       include 'COMMON.IOUNITS'
3084       include 'COMMON.GEO'
3085       include 'COMMON.VAR'
3086       include 'COMMON.LOCAL'
3087       include 'COMMON.CHAIN'
3088       include 'COMMON.DERIV'
3089       include 'COMMON.INTERACT'
3090       include 'COMMON.CONTACTS'
3091       include 'COMMON.TORSION'
3092       include 'COMMON.VECTORS'
3093       include 'COMMON.FFIELD'
3094       include 'COMMON.TIME1'
3095       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3096      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3097       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3098      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3099       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3100      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3101      &    num_conti,j1,j2
3102 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3103 #ifdef MOMENT
3104       double precision scal_el /1.0d0/
3105 #else
3106       double precision scal_el /0.5d0/
3107 #endif
3108 C 12/13/98
3109 C 13-go grudnia roku pamietnego...
3110       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3111      &                   0.0d0,1.0d0,0.0d0,
3112      &                   0.0d0,0.0d0,1.0d0/
3113 c          time00=MPI_Wtime()
3114 cd      write (iout,*) "eelecij",i,j
3115 c          ind=ind+1
3116           iteli=itel(i)
3117           itelj=itel(j)
3118           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3119           aaa=app(iteli,itelj)
3120           bbb=bpp(iteli,itelj)
3121           ael6i=ael6(iteli,itelj)
3122           ael3i=ael3(iteli,itelj)
3123           dxj=dc(1,j)
3124           dyj=dc(2,j)
3125           dzj=dc(3,j)
3126           dx_normj=dc_norm(1,j)
3127           dy_normj=dc_norm(2,j)
3128           dz_normj=dc_norm(3,j)
3129           xj=c(1,j)+0.5D0*dxj-xmedi
3130           yj=c(2,j)+0.5D0*dyj-ymedi
3131           zj=c(3,j)+0.5D0*dzj-zmedi
3132           rij=xj*xj+yj*yj+zj*zj
3133           rrmij=1.0D0/rij
3134           rij=dsqrt(rij)
3135           rmij=1.0D0/rij
3136           r3ij=rrmij*rmij
3137           r6ij=r3ij*r3ij
3138           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3139           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3140           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3141           fac=cosa-3.0D0*cosb*cosg
3142           ev1=aaa*r6ij*r6ij
3143 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3144           if (j.eq.i+2) ev1=scal_el*ev1
3145           ev2=bbb*r6ij
3146           fac3=ael6i*r6ij
3147           fac4=ael3i*r3ij
3148           evdwij=ev1+ev2
3149           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3150           el2=fac4*fac
3151           eesij=el1+el2
3152 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3153           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3154           ees=ees+eesij
3155           evdw1=evdw1+evdwij
3156 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3157 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3158 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3159 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3160
3161           if (energy_dec) then
3162               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3163               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3164           endif
3165
3166 C
3167 C Calculate contributions to the Cartesian gradient.
3168 C
3169 #ifdef SPLITELE
3170           facvdw=-6*rrmij*(ev1+evdwij)
3171           facel=-3*rrmij*(el1+eesij)
3172           fac1=fac
3173           erij(1)=xj*rmij
3174           erij(2)=yj*rmij
3175           erij(3)=zj*rmij
3176 *
3177 * Radial derivatives. First process both termini of the fragment (i,j)
3178 *
3179           ggg(1)=facel*xj
3180           ggg(2)=facel*yj
3181           ggg(3)=facel*zj
3182 c          do k=1,3
3183 c            ghalf=0.5D0*ggg(k)
3184 c            gelc(k,i)=gelc(k,i)+ghalf
3185 c            gelc(k,j)=gelc(k,j)+ghalf
3186 c          enddo
3187 c 9/28/08 AL Gradient compotents will be summed only at the end
3188           do k=1,3
3189             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3190             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3191           enddo
3192 *
3193 * Loop over residues i+1 thru j-1.
3194 *
3195 cgrad          do k=i+1,j-1
3196 cgrad            do l=1,3
3197 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3198 cgrad            enddo
3199 cgrad          enddo
3200           ggg(1)=facvdw*xj
3201           ggg(2)=facvdw*yj
3202           ggg(3)=facvdw*zj
3203 c          do k=1,3
3204 c            ghalf=0.5D0*ggg(k)
3205 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3206 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3207 c          enddo
3208 c 9/28/08 AL Gradient compotents will be summed only at the end
3209           do k=1,3
3210             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3211             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3212           enddo
3213 *
3214 * Loop over residues i+1 thru j-1.
3215 *
3216 cgrad          do k=i+1,j-1
3217 cgrad            do l=1,3
3218 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3219 cgrad            enddo
3220 cgrad          enddo
3221 #else
3222           facvdw=ev1+evdwij
3223           facel=el1+eesij
3224           fac1=fac
3225           fac=-3*rrmij*(facvdw+facvdw+facel)
3226           erij(1)=xj*rmij
3227           erij(2)=yj*rmij
3228           erij(3)=zj*rmij
3229 *
3230 * Radial derivatives. First process both termini of the fragment (i,j)
3231 *
3232           ggg(1)=fac*xj
3233           ggg(2)=fac*yj
3234           ggg(3)=fac*zj
3235 c          do k=1,3
3236 c            ghalf=0.5D0*ggg(k)
3237 c            gelc(k,i)=gelc(k,i)+ghalf
3238 c            gelc(k,j)=gelc(k,j)+ghalf
3239 c          enddo
3240 c 9/28/08 AL Gradient compotents will be summed only at the end
3241           do k=1,3
3242             gelc_long(k,j)=gelc(k,j)+ggg(k)
3243             gelc_long(k,i)=gelc(k,i)-ggg(k)
3244           enddo
3245 *
3246 * Loop over residues i+1 thru j-1.
3247 *
3248 cgrad          do k=i+1,j-1
3249 cgrad            do l=1,3
3250 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3251 cgrad            enddo
3252 cgrad          enddo
3253 c 9/28/08 AL Gradient compotents will be summed only at the end
3254           ggg(1)=facvdw*xj
3255           ggg(2)=facvdw*yj
3256           ggg(3)=facvdw*zj
3257           do k=1,3
3258             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3259             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3260           enddo
3261 #endif
3262 *
3263 * Angular part
3264 *
3265           ecosa=2.0D0*fac3*fac1+fac4
3266           fac4=-3.0D0*fac4
3267           fac3=-6.0D0*fac3
3268           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3269           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3270           do k=1,3
3271             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3272             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3273           enddo
3274 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3275 cd   &          (dcosg(k),k=1,3)
3276           do k=1,3
3277             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3278           enddo
3279 c          do k=1,3
3280 c            ghalf=0.5D0*ggg(k)
3281 c            gelc(k,i)=gelc(k,i)+ghalf
3282 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3283 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3284 c            gelc(k,j)=gelc(k,j)+ghalf
3285 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3286 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3287 c          enddo
3288 cgrad          do k=i+1,j-1
3289 cgrad            do l=1,3
3290 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3291 cgrad            enddo
3292 cgrad          enddo
3293           do k=1,3
3294             gelc(k,i)=gelc(k,i)
3295      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3296      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3297             gelc(k,j)=gelc(k,j)
3298      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3299      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3300             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3301             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3302           enddo
3303           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3304      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3305      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3306 C
3307 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3308 C   energy of a peptide unit is assumed in the form of a second-order
3309 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3310 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3311 C   are computed for EVERY pair of non-contiguous peptide groups.
3312 C
3313           if (j.lt.nres-1) then
3314             j1=j+1
3315             j2=j-1
3316           else
3317             j1=j-1
3318             j2=j-2
3319           endif
3320           kkk=0
3321           do k=1,2
3322             do l=1,2
3323               kkk=kkk+1
3324               muij(kkk)=mu(k,i)*mu(l,j)
3325             enddo
3326           enddo
3327 cd         write (iout,*) 'EELEC: i',i,' j',j
3328 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3329 cd          write(iout,*) 'muij',muij
3330           ury=scalar(uy(1,i),erij)
3331           urz=scalar(uz(1,i),erij)
3332           vry=scalar(uy(1,j),erij)
3333           vrz=scalar(uz(1,j),erij)
3334           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3335           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3336           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3337           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3338           fac=dsqrt(-ael6i)*r3ij
3339           a22=a22*fac
3340           a23=a23*fac
3341           a32=a32*fac
3342           a33=a33*fac
3343 cd          write (iout,'(4i5,4f10.5)')
3344 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3345 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3346 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3347 cd     &      uy(:,j),uz(:,j)
3348 cd          write (iout,'(4f10.5)')
3349 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3350 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3351 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3352 cd           write (iout,'(9f10.5/)')
3353 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3354 C Derivatives of the elements of A in virtual-bond vectors
3355           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3356           do k=1,3
3357             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3358             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3359             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3360             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3361             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3362             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3363             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3364             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3365             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3366             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3367             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3368             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3369           enddo
3370 C Compute radial contributions to the gradient
3371           facr=-3.0d0*rrmij
3372           a22der=a22*facr
3373           a23der=a23*facr
3374           a32der=a32*facr
3375           a33der=a33*facr
3376           agg(1,1)=a22der*xj
3377           agg(2,1)=a22der*yj
3378           agg(3,1)=a22der*zj
3379           agg(1,2)=a23der*xj
3380           agg(2,2)=a23der*yj
3381           agg(3,2)=a23der*zj
3382           agg(1,3)=a32der*xj
3383           agg(2,3)=a32der*yj
3384           agg(3,3)=a32der*zj
3385           agg(1,4)=a33der*xj
3386           agg(2,4)=a33der*yj
3387           agg(3,4)=a33der*zj
3388 C Add the contributions coming from er
3389           fac3=-3.0d0*fac
3390           do k=1,3
3391             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3392             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3393             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3394             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3395           enddo
3396           do k=1,3
3397 C Derivatives in DC(i)
3398 cgrad            ghalf1=0.5d0*agg(k,1)
3399 cgrad            ghalf2=0.5d0*agg(k,2)
3400 cgrad            ghalf3=0.5d0*agg(k,3)
3401 cgrad            ghalf4=0.5d0*agg(k,4)
3402             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3403      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3404             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3405      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3406             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3407      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3408             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3409      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3410 C Derivatives in DC(i+1)
3411             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3412      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3413             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3414      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3415             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3416      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3417             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3418      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3419 C Derivatives in DC(j)
3420             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3421      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3422             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3423      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3424             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3425      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3426             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3427      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3428 C Derivatives in DC(j+1) or DC(nres-1)
3429             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3430      &      -3.0d0*vryg(k,3)*ury)
3431             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3432      &      -3.0d0*vrzg(k,3)*ury)
3433             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3434      &      -3.0d0*vryg(k,3)*urz)
3435             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3436      &      -3.0d0*vrzg(k,3)*urz)
3437 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3438 cgrad              do l=1,4
3439 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3440 cgrad              enddo
3441 cgrad            endif
3442           enddo
3443           acipa(1,1)=a22
3444           acipa(1,2)=a23
3445           acipa(2,1)=a32
3446           acipa(2,2)=a33
3447           a22=-a22
3448           a23=-a23
3449           do l=1,2
3450             do k=1,3
3451               agg(k,l)=-agg(k,l)
3452               aggi(k,l)=-aggi(k,l)
3453               aggi1(k,l)=-aggi1(k,l)
3454               aggj(k,l)=-aggj(k,l)
3455               aggj1(k,l)=-aggj1(k,l)
3456             enddo
3457           enddo
3458           if (j.lt.nres-1) then
3459             a22=-a22
3460             a32=-a32
3461             do l=1,3,2
3462               do k=1,3
3463                 agg(k,l)=-agg(k,l)
3464                 aggi(k,l)=-aggi(k,l)
3465                 aggi1(k,l)=-aggi1(k,l)
3466                 aggj(k,l)=-aggj(k,l)
3467                 aggj1(k,l)=-aggj1(k,l)
3468               enddo
3469             enddo
3470           else
3471             a22=-a22
3472             a23=-a23
3473             a32=-a32
3474             a33=-a33
3475             do l=1,4
3476               do k=1,3
3477                 agg(k,l)=-agg(k,l)
3478                 aggi(k,l)=-aggi(k,l)
3479                 aggi1(k,l)=-aggi1(k,l)
3480                 aggj(k,l)=-aggj(k,l)
3481                 aggj1(k,l)=-aggj1(k,l)
3482               enddo
3483             enddo
3484           endif
3485           ENDIF ! WCORR
3486           IF (wel_loc.gt.0.0d0) THEN
3487 C Contribution to the local-electrostatic energy coming from the i-j pair
3488           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3489      &     +a33*muij(4)
3490 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3491
3492           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3493      &            'eelloc',i,j,eel_loc_ij
3494
3495           eel_loc=eel_loc+eel_loc_ij
3496 C Partial derivatives in virtual-bond dihedral angles gamma
3497           if (i.gt.1)
3498      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3499      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3500      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3501           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3502      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3503      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3504 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3505           do l=1,3
3506             ggg(l)=agg(l,1)*muij(1)+
3507      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3508             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3509             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3510 cgrad            ghalf=0.5d0*ggg(l)
3511 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3512 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3513           enddo
3514 cgrad          do k=i+1,j2
3515 cgrad            do l=1,3
3516 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3517 cgrad            enddo
3518 cgrad          enddo
3519 C Remaining derivatives of eello
3520           do l=1,3
3521             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3522      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3523             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3524      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3525             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3526      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3527             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3528      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3529           enddo
3530           ENDIF
3531 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3532 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3533           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3534      &       .and. num_conti.le.maxconts) then
3535 c            write (iout,*) i,j," entered corr"
3536 C
3537 C Calculate the contact function. The ith column of the array JCONT will
3538 C contain the numbers of atoms that make contacts with the atom I (of numbers
3539 C greater than I). The arrays FACONT and GACONT will contain the values of
3540 C the contact function and its derivative.
3541 c           r0ij=1.02D0*rpp(iteli,itelj)
3542 c           r0ij=1.11D0*rpp(iteli,itelj)
3543             r0ij=2.20D0*rpp(iteli,itelj)
3544 c           r0ij=1.55D0*rpp(iteli,itelj)
3545             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3546             if (fcont.gt.0.0D0) then
3547               num_conti=num_conti+1
3548               if (num_conti.gt.maxconts) then
3549                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3550      &                         ' will skip next contacts for this conf.'
3551               else
3552                 jcont_hb(num_conti,i)=j
3553 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3554 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3555                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3556      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3557 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3558 C  terms.
3559                 d_cont(num_conti,i)=rij
3560 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3561 C     --- Electrostatic-interaction matrix ---
3562                 a_chuj(1,1,num_conti,i)=a22
3563                 a_chuj(1,2,num_conti,i)=a23
3564                 a_chuj(2,1,num_conti,i)=a32
3565                 a_chuj(2,2,num_conti,i)=a33
3566 C     --- Gradient of rij
3567                 do kkk=1,3
3568                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3569                 enddo
3570                 kkll=0
3571                 do k=1,2
3572                   do l=1,2
3573                     kkll=kkll+1
3574                     do m=1,3
3575                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3576                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3577                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3578                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3579                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3580                     enddo
3581                   enddo
3582                 enddo
3583                 ENDIF
3584                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3585 C Calculate contact energies
3586                 cosa4=4.0D0*cosa
3587                 wij=cosa-3.0D0*cosb*cosg
3588                 cosbg1=cosb+cosg
3589                 cosbg2=cosb-cosg
3590 c               fac3=dsqrt(-ael6i)/r0ij**3
3591                 fac3=dsqrt(-ael6i)*r3ij
3592 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3593                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3594                 if (ees0tmp.gt.0) then
3595                   ees0pij=dsqrt(ees0tmp)
3596                 else
3597                   ees0pij=0
3598                 endif
3599 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3600                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3601                 if (ees0tmp.gt.0) then
3602                   ees0mij=dsqrt(ees0tmp)
3603                 else
3604                   ees0mij=0
3605                 endif
3606 c               ees0mij=0.0D0
3607                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3608                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3609 C Diagnostics. Comment out or remove after debugging!
3610 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3611 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3612 c               ees0m(num_conti,i)=0.0D0
3613 C End diagnostics.
3614 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3615 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3616 C Angular derivatives of the contact function
3617                 ees0pij1=fac3/ees0pij
3618                 ees0mij1=fac3/ees0mij
3619                 fac3p=-3.0D0*fac3*rrmij
3620                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3621                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3622 c               ees0mij1=0.0D0
3623                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3624                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3625                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3626                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3627                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3628                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3629                 ecosap=ecosa1+ecosa2
3630                 ecosbp=ecosb1+ecosb2
3631                 ecosgp=ecosg1+ecosg2
3632                 ecosam=ecosa1-ecosa2
3633                 ecosbm=ecosb1-ecosb2
3634                 ecosgm=ecosg1-ecosg2
3635 C Diagnostics
3636 c               ecosap=ecosa1
3637 c               ecosbp=ecosb1
3638 c               ecosgp=ecosg1
3639 c               ecosam=0.0D0
3640 c               ecosbm=0.0D0
3641 c               ecosgm=0.0D0
3642 C End diagnostics
3643                 facont_hb(num_conti,i)=fcont
3644                 fprimcont=fprimcont/rij
3645 cd              facont_hb(num_conti,i)=1.0D0
3646 C Following line is for diagnostics.
3647 cd              fprimcont=0.0D0
3648                 do k=1,3
3649                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3650                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3651                 enddo
3652                 do k=1,3
3653                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3654                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3655                 enddo
3656                 gggp(1)=gggp(1)+ees0pijp*xj
3657                 gggp(2)=gggp(2)+ees0pijp*yj
3658                 gggp(3)=gggp(3)+ees0pijp*zj
3659                 gggm(1)=gggm(1)+ees0mijp*xj
3660                 gggm(2)=gggm(2)+ees0mijp*yj
3661                 gggm(3)=gggm(3)+ees0mijp*zj
3662 C Derivatives due to the contact function
3663                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3664                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3665                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3666                 do k=1,3
3667 c
3668 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3669 c          following the change of gradient-summation algorithm.
3670 c
3671 cgrad                  ghalfp=0.5D0*gggp(k)
3672 cgrad                  ghalfm=0.5D0*gggm(k)
3673                   gacontp_hb1(k,num_conti,i)=!ghalfp
3674      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3675      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3676                   gacontp_hb2(k,num_conti,i)=!ghalfp
3677      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3678      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3679                   gacontp_hb3(k,num_conti,i)=gggp(k)
3680                   gacontm_hb1(k,num_conti,i)=!ghalfm
3681      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3682      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3683                   gacontm_hb2(k,num_conti,i)=!ghalfm
3684      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3685      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3686                   gacontm_hb3(k,num_conti,i)=gggm(k)
3687                 enddo
3688 C Diagnostics. Comment out or remove after debugging!
3689 cdiag           do k=1,3
3690 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3691 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3692 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3693 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3694 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3695 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3696 cdiag           enddo
3697               ENDIF ! wcorr
3698               endif  ! num_conti.le.maxconts
3699             endif  ! fcont.gt.0
3700           endif    ! j.gt.i+1
3701           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3702             do k=1,4
3703               do l=1,3
3704                 ghalf=0.5d0*agg(l,k)
3705                 aggi(l,k)=aggi(l,k)+ghalf
3706                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3707                 aggj(l,k)=aggj(l,k)+ghalf
3708               enddo
3709             enddo
3710             if (j.eq.nres-1 .and. i.lt.j-2) then
3711               do k=1,4
3712                 do l=1,3
3713                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3714                 enddo
3715               enddo
3716             endif
3717           endif
3718 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3719       return
3720       end
3721 C-----------------------------------------------------------------------------
3722       subroutine eturn3(i,eello_turn3)
3723 C Third- and fourth-order contributions from turns
3724       implicit real*8 (a-h,o-z)
3725       include 'DIMENSIONS'
3726       include 'COMMON.IOUNITS'
3727       include 'COMMON.GEO'
3728       include 'COMMON.VAR'
3729       include 'COMMON.LOCAL'
3730       include 'COMMON.CHAIN'
3731       include 'COMMON.DERIV'
3732       include 'COMMON.INTERACT'
3733       include 'COMMON.CONTACTS'
3734       include 'COMMON.TORSION'
3735       include 'COMMON.VECTORS'
3736       include 'COMMON.FFIELD'
3737       include 'COMMON.CONTROL'
3738       dimension ggg(3)
3739       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3740      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3741      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3742       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3743      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3744       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3745      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3746      &    num_conti,j1,j2
3747       j=i+2
3748 c      write (iout,*) "eturn3",i,j,j1,j2
3749       a_temp(1,1)=a22
3750       a_temp(1,2)=a23
3751       a_temp(2,1)=a32
3752       a_temp(2,2)=a33
3753 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3754 C
3755 C               Third-order contributions
3756 C
3757 C                 (i+2)o----(i+3)
3758 C                      | |
3759 C                      | |
3760 C                 (i+1)o----i
3761 C
3762 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3763 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3764         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3765         call transpose2(auxmat(1,1),auxmat1(1,1))
3766         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3767         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3768         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3769      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3770 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3771 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3772 cd     &    ' eello_turn3_num',4*eello_turn3_num
3773 C Derivatives in gamma(i)
3774         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3775         call transpose2(auxmat2(1,1),auxmat3(1,1))
3776         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3777         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3778 C Derivatives in gamma(i+1)
3779         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3780         call transpose2(auxmat2(1,1),auxmat3(1,1))
3781         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3782         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3783      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3784 C Cartesian derivatives
3785         do l=1,3
3786 c            ghalf1=0.5d0*agg(l,1)
3787 c            ghalf2=0.5d0*agg(l,2)
3788 c            ghalf3=0.5d0*agg(l,3)
3789 c            ghalf4=0.5d0*agg(l,4)
3790           a_temp(1,1)=aggi(l,1)!+ghalf1
3791           a_temp(1,2)=aggi(l,2)!+ghalf2
3792           a_temp(2,1)=aggi(l,3)!+ghalf3
3793           a_temp(2,2)=aggi(l,4)!+ghalf4
3794           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3795           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3796      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3797           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3798           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3799           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3800           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3801           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3802           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3803      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3804           a_temp(1,1)=aggj(l,1)!+ghalf1
3805           a_temp(1,2)=aggj(l,2)!+ghalf2
3806           a_temp(2,1)=aggj(l,3)!+ghalf3
3807           a_temp(2,2)=aggj(l,4)!+ghalf4
3808           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3809           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3810      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3811           a_temp(1,1)=aggj1(l,1)
3812           a_temp(1,2)=aggj1(l,2)
3813           a_temp(2,1)=aggj1(l,3)
3814           a_temp(2,2)=aggj1(l,4)
3815           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3816           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3817      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3818         enddo
3819       return
3820       end
3821 C-------------------------------------------------------------------------------
3822       subroutine eturn4(i,eello_turn4)
3823 C Third- and fourth-order contributions from turns
3824       implicit real*8 (a-h,o-z)
3825       include 'DIMENSIONS'
3826       include 'COMMON.IOUNITS'
3827       include 'COMMON.GEO'
3828       include 'COMMON.VAR'
3829       include 'COMMON.LOCAL'
3830       include 'COMMON.CHAIN'
3831       include 'COMMON.DERIV'
3832       include 'COMMON.INTERACT'
3833       include 'COMMON.CONTACTS'
3834       include 'COMMON.TORSION'
3835       include 'COMMON.VECTORS'
3836       include 'COMMON.FFIELD'
3837       include 'COMMON.CONTROL'
3838       dimension ggg(3)
3839       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3840      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3841      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3842       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3843      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3844       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3845      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3846      &    num_conti,j1,j2
3847       j=i+3
3848 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3849 C
3850 C               Fourth-order contributions
3851 C
3852 C                 (i+3)o----(i+4)
3853 C                     /  |
3854 C               (i+2)o   |
3855 C                     \  |
3856 C                 (i+1)o----i
3857 C
3858 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3859 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3860 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3861         a_temp(1,1)=a22
3862         a_temp(1,2)=a23
3863         a_temp(2,1)=a32
3864         a_temp(2,2)=a33
3865         iti1=itortyp(itype(i+1))
3866         iti2=itortyp(itype(i+2))
3867         iti3=itortyp(itype(i+3))
3868 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3869         call transpose2(EUg(1,1,i+1),e1t(1,1))
3870         call transpose2(Eug(1,1,i+2),e2t(1,1))
3871         call transpose2(Eug(1,1,i+3),e3t(1,1))
3872         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3873         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3874         s1=scalar2(b1(1,iti2),auxvec(1))
3875         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3876         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3877         s2=scalar2(b1(1,iti1),auxvec(1))
3878         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3879         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3880         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3881         eello_turn4=eello_turn4-(s1+s2+s3)
3882         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3883      &      'eturn4',i,j,-(s1+s2+s3)
3884 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3885 cd     &    ' eello_turn4_num',8*eello_turn4_num
3886 C Derivatives in gamma(i)
3887         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3888         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3889         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3890         s1=scalar2(b1(1,iti2),auxvec(1))
3891         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3892         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3893         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3894 C Derivatives in gamma(i+1)
3895         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3896         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3897         s2=scalar2(b1(1,iti1),auxvec(1))
3898         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3899         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3900         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3901         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3902 C Derivatives in gamma(i+2)
3903         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3904         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3905         s1=scalar2(b1(1,iti2),auxvec(1))
3906         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3907         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3908         s2=scalar2(b1(1,iti1),auxvec(1))
3909         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3910         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3911         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3912         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3913 C Cartesian derivatives
3914 C Derivatives of this turn contributions in DC(i+2)
3915         if (j.lt.nres-1) then
3916           do l=1,3
3917             a_temp(1,1)=agg(l,1)
3918             a_temp(1,2)=agg(l,2)
3919             a_temp(2,1)=agg(l,3)
3920             a_temp(2,2)=agg(l,4)
3921             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3922             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3923             s1=scalar2(b1(1,iti2),auxvec(1))
3924             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3925             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3926             s2=scalar2(b1(1,iti1),auxvec(1))
3927             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3928             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3929             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3930             ggg(l)=-(s1+s2+s3)
3931             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3932           enddo
3933         endif
3934 C Remaining derivatives of this turn contribution
3935         do l=1,3
3936           a_temp(1,1)=aggi(l,1)
3937           a_temp(1,2)=aggi(l,2)
3938           a_temp(2,1)=aggi(l,3)
3939           a_temp(2,2)=aggi(l,4)
3940           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3941           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3942           s1=scalar2(b1(1,iti2),auxvec(1))
3943           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3944           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3945           s2=scalar2(b1(1,iti1),auxvec(1))
3946           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3947           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3948           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3949           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3950           a_temp(1,1)=aggi1(l,1)
3951           a_temp(1,2)=aggi1(l,2)
3952           a_temp(2,1)=aggi1(l,3)
3953           a_temp(2,2)=aggi1(l,4)
3954           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3955           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3956           s1=scalar2(b1(1,iti2),auxvec(1))
3957           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3958           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3959           s2=scalar2(b1(1,iti1),auxvec(1))
3960           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3961           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3962           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3963           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3964           a_temp(1,1)=aggj(l,1)
3965           a_temp(1,2)=aggj(l,2)
3966           a_temp(2,1)=aggj(l,3)
3967           a_temp(2,2)=aggj(l,4)
3968           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3969           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3970           s1=scalar2(b1(1,iti2),auxvec(1))
3971           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3972           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3973           s2=scalar2(b1(1,iti1),auxvec(1))
3974           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3975           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3976           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3977           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3978           a_temp(1,1)=aggj1(l,1)
3979           a_temp(1,2)=aggj1(l,2)
3980           a_temp(2,1)=aggj1(l,3)
3981           a_temp(2,2)=aggj1(l,4)
3982           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3983           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3984           s1=scalar2(b1(1,iti2),auxvec(1))
3985           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3986           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3987           s2=scalar2(b1(1,iti1),auxvec(1))
3988           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3989           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3990           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3991 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3992           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3993         enddo
3994       return
3995       end
3996 C-----------------------------------------------------------------------------
3997       subroutine vecpr(u,v,w)
3998       implicit real*8(a-h,o-z)
3999       dimension u(3),v(3),w(3)
4000       w(1)=u(2)*v(3)-u(3)*v(2)
4001       w(2)=-u(1)*v(3)+u(3)*v(1)
4002       w(3)=u(1)*v(2)-u(2)*v(1)
4003       return
4004       end
4005 C-----------------------------------------------------------------------------
4006       subroutine unormderiv(u,ugrad,unorm,ungrad)
4007 C This subroutine computes the derivatives of a normalized vector u, given
4008 C the derivatives computed without normalization conditions, ugrad. Returns
4009 C ungrad.
4010       implicit none
4011       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4012       double precision vec(3)
4013       double precision scalar
4014       integer i,j
4015 c      write (2,*) 'ugrad',ugrad
4016 c      write (2,*) 'u',u
4017       do i=1,3
4018         vec(i)=scalar(ugrad(1,i),u(1))
4019       enddo
4020 c      write (2,*) 'vec',vec
4021       do i=1,3
4022         do j=1,3
4023           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4024         enddo
4025       enddo
4026 c      write (2,*) 'ungrad',ungrad
4027       return
4028       end
4029 C-----------------------------------------------------------------------------
4030       subroutine escp_soft_sphere(evdw2,evdw2_14)
4031 C
4032 C This subroutine calculates the excluded-volume interaction energy between
4033 C peptide-group centers and side chains and its gradient in virtual-bond and
4034 C side-chain vectors.
4035 C
4036       implicit real*8 (a-h,o-z)
4037       include 'DIMENSIONS'
4038       include 'COMMON.GEO'
4039       include 'COMMON.VAR'
4040       include 'COMMON.LOCAL'
4041       include 'COMMON.CHAIN'
4042       include 'COMMON.DERIV'
4043       include 'COMMON.INTERACT'
4044       include 'COMMON.FFIELD'
4045       include 'COMMON.IOUNITS'
4046       include 'COMMON.CONTROL'
4047       dimension ggg(3)
4048       evdw2=0.0D0
4049       evdw2_14=0.0d0
4050       r0_scp=4.5d0
4051 cd    print '(a)','Enter ESCP'
4052 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4053       do i=iatscp_s,iatscp_e
4054         iteli=itel(i)
4055         xi=0.5D0*(c(1,i)+c(1,i+1))
4056         yi=0.5D0*(c(2,i)+c(2,i+1))
4057         zi=0.5D0*(c(3,i)+c(3,i+1))
4058
4059         do iint=1,nscp_gr(i)
4060
4061         do j=iscpstart(i,iint),iscpend(i,iint)
4062           itypj=iabs(itype(j))
4063 C Uncomment following three lines for SC-p interactions
4064 c         xj=c(1,nres+j)-xi
4065 c         yj=c(2,nres+j)-yi
4066 c         zj=c(3,nres+j)-zi
4067 C Uncomment following three lines for Ca-p interactions
4068           xj=c(1,j)-xi
4069           yj=c(2,j)-yi
4070           zj=c(3,j)-zi
4071           rij=xj*xj+yj*yj+zj*zj
4072           r0ij=r0_scp
4073           r0ijsq=r0ij*r0ij
4074           if (rij.lt.r0ijsq) then
4075             evdwij=0.25d0*(rij-r0ijsq)**2
4076             fac=rij-r0ijsq
4077           else
4078             evdwij=0.0d0
4079             fac=0.0d0
4080           endif
4081           evdw2=evdw2+evdwij
4082 C
4083 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4084 C
4085           ggg(1)=xj*fac
4086           ggg(2)=yj*fac
4087           ggg(3)=zj*fac
4088 cgrad          if (j.lt.i) then
4089 cd          write (iout,*) 'j<i'
4090 C Uncomment following three lines for SC-p interactions
4091 c           do k=1,3
4092 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4093 c           enddo
4094 cgrad          else
4095 cd          write (iout,*) 'j>i'
4096 cgrad            do k=1,3
4097 cgrad              ggg(k)=-ggg(k)
4098 C Uncomment following line for SC-p interactions
4099 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4100 cgrad            enddo
4101 cgrad          endif
4102 cgrad          do k=1,3
4103 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4104 cgrad          enddo
4105 cgrad          kstart=min0(i+1,j)
4106 cgrad          kend=max0(i-1,j-1)
4107 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4108 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4109 cgrad          do k=kstart,kend
4110 cgrad            do l=1,3
4111 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4112 cgrad            enddo
4113 cgrad          enddo
4114           do k=1,3
4115             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4116             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4117           enddo
4118         enddo
4119
4120         enddo ! iint
4121       enddo ! i
4122       return
4123       end
4124 C-----------------------------------------------------------------------------
4125       subroutine escp(evdw2,evdw2_14)
4126 C
4127 C This subroutine calculates the excluded-volume interaction energy between
4128 C peptide-group centers and side chains and its gradient in virtual-bond and
4129 C side-chain vectors.
4130 C
4131       implicit real*8 (a-h,o-z)
4132       include 'DIMENSIONS'
4133       include 'COMMON.GEO'
4134       include 'COMMON.VAR'
4135       include 'COMMON.LOCAL'
4136       include 'COMMON.CHAIN'
4137       include 'COMMON.DERIV'
4138       include 'COMMON.INTERACT'
4139       include 'COMMON.FFIELD'
4140       include 'COMMON.IOUNITS'
4141       include 'COMMON.CONTROL'
4142       dimension ggg(3)
4143       evdw2=0.0D0
4144       evdw2_14=0.0d0
4145 cd    print '(a)','Enter ESCP'
4146 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4147       do i=iatscp_s,iatscp_e
4148         iteli=itel(i)
4149         xi=0.5D0*(c(1,i)+c(1,i+1))
4150         yi=0.5D0*(c(2,i)+c(2,i+1))
4151         zi=0.5D0*(c(3,i)+c(3,i+1))
4152
4153         do iint=1,nscp_gr(i)
4154
4155         do j=iscpstart(i,iint),iscpend(i,iint)
4156           itypj=iabs(itype(j))
4157 C Uncomment following three lines for SC-p interactions
4158 c         xj=c(1,nres+j)-xi
4159 c         yj=c(2,nres+j)-yi
4160 c         zj=c(3,nres+j)-zi
4161 C Uncomment following three lines for Ca-p interactions
4162           xj=c(1,j)-xi
4163           yj=c(2,j)-yi
4164           zj=c(3,j)-zi
4165           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4166           fac=rrij**expon2
4167           e1=fac*fac*aad(itypj,iteli)
4168           e2=fac*bad(itypj,iteli)
4169           if (iabs(j-i) .le. 2) then
4170             e1=scal14*e1
4171             e2=scal14*e2
4172             evdw2_14=evdw2_14+e1+e2
4173           endif
4174           evdwij=e1+e2
4175           evdw2=evdw2+evdwij
4176           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4177      &        'evdw2',i,j,evdwij
4178 C
4179 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4180 C
4181           fac=-(evdwij+e1)*rrij
4182           ggg(1)=xj*fac
4183           ggg(2)=yj*fac
4184           ggg(3)=zj*fac
4185 cgrad          if (j.lt.i) then
4186 cd          write (iout,*) 'j<i'
4187 C Uncomment following three lines for SC-p interactions
4188 c           do k=1,3
4189 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4190 c           enddo
4191 cgrad          else
4192 cd          write (iout,*) 'j>i'
4193 cgrad            do k=1,3
4194 cgrad              ggg(k)=-ggg(k)
4195 C Uncomment following line for SC-p interactions
4196 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4197 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4198 cgrad            enddo
4199 cgrad          endif
4200 cgrad          do k=1,3
4201 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4202 cgrad          enddo
4203 cgrad          kstart=min0(i+1,j)
4204 cgrad          kend=max0(i-1,j-1)
4205 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4206 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4207 cgrad          do k=kstart,kend
4208 cgrad            do l=1,3
4209 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4210 cgrad            enddo
4211 cgrad          enddo
4212           do k=1,3
4213             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4214             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4215           enddo
4216         enddo
4217
4218         enddo ! iint
4219       enddo ! i
4220       do i=1,nct
4221         do j=1,3
4222           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4223           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4224           gradx_scp(j,i)=expon*gradx_scp(j,i)
4225         enddo
4226       enddo
4227 C******************************************************************************
4228 C
4229 C                              N O T E !!!
4230 C
4231 C To save time the factor EXPON has been extracted from ALL components
4232 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4233 C use!
4234 C
4235 C******************************************************************************
4236       return
4237       end
4238 C--------------------------------------------------------------------------
4239       subroutine edis(ehpb)
4240 C
4241 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4242 C
4243       implicit real*8 (a-h,o-z)
4244       include 'DIMENSIONS'
4245       include 'COMMON.SBRIDGE'
4246       include 'COMMON.CHAIN'
4247       include 'COMMON.DERIV'
4248       include 'COMMON.VAR'
4249       include 'COMMON.INTERACT'
4250       include 'COMMON.IOUNITS'
4251       dimension ggg(3)
4252       ehpb=0.0D0
4253 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4254 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4255       if (link_end.eq.0) return
4256       do i=link_start,link_end
4257 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4258 C CA-CA distance used in regularization of structure.
4259         ii=ihpb(i)
4260         jj=jhpb(i)
4261 C iii and jjj point to the residues for which the distance is assigned.
4262         if (ii.gt.nres) then
4263           iii=ii-nres
4264           jjj=jj-nres
4265         else
4266           iii=ii
4267           jjj=jj
4268         endif
4269 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4270 c     &    dhpb(i),dhpb1(i),forcon(i)
4271 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4272 C    distance and angle dependent SS bond potential.
4273         if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and. iabs(itype(jjj
4274      &)).eq.1) then
4275           call ssbond_ene(iii,jjj,eij)
4276           ehpb=ehpb+2*eij
4277 cd          write (iout,*) "eij",eij
4278         else if (ii.gt.nres .and. jj.gt.nres) then
4279 c Restraints from contact prediction
4280           dd=dist(ii,jj)
4281           if (dhpb1(i).gt.0.0d0) then
4282             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4283             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4284 c            write (iout,*) "beta nmr",
4285 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4286           else
4287             dd=dist(ii,jj)
4288             rdis=dd-dhpb(i)
4289 C Get the force constant corresponding to this distance.
4290             waga=forcon(i)
4291 C Calculate the contribution to energy.
4292             ehpb=ehpb+waga*rdis*rdis
4293 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
4294 C
4295 C Evaluate gradient.
4296 C
4297             fac=waga*rdis/dd
4298           endif
4299           do j=1,3
4300             ggg(j)=fac*(c(j,jj)-c(j,ii))
4301           enddo
4302           do j=1,3
4303             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4304             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4305           enddo
4306           do k=1,3
4307             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4308             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4309           enddo
4310         else
4311 C Calculate the distance between the two points and its difference from the
4312 C target distance.
4313           dd=dist(ii,jj)
4314           if (dhpb1(i).gt.0.0d0) then
4315             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4316             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4317 c            write (iout,*) "alph nmr",
4318 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4319           else
4320             rdis=dd-dhpb(i)
4321 C Get the force constant corresponding to this distance.
4322             waga=forcon(i)
4323 C Calculate the contribution to energy.
4324             ehpb=ehpb+waga*rdis*rdis
4325 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
4326 C
4327 C Evaluate gradient.
4328 C
4329             fac=waga*rdis/dd
4330           endif
4331 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4332 cd   &   ' waga=',waga,' fac=',fac
4333             do j=1,3
4334               ggg(j)=fac*(c(j,jj)-c(j,ii))
4335             enddo
4336 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4337 C If this is a SC-SC distance, we need to calculate the contributions to the
4338 C Cartesian gradient in the SC vectors (ghpbx).
4339           if (iii.lt.ii) then
4340           do j=1,3
4341             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4342             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4343           enddo
4344           endif
4345 cgrad        do j=iii,jjj-1
4346 cgrad          do k=1,3
4347 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4348 cgrad          enddo
4349 cgrad        enddo
4350           do k=1,3
4351             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4352             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4353           enddo
4354         endif
4355       enddo
4356       ehpb=0.5D0*ehpb
4357       return
4358       end
4359 C--------------------------------------------------------------------------
4360       subroutine ssbond_ene(i,j,eij)
4361 C
4362 C Calculate the distance and angle dependent SS-bond potential energy
4363 C using a free-energy function derived based on RHF/6-31G** ab initio
4364 C calculations of diethyl disulfide.
4365 C
4366 C A. Liwo and U. Kozlowska, 11/24/03
4367 C
4368       implicit real*8 (a-h,o-z)
4369       include 'DIMENSIONS'
4370       include 'COMMON.SBRIDGE'
4371       include 'COMMON.CHAIN'
4372       include 'COMMON.DERIV'
4373       include 'COMMON.LOCAL'
4374       include 'COMMON.INTERACT'
4375       include 'COMMON.VAR'
4376       include 'COMMON.IOUNITS'
4377       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4378       itypi=iabs(itype(i))
4379       xi=c(1,nres+i)
4380       yi=c(2,nres+i)
4381       zi=c(3,nres+i)
4382       dxi=dc_norm(1,nres+i)
4383       dyi=dc_norm(2,nres+i)
4384       dzi=dc_norm(3,nres+i)
4385 c      dsci_inv=dsc_inv(itypi)
4386       dsci_inv=vbld_inv(nres+i)
4387       itypj=iabs(itype(j))
4388 c      dscj_inv=dsc_inv(itypj)
4389       dscj_inv=vbld_inv(nres+j)
4390       xj=c(1,nres+j)-xi
4391       yj=c(2,nres+j)-yi
4392       zj=c(3,nres+j)-zi
4393       dxj=dc_norm(1,nres+j)
4394       dyj=dc_norm(2,nres+j)
4395       dzj=dc_norm(3,nres+j)
4396       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4397       rij=dsqrt(rrij)
4398       erij(1)=xj*rij
4399       erij(2)=yj*rij
4400       erij(3)=zj*rij
4401       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4402       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4403       om12=dxi*dxj+dyi*dyj+dzi*dzj
4404       do k=1,3
4405         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4406         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4407       enddo
4408       rij=1.0d0/rij
4409       deltad=rij-d0cm
4410       deltat1=1.0d0-om1
4411       deltat2=1.0d0+om2
4412       deltat12=om2-om1+2.0d0
4413       cosphi=om12-om1*om2
4414       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4415      &  +akct*deltad*deltat12
4416      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4417 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4418 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4419 c     &  " deltat12",deltat12," eij",eij
4420       ed=2*akcm*deltad+akct*deltat12
4421       pom1=akct*deltad
4422       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4423       eom1=-2*akth*deltat1-pom1-om2*pom2
4424       eom2= 2*akth*deltat2+pom1-om1*pom2
4425       eom12=pom2
4426       do k=1,3
4427         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4428         ghpbx(k,i)=ghpbx(k,i)-ggk
4429      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4430      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4431         ghpbx(k,j)=ghpbx(k,j)+ggk
4432      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4433      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4434         ghpbc(k,i)=ghpbc(k,i)-ggk
4435         ghpbc(k,j)=ghpbc(k,j)+ggk
4436       enddo
4437 C
4438 C Calculate the components of the gradient in DC and X
4439 C
4440 cgrad      do k=i,j-1
4441 cgrad        do l=1,3
4442 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4443 cgrad        enddo
4444 cgrad      enddo
4445       return
4446       end
4447 C--------------------------------------------------------------------------
4448       subroutine ebond(estr)
4449 c
4450 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4451 c
4452       implicit real*8 (a-h,o-z)
4453       include 'DIMENSIONS'
4454       include 'COMMON.LOCAL'
4455       include 'COMMON.GEO'
4456       include 'COMMON.INTERACT'
4457       include 'COMMON.DERIV'
4458       include 'COMMON.VAR'
4459       include 'COMMON.CHAIN'
4460       include 'COMMON.IOUNITS'
4461       include 'COMMON.NAMES'
4462       include 'COMMON.FFIELD'
4463       include 'COMMON.CONTROL'
4464       include 'COMMON.SETUP'
4465       double precision u(3),ud(3)
4466       estr=0.0d0
4467       do i=ibondp_start,ibondp_end
4468         diff = vbld(i)-vbldp0
4469 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4470         estr=estr+diff*diff
4471         do j=1,3
4472           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4473         enddo
4474 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4475       enddo
4476       estr=0.5d0*AKP*estr
4477 c
4478 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4479 c
4480       do i=ibond_start,ibond_end
4481         iti=iabs(itype(i))
4482         if (iti.ne.10) then
4483           nbi=nbondterm(iti)
4484           if (nbi.eq.1) then
4485             diff=vbld(i+nres)-vbldsc0(1,iti)
4486 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4487 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4488             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4489             do j=1,3
4490               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4491             enddo
4492           else
4493             do j=1,nbi
4494               diff=vbld(i+nres)-vbldsc0(j,iti)
4495               ud(j)=aksc(j,iti)*diff
4496               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4497             enddo
4498             uprod=u(1)
4499             do j=2,nbi
4500               uprod=uprod*u(j)
4501             enddo
4502             usum=0.0d0
4503             usumsqder=0.0d0
4504             do j=1,nbi
4505               uprod1=1.0d0
4506               uprod2=1.0d0
4507               do k=1,nbi
4508                 if (k.ne.j) then
4509                   uprod1=uprod1*u(k)
4510                   uprod2=uprod2*u(k)*u(k)
4511                 endif
4512               enddo
4513               usum=usum+uprod1
4514               usumsqder=usumsqder+ud(j)*uprod2
4515             enddo
4516             estr=estr+uprod/usum
4517             do j=1,3
4518              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4519             enddo
4520           endif
4521         endif
4522       enddo
4523       return
4524       end
4525 #ifdef CRYST_THETA
4526 C--------------------------------------------------------------------------
4527       subroutine ebend(etheta)
4528 C
4529 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4530 C angles gamma and its derivatives in consecutive thetas and gammas.
4531 C
4532       implicit real*8 (a-h,o-z)
4533       include 'DIMENSIONS'
4534       include 'COMMON.LOCAL'
4535       include 'COMMON.GEO'
4536       include 'COMMON.INTERACT'
4537       include 'COMMON.DERIV'
4538       include 'COMMON.VAR'
4539       include 'COMMON.CHAIN'
4540       include 'COMMON.IOUNITS'
4541       include 'COMMON.NAMES'
4542       include 'COMMON.FFIELD'
4543       include 'COMMON.CONTROL'
4544       common /calcthet/ term1,term2,termm,diffak,ratak,
4545      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4546      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4547       double precision y(2),z(2)
4548       delta=0.02d0*pi
4549 c      time11=dexp(-2*time)
4550 c      time12=1.0d0
4551       etheta=0.0D0
4552 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4553       do i=ithet_start,ithet_end
4554 C Zero the energy function and its derivative at 0 or pi.
4555         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4556         it=iabs(itype(i-1))
4557         if (i.gt.3) then
4558 #ifdef OSF
4559           phii=phi(i)
4560           if (phii.ne.phii) phii=150.0
4561 #else
4562           phii=phi(i)
4563 #endif
4564           y(1)=dcos(phii)
4565           y(2)=dsin(phii)
4566         else
4567           y(1)=0.0D0
4568           y(2)=0.0D0
4569         endif
4570         if (i.lt.nres) then
4571 #ifdef OSF
4572           phii1=phi(i+1)
4573           if (phii1.ne.phii1) phii1=150.0
4574           phii1=pinorm(phii1)
4575           z(1)=cos(phii1)
4576 #else
4577           phii1=phi(i+1)
4578           z(1)=dcos(phii1)
4579 #endif
4580           z(2)=dsin(phii1)
4581         else
4582           z(1)=0.0D0
4583           z(2)=0.0D0
4584         endif
4585 C Calculate the "mean" value of theta from the part of the distribution
4586 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4587 C In following comments this theta will be referred to as t_c.
4588         thet_pred_mean=0.0d0
4589         do k=1,2
4590           athetk=athet(k,it)
4591           bthetk=bthet(k,it)
4592           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4593         enddo
4594         dthett=thet_pred_mean*ssd
4595         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4596 C Derivatives of the "mean" values in gamma1 and gamma2.
4597         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
4598         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
4599         if (theta(i).gt.pi-delta) then
4600           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4601      &         E_tc0)
4602           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4603           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4604           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4605      &        E_theta)
4606           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4607      &        E_tc)
4608         else if (theta(i).lt.delta) then
4609           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4610           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4611           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4612      &        E_theta)
4613           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4614           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4615      &        E_tc)
4616         else
4617           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4618      &        E_theta,E_tc)
4619         endif
4620         etheta=etheta+ethetai
4621         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4622      &      'ebend',i,ethetai
4623         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4624         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4625         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4626       enddo
4627 C Ufff.... We've done all this!!!
4628       return
4629       end
4630 C---------------------------------------------------------------------------
4631       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4632      &     E_tc)
4633       implicit real*8 (a-h,o-z)
4634       include 'DIMENSIONS'
4635       include 'COMMON.LOCAL'
4636       include 'COMMON.IOUNITS'
4637       common /calcthet/ term1,term2,termm,diffak,ratak,
4638      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4639      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4640 C Calculate the contributions to both Gaussian lobes.
4641 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4642 C The "polynomial part" of the "standard deviation" of this part of
4643 C the distribution.
4644         sig=polthet(3,it)
4645         do j=2,0,-1
4646           sig=sig*thet_pred_mean+polthet(j,it)
4647         enddo
4648 C Derivative of the "interior part" of the "standard deviation of the"
4649 C gamma-dependent Gaussian lobe in t_c.
4650         sigtc=3*polthet(3,it)
4651         do j=2,1,-1
4652           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4653         enddo
4654         sigtc=sig*sigtc
4655 C Set the parameters of both Gaussian lobes of the distribution.
4656 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4657         fac=sig*sig+sigc0(it)
4658         sigcsq=fac+fac
4659         sigc=1.0D0/sigcsq
4660 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4661         sigsqtc=-4.0D0*sigcsq*sigtc
4662 c       print *,i,sig,sigtc,sigsqtc
4663 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4664         sigtc=-sigtc/(fac*fac)
4665 C Following variable is sigma(t_c)**(-2)
4666         sigcsq=sigcsq*sigcsq
4667         sig0i=sig0(it)
4668         sig0inv=1.0D0/sig0i**2
4669         delthec=thetai-thet_pred_mean
4670         delthe0=thetai-theta0i
4671         term1=-0.5D0*sigcsq*delthec*delthec
4672         term2=-0.5D0*sig0inv*delthe0*delthe0
4673 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4674 C NaNs in taking the logarithm. We extract the largest exponent which is added
4675 C to the energy (this being the log of the distribution) at the end of energy
4676 C term evaluation for this virtual-bond angle.
4677         if (term1.gt.term2) then
4678           termm=term1
4679           term2=dexp(term2-termm)
4680           term1=1.0d0
4681         else
4682           termm=term2
4683           term1=dexp(term1-termm)
4684           term2=1.0d0
4685         endif
4686 C The ratio between the gamma-independent and gamma-dependent lobes of
4687 C the distribution is a Gaussian function of thet_pred_mean too.
4688         diffak=gthet(2,it)-thet_pred_mean
4689         ratak=diffak/gthet(3,it)**2
4690         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4691 C Let's differentiate it in thet_pred_mean NOW.
4692         aktc=ak*ratak
4693 C Now put together the distribution terms to make complete distribution.
4694         termexp=term1+ak*term2
4695         termpre=sigc+ak*sig0i
4696 C Contribution of the bending energy from this theta is just the -log of
4697 C the sum of the contributions from the two lobes and the pre-exponential
4698 C factor. Simple enough, isn't it?
4699         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4700 C NOW the derivatives!!!
4701 C 6/6/97 Take into account the deformation.
4702         E_theta=(delthec*sigcsq*term1
4703      &       +ak*delthe0*sig0inv*term2)/termexp
4704         E_tc=((sigtc+aktc*sig0i)/termpre
4705      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4706      &       aktc*term2)/termexp)
4707       return
4708       end
4709 c-----------------------------------------------------------------------------
4710       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4711       implicit real*8 (a-h,o-z)
4712       include 'DIMENSIONS'
4713       include 'COMMON.LOCAL'
4714       include 'COMMON.IOUNITS'
4715       common /calcthet/ term1,term2,termm,diffak,ratak,
4716      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4717      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4718       delthec=thetai-thet_pred_mean
4719       delthe0=thetai-theta0i
4720 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4721       t3 = thetai-thet_pred_mean
4722       t6 = t3**2
4723       t9 = term1
4724       t12 = t3*sigcsq
4725       t14 = t12+t6*sigsqtc
4726       t16 = 1.0d0
4727       t21 = thetai-theta0i
4728       t23 = t21**2
4729       t26 = term2
4730       t27 = t21*t26
4731       t32 = termexp
4732       t40 = t32**2
4733       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4734      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4735      & *(-t12*t9-ak*sig0inv*t27)
4736       return
4737       end
4738 #else
4739 C--------------------------------------------------------------------------
4740       subroutine ebend(etheta)
4741 C
4742 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4743 C angles gamma and its derivatives in consecutive thetas and gammas.
4744 C ab initio-derived potentials from
4745 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4746 C
4747       implicit real*8 (a-h,o-z)
4748       include 'DIMENSIONS'
4749       include 'COMMON.LOCAL'
4750       include 'COMMON.GEO'
4751       include 'COMMON.INTERACT'
4752       include 'COMMON.DERIV'
4753       include 'COMMON.VAR'
4754       include 'COMMON.CHAIN'
4755       include 'COMMON.IOUNITS'
4756       include 'COMMON.NAMES'
4757       include 'COMMON.FFIELD'
4758       include 'COMMON.CONTROL'
4759       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4760      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4761      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4762      & sinph1ph2(maxdouble,maxdouble)
4763       logical lprn /.false./, lprn1 /.false./
4764       etheta=0.0D0
4765       do i=ithet_start,ithet_end
4766         dethetai=0.0d0
4767         dephii=0.0d0
4768         dephii1=0.0d0
4769         theti2=0.5d0*theta(i)
4770         ityp2=ithetyp(iabs(itype(i-1)))
4771         do k=1,nntheterm
4772           coskt(k)=dcos(k*theti2)
4773           sinkt(k)=dsin(k*theti2)
4774         enddo
4775         if (i.gt.3) then
4776 #ifdef OSF
4777           phii=phi(i)
4778           if (phii.ne.phii) phii=150.0
4779 #else
4780           phii=phi(i)
4781 #endif
4782           ityp1=ithetyp(iabs(itype(i-2)))
4783           do k=1,nsingle
4784             cosph1(k)=dcos(k*phii)
4785             sinph1(k)=dsin(k*phii)
4786           enddo
4787         else
4788           phii=0.0d0
4789           ityp1=nthetyp+1
4790           do k=1,nsingle
4791             cosph1(k)=0.0d0
4792             sinph1(k)=0.0d0
4793           enddo
4794         endif
4795         if (i.lt.nres) then
4796 #ifdef OSF
4797           phii1=phi(i+1)
4798           if (phii1.ne.phii1) phii1=150.0
4799           phii1=pinorm(phii1)
4800 #else
4801           phii1=phi(i+1)
4802 #endif
4803           ityp3=ithetyp(iabs(itype(i)))
4804           do k=1,nsingle
4805             cosph2(k)=dcos(k*phii1)
4806             sinph2(k)=dsin(k*phii1)
4807           enddo
4808         else
4809           phii1=0.0d0
4810           ityp3=nthetyp+1
4811           do k=1,nsingle
4812             cosph2(k)=0.0d0
4813             sinph2(k)=0.0d0
4814           enddo
4815         endif
4816         ethetai=aa0thet(ityp1,ityp2,ityp3)
4817         do k=1,ndouble
4818           do l=1,k-1
4819             ccl=cosph1(l)*cosph2(k-l)
4820             ssl=sinph1(l)*sinph2(k-l)
4821             scl=sinph1(l)*cosph2(k-l)
4822             csl=cosph1(l)*sinph2(k-l)
4823             cosph1ph2(l,k)=ccl-ssl
4824             cosph1ph2(k,l)=ccl+ssl
4825             sinph1ph2(l,k)=scl+csl
4826             sinph1ph2(k,l)=scl-csl
4827           enddo
4828         enddo
4829         if (lprn) then
4830         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4831      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4832         write (iout,*) "coskt and sinkt"
4833         do k=1,nntheterm
4834           write (iout,*) k,coskt(k),sinkt(k)
4835         enddo
4836         endif
4837         do k=1,ntheterm
4838           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4839           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4840      &      *coskt(k)
4841           if (lprn)
4842      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4843      &     " ethetai",ethetai
4844         enddo
4845         if (lprn) then
4846         write (iout,*) "cosph and sinph"
4847         do k=1,nsingle
4848           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4849         enddo
4850         write (iout,*) "cosph1ph2 and sinph2ph2"
4851         do k=2,ndouble
4852           do l=1,k-1
4853             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4854      &         sinph1ph2(l,k),sinph1ph2(k,l)
4855           enddo
4856         enddo
4857         write(iout,*) "ethetai",ethetai
4858         endif
4859         do m=1,ntheterm2
4860           do k=1,nsingle
4861             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4862      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4863      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4864      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4865             ethetai=ethetai+sinkt(m)*aux
4866             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4867             dephii=dephii+k*sinkt(m)*(
4868      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4869      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4870             dephii1=dephii1+k*sinkt(m)*(
4871      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4872      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4873             if (lprn)
4874      &      write (iout,*) "m",m," k",k," bbthet",
4875      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4876      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4877      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4878      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4879           enddo
4880         enddo
4881         if (lprn)
4882      &  write(iout,*) "ethetai",ethetai
4883         do m=1,ntheterm3
4884           do k=2,ndouble
4885             do l=1,k-1
4886               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4887      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4888      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4889      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4890               ethetai=ethetai+sinkt(m)*aux
4891               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4892               dephii=dephii+l*sinkt(m)*(
4893      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4894      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4895      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4896      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4897               dephii1=dephii1+(k-l)*sinkt(m)*(
4898      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4899      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4900      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
4901      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4902               if (lprn) then
4903               write (iout,*) "m",m," k",k," l",l," ffthet",
4904      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
4905      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
4906      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
4907      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4908               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4909      &            cosph1ph2(k,l)*sinkt(m),
4910      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4911               endif
4912             enddo
4913           enddo
4914         enddo
4915 10      continue
4916         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4917      &   i,theta(i)*rad2deg,phii*rad2deg,
4918      &   phii1*rad2deg,ethetai
4919         etheta=etheta+ethetai
4920         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4921         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4922         gloc(nphi+i-2,icg)=wang*dethetai
4923       enddo
4924       return
4925       end
4926 #endif
4927 #ifdef CRYST_SC
4928 c-----------------------------------------------------------------------------
4929       subroutine esc(escloc)
4930 C Calculate the local energy of a side chain and its derivatives in the
4931 C corresponding virtual-bond valence angles THETA and the spherical angles
4932 C ALPHA and OMEGA.
4933       implicit real*8 (a-h,o-z)
4934       include 'DIMENSIONS'
4935       include 'COMMON.GEO'
4936       include 'COMMON.LOCAL'
4937       include 'COMMON.VAR'
4938       include 'COMMON.INTERACT'
4939       include 'COMMON.DERIV'
4940       include 'COMMON.CHAIN'
4941       include 'COMMON.IOUNITS'
4942       include 'COMMON.NAMES'
4943       include 'COMMON.FFIELD'
4944       include 'COMMON.CONTROL'
4945       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4946      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4947       common /sccalc/ time11,time12,time112,theti,it,nlobit
4948       delta=0.02d0*pi
4949       escloc=0.0D0
4950 c     write (iout,'(a)') 'ESC'
4951       do i=loc_start,loc_end
4952         it=itype(i)
4953         if (it.eq.10) goto 1
4954         nlobit=nlob(iabs(it))
4955 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4956 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4957         theti=theta(i+1)-pipol
4958         x(1)=dtan(theti)
4959         x(2)=alph(i)
4960         x(3)=omeg(i)
4961
4962         if (x(2).gt.pi-delta) then
4963           xtemp(1)=x(1)
4964           xtemp(2)=pi-delta
4965           xtemp(3)=x(3)
4966           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4967           xtemp(2)=pi
4968           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4969           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4970      &        escloci,dersc(2))
4971           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4972      &        ddersc0(1),dersc(1))
4973           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4974      &        ddersc0(3),dersc(3))
4975           xtemp(2)=pi-delta
4976           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4977           xtemp(2)=pi
4978           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4979           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4980      &            dersc0(2),esclocbi,dersc02)
4981           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4982      &            dersc12,dersc01)
4983           call splinthet(x(2),0.5d0*delta,ss,ssd)
4984           dersc0(1)=dersc01
4985           dersc0(2)=dersc02
4986           dersc0(3)=0.0d0
4987           do k=1,3
4988             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4989           enddo
4990           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4991 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4992 c    &             esclocbi,ss,ssd
4993           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4994 c         escloci=esclocbi
4995 c         write (iout,*) escloci
4996         else if (x(2).lt.delta) then
4997           xtemp(1)=x(1)
4998           xtemp(2)=delta
4999           xtemp(3)=x(3)
5000           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5001           xtemp(2)=0.0d0
5002           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5003           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5004      &        escloci,dersc(2))
5005           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5006      &        ddersc0(1),dersc(1))
5007           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5008      &        ddersc0(3),dersc(3))
5009           xtemp(2)=delta
5010           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5011           xtemp(2)=0.0d0
5012           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5013           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5014      &            dersc0(2),esclocbi,dersc02)
5015           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5016      &            dersc12,dersc01)
5017           dersc0(1)=dersc01
5018           dersc0(2)=dersc02
5019           dersc0(3)=0.0d0
5020           call splinthet(x(2),0.5d0*delta,ss,ssd)
5021           do k=1,3
5022             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5023           enddo
5024           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5025 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5026 c    &             esclocbi,ss,ssd
5027           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5028 c         write (iout,*) escloci
5029         else
5030           call enesc(x,escloci,dersc,ddummy,.false.)
5031         endif
5032
5033         escloc=escloc+escloci
5034         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5035      &     'escloc',i,escloci
5036 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5037
5038         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5039      &   wscloc*dersc(1)
5040         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5041         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5042     1   continue
5043       enddo
5044       return
5045       end
5046 C---------------------------------------------------------------------------
5047       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5048       implicit real*8 (a-h,o-z)
5049       include 'DIMENSIONS'
5050       include 'COMMON.GEO'
5051       include 'COMMON.LOCAL'
5052       include 'COMMON.IOUNITS'
5053       common /sccalc/ time11,time12,time112,theti,it,nlobit
5054       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5055       double precision contr(maxlob,-1:1)
5056       logical mixed
5057 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5058         escloc_i=0.0D0
5059         do j=1,3
5060           dersc(j)=0.0D0
5061           if (mixed) ddersc(j)=0.0d0
5062         enddo
5063         x3=x(3)
5064
5065 C Because of periodicity of the dependence of the SC energy in omega we have
5066 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5067 C To avoid underflows, first compute & store the exponents.
5068
5069         do iii=-1,1
5070
5071           x(3)=x3+iii*dwapi
5072
5073           do j=1,nlobit
5074             do k=1,3
5075               z(k)=x(k)-censc(k,j,it)
5076             enddo
5077             do k=1,3
5078               Axk=0.0D0
5079               do l=1,3
5080                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5081               enddo
5082               Ax(k,j,iii)=Axk
5083             enddo
5084             expfac=0.0D0
5085             do k=1,3
5086               expfac=expfac+Ax(k,j,iii)*z(k)
5087             enddo
5088             contr(j,iii)=expfac
5089           enddo ! j
5090
5091         enddo ! iii
5092
5093         x(3)=x3
5094 C As in the case of ebend, we want to avoid underflows in exponentiation and
5095 C subsequent NaNs and INFs in energy calculation.
5096 C Find the largest exponent
5097         emin=contr(1,-1)
5098         do iii=-1,1
5099           do j=1,nlobit
5100             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5101           enddo
5102         enddo
5103         emin=0.5D0*emin
5104 cd      print *,'it=',it,' emin=',emin
5105
5106 C Compute the contribution to SC energy and derivatives
5107         do iii=-1,1
5108
5109           do j=1,nlobit
5110 #ifdef OSF
5111             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
5112             if(adexp.ne.adexp) adexp=1.0
5113             expfac=dexp(adexp)
5114 #else
5115             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5116 #endif
5117 cd          print *,'j=',j,' expfac=',expfac
5118             escloc_i=escloc_i+expfac
5119             do k=1,3
5120               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5121             enddo
5122             if (mixed) then
5123               do k=1,3,2
5124                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5125      &            +gaussc(k,2,j,it))*expfac
5126               enddo
5127             endif
5128           enddo
5129
5130         enddo ! iii
5131
5132         dersc(1)=dersc(1)/cos(theti)**2
5133         ddersc(1)=ddersc(1)/cos(theti)**2
5134         ddersc(3)=ddersc(3)
5135
5136         escloci=-(dlog(escloc_i)-emin)
5137         do j=1,3
5138           dersc(j)=dersc(j)/escloc_i
5139         enddo
5140         if (mixed) then
5141           do j=1,3,2
5142             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5143           enddo
5144         endif
5145       return
5146       end
5147 C------------------------------------------------------------------------------
5148       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5149       implicit real*8 (a-h,o-z)
5150       include 'DIMENSIONS'
5151       include 'COMMON.GEO'
5152       include 'COMMON.LOCAL'
5153       include 'COMMON.IOUNITS'
5154       common /sccalc/ time11,time12,time112,theti,it,nlobit
5155       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5156       double precision contr(maxlob)
5157       logical mixed
5158
5159       escloc_i=0.0D0
5160
5161       do j=1,3
5162         dersc(j)=0.0D0
5163       enddo
5164
5165       do j=1,nlobit
5166         do k=1,2
5167           z(k)=x(k)-censc(k,j,it)
5168         enddo
5169         z(3)=dwapi
5170         do k=1,3
5171           Axk=0.0D0
5172           do l=1,3
5173             Axk=Axk+gaussc(l,k,j,it)*z(l)
5174           enddo
5175           Ax(k,j)=Axk
5176         enddo
5177         expfac=0.0D0
5178         do k=1,3
5179           expfac=expfac+Ax(k,j)*z(k)
5180         enddo
5181         contr(j)=expfac
5182       enddo ! j
5183
5184 C As in the case of ebend, we want to avoid underflows in exponentiation and
5185 C subsequent NaNs and INFs in energy calculation.
5186 C Find the largest exponent
5187       emin=contr(1)
5188       do j=1,nlobit
5189         if (emin.gt.contr(j)) emin=contr(j)
5190       enddo
5191       emin=0.5D0*emin
5192
5193 C Compute the contribution to SC energy and derivatives
5194
5195       dersc12=0.0d0
5196       do j=1,nlobit
5197         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5198         escloc_i=escloc_i+expfac
5199         do k=1,2
5200           dersc(k)=dersc(k)+Ax(k,j)*expfac
5201         enddo
5202         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5203      &            +gaussc(1,2,j,it))*expfac
5204         dersc(3)=0.0d0
5205       enddo
5206
5207       dersc(1)=dersc(1)/cos(theti)**2
5208       dersc12=dersc12/cos(theti)**2
5209       escloci=-(dlog(escloc_i)-emin)
5210       do j=1,2
5211         dersc(j)=dersc(j)/escloc_i
5212       enddo
5213       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5214       return
5215       end
5216 #else
5217 c----------------------------------------------------------------------------------
5218       subroutine esc(escloc)
5219 C Calculate the local energy of a side chain and its derivatives in the
5220 C corresponding virtual-bond valence angles THETA and the spherical angles
5221 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5222 C added by Urszula Kozlowska. 07/11/2007
5223 C
5224       implicit real*8 (a-h,o-z)
5225       include 'DIMENSIONS'
5226       include 'COMMON.GEO'
5227       include 'COMMON.LOCAL'
5228       include 'COMMON.VAR'
5229       include 'COMMON.SCROT'
5230       include 'COMMON.INTERACT'
5231       include 'COMMON.DERIV'
5232       include 'COMMON.CHAIN'
5233       include 'COMMON.IOUNITS'
5234       include 'COMMON.NAMES'
5235       include 'COMMON.FFIELD'
5236       include 'COMMON.CONTROL'
5237       include 'COMMON.VECTORS'
5238       double precision x_prime(3),y_prime(3),z_prime(3)
5239      &    , sumene,dsc_i,dp2_i,x(65),
5240      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5241      &    de_dxx,de_dyy,de_dzz,de_dt
5242       double precision s1_t,s1_6_t,s2_t,s2_6_t
5243       double precision
5244      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5245      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5246      & dt_dCi(3),dt_dCi1(3)
5247       common /sccalc/ time11,time12,time112,theti,it,nlobit
5248       delta=0.02d0*pi
5249       escloc=0.0D0
5250       do i=loc_start,loc_end
5251         costtab(i+1) =dcos(theta(i+1))
5252         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5253         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5254         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5255         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5256         cosfac=dsqrt(cosfac2)
5257         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5258         sinfac=dsqrt(sinfac2)
5259         it=itype(i)
5260         if (it.eq.10) goto 1
5261 c
5262 C  Compute the axes of tghe local cartesian coordinates system; store in
5263 c   x_prime, y_prime and z_prime
5264 c
5265         do j=1,3
5266           x_prime(j) = 0.00
5267           y_prime(j) = 0.00
5268           z_prime(j) = 0.00
5269         enddo
5270 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5271 C     &   dc_norm(3,i+nres)
5272         do j = 1,3
5273           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5274           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5275         enddo
5276         do j = 1,3
5277           z_prime(j) = -uz(j,i-1)
5278         enddo
5279 c       write (2,*) "i",i
5280 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5281 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5282 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5283 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5284 c      & " xy",scalar(x_prime(1),y_prime(1)),
5285 c      & " xz",scalar(x_prime(1),z_prime(1)),
5286 c      & " yy",scalar(y_prime(1),y_prime(1)),
5287 c      & " yz",scalar(y_prime(1),z_prime(1)),
5288 c      & " zz",scalar(z_prime(1),z_prime(1))
5289 c
5290 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5291 C to local coordinate system. Store in xx, yy, zz.
5292 c
5293         xx=0.0d0
5294         yy=0.0d0
5295         zz=0.0d0
5296         do j = 1,3
5297           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5298           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5299           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5300         enddo
5301
5302         xxtab(i)=xx
5303         yytab(i)=yy
5304         zztab(i)=zz
5305 C
5306 C Compute the energy of the ith side cbain
5307 C
5308 c        write (2,*) "xx",xx," yy",yy," zz",zz
5309         it=itype(i)
5310         do j = 1,65
5311           x(j) = sc_parmin(j,it)
5312         enddo
5313 #ifdef CHECK_COORD
5314 Cc diagnostics - remove later
5315         xx1 = dcos(alph(2))
5316         yy1 = dsin(alph(2))*dcos(omeg(2))
5317         zz1 = -dsin(alph(2))*dsin(omeg(2))
5318         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5319      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5320      &    xx1,yy1,zz1
5321 C,"  --- ", xx_w,yy_w,zz_w
5322 c end diagnostics
5323 #endif
5324         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5325      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5326      &   + x(10)*yy*zz
5327         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5328      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5329      & + x(20)*yy*zz
5330         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5331      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5332      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5333      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5334      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5335      &  +x(40)*xx*yy*zz
5336         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5337      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5338      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5339      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5340      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5341      &  +x(60)*xx*yy*zz
5342         dsc_i   = 0.743d0+x(61)
5343         dp2_i   = 1.9d0+x(62)
5344         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5345      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5346         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5347      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5348         s1=(1+x(63))/(0.1d0 + dscp1)
5349         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5350         s2=(1+x(65))/(0.1d0 + dscp2)
5351         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5352         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5353      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5354 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5355 c     &   sumene4,
5356 c     &   dscp1,dscp2,sumene
5357 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5358         escloc = escloc + sumene
5359 c        write (2,*) "i",i," escloc",sumene,escloc
5360 #ifdef DEBUG
5361 C
5362 C This section to check the numerical derivatives of the energy of ith side
5363 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5364 C #define DEBUG in the code to turn it on.
5365 C
5366         write (2,*) "sumene               =",sumene
5367         aincr=1.0d-7
5368         xxsave=xx
5369         xx=xx+aincr
5370         write (2,*) xx,yy,zz
5371         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5372         de_dxx_num=(sumenep-sumene)/aincr
5373         xx=xxsave
5374         write (2,*) "xx+ sumene from enesc=",sumenep
5375         yysave=yy
5376         yy=yy+aincr
5377         write (2,*) xx,yy,zz
5378         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5379         de_dyy_num=(sumenep-sumene)/aincr
5380         yy=yysave
5381         write (2,*) "yy+ sumene from enesc=",sumenep
5382         zzsave=zz
5383         zz=zz+aincr
5384         write (2,*) xx,yy,zz
5385         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5386         de_dzz_num=(sumenep-sumene)/aincr
5387         zz=zzsave
5388         write (2,*) "zz+ sumene from enesc=",sumenep
5389         costsave=cost2tab(i+1)
5390         sintsave=sint2tab(i+1)
5391         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5392         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5393         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5394         de_dt_num=(sumenep-sumene)/aincr
5395         write (2,*) " t+ sumene from enesc=",sumenep
5396         cost2tab(i+1)=costsave
5397         sint2tab(i+1)=sintsave
5398 C End of diagnostics section.
5399 #endif
5400 C
5401 C Compute the gradient of esc
5402 C
5403         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5404         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5405         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5406         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5407         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5408         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5409         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5410         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5411         pom1=(sumene3*sint2tab(i+1)+sumene1)
5412      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5413         pom2=(sumene4*cost2tab(i+1)+sumene2)
5414      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5415         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5416         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5417      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5418      &  +x(40)*yy*zz
5419         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5420         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5421      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5422      &  +x(60)*yy*zz
5423         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5424      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5425      &        +(pom1+pom2)*pom_dx
5426 #ifdef DEBUG
5427         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5428 #endif
5429 C
5430         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5431         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5432      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5433      &  +x(40)*xx*zz
5434         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5435         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5436      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5437      &  +x(59)*zz**2 +x(60)*xx*zz
5438         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5439      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5440      &        +(pom1-pom2)*pom_dy
5441 #ifdef DEBUG
5442         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5443 #endif
5444 C
5445         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5446      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5447      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5448      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5449      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5450      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5451      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5452      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5453 #ifdef DEBUG
5454         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5455 #endif
5456 C
5457         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5458      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5459      &  +pom1*pom_dt1+pom2*pom_dt2
5460 #ifdef DEBUG
5461         write(2,*), "de_dt = ", de_dt,de_dt_num
5462 #endif
5463 c
5464 C
5465        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5466        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5467        cosfac2xx=cosfac2*xx
5468        sinfac2yy=sinfac2*yy
5469        do k = 1,3
5470          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5471      &      vbld_inv(i+1)
5472          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5473      &      vbld_inv(i)
5474          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5475          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5476 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5477 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5478 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5479 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5480          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5481          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5482          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5483          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5484          dZZ_Ci1(k)=0.0d0
5485          dZZ_Ci(k)=0.0d0
5486          do j=1,3
5487            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5488            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5489          enddo
5490
5491          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5492          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5493          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5494 c
5495          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5496          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5497        enddo
5498
5499        do k=1,3
5500          dXX_Ctab(k,i)=dXX_Ci(k)
5501          dXX_C1tab(k,i)=dXX_Ci1(k)
5502          dYY_Ctab(k,i)=dYY_Ci(k)
5503          dYY_C1tab(k,i)=dYY_Ci1(k)
5504          dZZ_Ctab(k,i)=dZZ_Ci(k)
5505          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5506          dXX_XYZtab(k,i)=dXX_XYZ(k)
5507          dYY_XYZtab(k,i)=dYY_XYZ(k)
5508          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5509        enddo
5510
5511        do k = 1,3
5512 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5513 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5514 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5515 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5516 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5517 c     &    dt_dci(k)
5518 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5519 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5520          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5521      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5522          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5523      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5524          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5525      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5526        enddo
5527 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5528 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5529
5530 C to check gradient call subroutine check_grad
5531
5532     1 continue
5533       enddo
5534       return
5535       end
5536 c------------------------------------------------------------------------------
5537       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5538       implicit none
5539       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5540      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5541       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5542      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5543      &   + x(10)*yy*zz
5544       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5545      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5546      & + x(20)*yy*zz
5547       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5548      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5549      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5550      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5551      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5552      &  +x(40)*xx*yy*zz
5553       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5554      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5555      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5556      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5557      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5558      &  +x(60)*xx*yy*zz
5559       dsc_i   = 0.743d0+x(61)
5560       dp2_i   = 1.9d0+x(62)
5561       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5562      &          *(xx*cost2+yy*sint2))
5563       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5564      &          *(xx*cost2-yy*sint2))
5565       s1=(1+x(63))/(0.1d0 + dscp1)
5566       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5567       s2=(1+x(65))/(0.1d0 + dscp2)
5568       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5569       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5570      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5571       enesc=sumene
5572       return
5573       end
5574 #endif
5575 c------------------------------------------------------------------------------
5576       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5577 C
5578 C This procedure calculates two-body contact function g(rij) and its derivative:
5579 C
5580 C           eps0ij                                     !       x < -1
5581 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5582 C            0                                         !       x > 1
5583 C
5584 C where x=(rij-r0ij)/delta
5585 C
5586 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5587 C
5588       implicit none
5589       double precision rij,r0ij,eps0ij,fcont,fprimcont
5590       double precision x,x2,x4,delta
5591 c     delta=0.02D0*r0ij
5592 c      delta=0.2D0*r0ij
5593       x=(rij-r0ij)/delta
5594       if (x.lt.-1.0D0) then
5595         fcont=eps0ij
5596         fprimcont=0.0D0
5597       else if (x.le.1.0D0) then
5598         x2=x*x
5599         x4=x2*x2
5600         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5601         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5602       else
5603         fcont=0.0D0
5604         fprimcont=0.0D0
5605       endif
5606       return
5607       end
5608 c------------------------------------------------------------------------------
5609       subroutine splinthet(theti,delta,ss,ssder)
5610       implicit real*8 (a-h,o-z)
5611       include 'DIMENSIONS'
5612       include 'COMMON.VAR'
5613       include 'COMMON.GEO'
5614       thetup=pi-delta
5615       thetlow=delta
5616       if (theti.gt.pipol) then
5617         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5618       else
5619         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5620         ssder=-ssder
5621       endif
5622       return
5623       end
5624 c------------------------------------------------------------------------------
5625       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5626       implicit none
5627       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5628       double precision ksi,ksi2,ksi3,a1,a2,a3
5629       a1=fprim0*delta/(f1-f0)
5630       a2=3.0d0-2.0d0*a1
5631       a3=a1-2.0d0
5632       ksi=(x-x0)/delta
5633       ksi2=ksi*ksi
5634       ksi3=ksi2*ksi
5635       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5636       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5637       return
5638       end
5639 c------------------------------------------------------------------------------
5640       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5641       implicit none
5642       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5643       double precision ksi,ksi2,ksi3,a1,a2,a3
5644       ksi=(x-x0)/delta
5645       ksi2=ksi*ksi
5646       ksi3=ksi2*ksi
5647       a1=fprim0x*delta
5648       a2=3*(f1x-f0x)-2*fprim0x*delta
5649       a3=fprim0x*delta-2*(f1x-f0x)
5650       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5651       return
5652       end
5653 C-----------------------------------------------------------------------------
5654 #ifdef CRYST_TOR
5655 C-----------------------------------------------------------------------------
5656       subroutine etor(etors,edihcnstr)
5657       implicit real*8 (a-h,o-z)
5658       include 'DIMENSIONS'
5659       include 'COMMON.VAR'
5660       include 'COMMON.GEO'
5661       include 'COMMON.LOCAL'
5662       include 'COMMON.TORSION'
5663       include 'COMMON.INTERACT'
5664       include 'COMMON.DERIV'
5665       include 'COMMON.CHAIN'
5666       include 'COMMON.NAMES'
5667       include 'COMMON.IOUNITS'
5668       include 'COMMON.FFIELD'
5669       include 'COMMON.TORCNSTR'
5670       include 'COMMON.CONTROL'
5671       logical lprn
5672 C Set lprn=.true. for debugging
5673       lprn=.false.
5674 c      lprn=.true.
5675       etors=0.0D0
5676       do i=iphi_start,iphi_end
5677       etors_ii=0.0D0
5678         itori=itortyp(itype(i-2))
5679         itori1=itortyp(itype(i-1))
5680         phii=phi(i)
5681         gloci=0.0D0
5682 C Proline-Proline pair is a special case...
5683         if (itori.eq.3 .and. itori1.eq.3) then
5684           if (phii.gt.-dwapi3) then
5685             cosphi=dcos(3*phii)
5686             fac=1.0D0/(1.0D0-cosphi)
5687             etorsi=v1(1,3,3)*fac
5688             etorsi=etorsi+etorsi
5689             etors=etors+etorsi-v1(1,3,3)
5690             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5691             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5692           endif
5693           do j=1,3
5694             v1ij=v1(j+1,itori,itori1)
5695             v2ij=v2(j+1,itori,itori1)
5696             cosphi=dcos(j*phii)
5697             sinphi=dsin(j*phii)
5698             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5699             if (energy_dec) etors_ii=etors_ii+
5700      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5701             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5702           enddo
5703         else
5704           do j=1,nterm_old
5705             v1ij=v1(j,itori,itori1)
5706             v2ij=v2(j,itori,itori1)
5707             cosphi=dcos(j*phii)
5708             sinphi=dsin(j*phii)
5709             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5710             if (energy_dec) etors_ii=etors_ii+
5711      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5712             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5713           enddo
5714         endif
5715         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5716      &        'etor',i,etors_ii
5717         if (lprn)
5718      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5719      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5720      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5721         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5722         write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5723       enddo
5724 ! 6/20/98 - dihedral angle constraints
5725       edihcnstr=0.0d0
5726       do i=1,ndih_constr
5727         itori=idih_constr(i)
5728         phii=phi(itori)
5729         difi=phii-phi0(i)
5730         if (difi.gt.drange(i)) then
5731           difi=difi-drange(i)
5732           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5733           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5734         else if (difi.lt.-drange(i)) then
5735           difi=difi+drange(i)
5736           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5737           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5738         endif
5739 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5740 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5741       enddo
5742 !      write (iout,*) 'edihcnstr',edihcnstr
5743       return
5744       end
5745 c------------------------------------------------------------------------------
5746       subroutine etor_d(etors_d)
5747       etors_d=0.0d0
5748       return
5749       end
5750 c----------------------------------------------------------------------------
5751 #else
5752       subroutine etor(etors,edihcnstr)
5753       implicit real*8 (a-h,o-z)
5754       include 'DIMENSIONS'
5755       include 'COMMON.VAR'
5756       include 'COMMON.GEO'
5757       include 'COMMON.LOCAL'
5758       include 'COMMON.TORSION'
5759       include 'COMMON.INTERACT'
5760       include 'COMMON.DERIV'
5761       include 'COMMON.CHAIN'
5762       include 'COMMON.NAMES'
5763       include 'COMMON.IOUNITS'
5764       include 'COMMON.FFIELD'
5765       include 'COMMON.TORCNSTR'
5766       include 'COMMON.CONTROL'
5767       logical lprn
5768 C Set lprn=.true. for debugging
5769       lprn=.false.
5770 c     lprn=.true.
5771       etors=0.0D0
5772       do i=iphi_start,iphi_end
5773       etors_ii=0.0D0
5774         itori=itortyp(itype(i-2))
5775         itori1=itortyp(itype(i-1))
5776         if (iabs(itype(i)).eq.20) then
5777         iblock=2
5778         else
5779         iblock=1
5780         endif
5781         phii=phi(i)
5782         gloci=0.0D0
5783 C Regular cosine and sine terms
5784         do j=1,nterm(itori,itori1,iblock)
5785           v1ij=v1(j,itori,itori1,iblock)
5786           v2ij=v2(j,itori,itori1,iblock)
5787           cosphi=dcos(j*phii)
5788           sinphi=dsin(j*phii)
5789           etors=etors+v1ij*cosphi+v2ij*sinphi
5790           if (energy_dec) etors_ii=etors_ii+
5791      &                v1ij*cosphi+v2ij*sinphi
5792           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5793         enddo
5794 C Lorentz terms
5795 C                         v1
5796 C  E = SUM ----------------------------------- - v1
5797 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5798 C
5799         cosphi=dcos(0.5d0*phii)
5800         sinphi=dsin(0.5d0*phii)
5801         do j=1,nlor(itori,itori1,iblock)
5802           vl1ij=vlor1(j,itori,itori1)
5803           vl2ij=vlor2(j,itori,itori1)
5804           vl3ij=vlor3(j,itori,itori1)
5805           pom=vl2ij*cosphi+vl3ij*sinphi
5806           pom1=1.0d0/(pom*pom+1.0d0)
5807           etors=etors+vl1ij*pom1
5808           if (energy_dec) etors_ii=etors_ii+
5809      &                vl1ij*pom1
5810           pom=-pom*pom1*pom1
5811           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5812         enddo
5813 C Subtract the constant term
5814         etors=etors-v0(itori,itori1,iblock)
5815           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5816      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
5817         if (lprn)
5818      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5819      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5820      &  (v1(j,itori,itori1,iblock),j=1,6),
5821      &  (v2(j,itori,itori1,iblock),j=1,6)
5822         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5823 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5824       enddo
5825 ! 6/20/98 - dihedral angle constraints
5826       edihcnstr=0.0d0
5827 c      do i=1,ndih_constr
5828       do i=idihconstr_start,idihconstr_end
5829         itori=idih_constr(i)
5830         phii=phi(itori)
5831         difi=pinorm(phii-phi0(i))
5832         if (difi.gt.drange(i)) then
5833           difi=difi-drange(i)
5834           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5835           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5836         else if (difi.lt.-drange(i)) then
5837           difi=difi+drange(i)
5838           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5839           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5840         else
5841           difi=0.0
5842         endif
5843 c        write (iout,*) "gloci", gloc(i-3,icg)
5844 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5845 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5846 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5847       enddo
5848 cd       write (iout,*) 'edihcnstr',edihcnstr
5849       return
5850       end
5851 c----------------------------------------------------------------------------
5852       subroutine etor_d(etors_d)
5853 C 6/23/01 Compute double torsional energy
5854       implicit real*8 (a-h,o-z)
5855       include 'DIMENSIONS'
5856       include 'COMMON.VAR'
5857       include 'COMMON.GEO'
5858       include 'COMMON.LOCAL'
5859       include 'COMMON.TORSION'
5860       include 'COMMON.INTERACT'
5861       include 'COMMON.DERIV'
5862       include 'COMMON.CHAIN'
5863       include 'COMMON.NAMES'
5864       include 'COMMON.IOUNITS'
5865       include 'COMMON.FFIELD'
5866       include 'COMMON.TORCNSTR'
5867       logical lprn
5868 C Set lprn=.true. for debugging
5869       lprn=.false.
5870 c     lprn=.true.
5871       etors_d=0.0D0
5872       do i=iphid_start,iphid_end
5873         itori=itortyp(itype(i-2))
5874         itori1=itortyp(itype(i-1))
5875         itori2=itortyp(itype(i))
5876         phii=phi(i)
5877         phii1=phi(i+1)
5878         gloci1=0.0D0
5879         gloci2=0.0D0
5880         do j=1,ntermd_1(itori,itori1,itori2)
5881           v1cij=v1c(1,j,itori,itori1,itori2)
5882           v1sij=v1s(1,j,itori,itori1,itori2)
5883           v2cij=v1c(2,j,itori,itori1,itori2)
5884           v2sij=v1s(2,j,itori,itori1,itori2)
5885           cosphi1=dcos(j*phii)
5886           sinphi1=dsin(j*phii)
5887           cosphi2=dcos(j*phii1)
5888           sinphi2=dsin(j*phii1)
5889           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5890      &     v2cij*cosphi2+v2sij*sinphi2
5891           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5892           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5893         enddo
5894         do k=2,ntermd_2(itori,itori1,itori2)
5895           do l=1,k-1
5896             v1cdij = v2c(k,l,itori,itori1,itori2)
5897             v2cdij = v2c(l,k,itori,itori1,itori2)
5898             v1sdij = v2s(k,l,itori,itori1,itori2)
5899             v2sdij = v2s(l,k,itori,itori1,itori2)
5900             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5901             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5902             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5903             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5904             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5905      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5906             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5907      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5908             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5909      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5910           enddo
5911         enddo
5912         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5913         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5914 c        write (iout,*) "gloci", gloc(i-3,icg)
5915       enddo
5916       return
5917       end
5918 #endif
5919 c------------------------------------------------------------------------------
5920       subroutine eback_sc_corr(esccor)
5921 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5922 c        conformational states; temporarily implemented as differences
5923 c        between UNRES torsional potentials (dependent on three types of
5924 c        residues) and the torsional potentials dependent on all 20 types
5925 c        of residues computed from AM1  energy surfaces of terminally-blocked
5926 c        amino-acid residues.
5927       implicit real*8 (a-h,o-z)
5928       include 'DIMENSIONS'
5929       include 'COMMON.VAR'
5930       include 'COMMON.GEO'
5931       include 'COMMON.LOCAL'
5932       include 'COMMON.TORSION'
5933       include 'COMMON.SCCOR'
5934       include 'COMMON.INTERACT'
5935       include 'COMMON.DERIV'
5936       include 'COMMON.CHAIN'
5937       include 'COMMON.NAMES'
5938       include 'COMMON.IOUNITS'
5939       include 'COMMON.FFIELD'
5940       include 'COMMON.CONTROL'
5941       logical lprn
5942 C Set lprn=.true. for debugging
5943       lprn=.false.
5944 c      lprn=.true.
5945 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
5946       esccor=0.0D0
5947       do i=itau_start,itau_end
5948         esccor_ii=0.0D0
5949         isccori=isccortyp(itype(i-2))
5950         isccori1=isccortyp(itype(i-1))
5951         phii=phi(i)
5952 cccc  Added 9 May 2012
5953 cc Tauangle is torsional engle depending on the value of first digit
5954 c(see comment below)
5955 cc Omicron is flat angle depending on the value of first digit
5956 c(see comment below)
5957
5958
5959         do intertyp=1,3 !intertyp
5960 cc Added 09 May 2012 (Adasko)
5961 cc  Intertyp means interaction type of backbone mainchain correlation:
5962 c   1 = SC...Ca...Ca...Ca
5963 c   2 = Ca...Ca...Ca...SC
5964 c   3 = SC...Ca...Ca...SCi
5965         gloci=0.0D0
5966         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5967      &      (itype(i-1).eq.10).or.(itype(i-2).eq.21).or.
5968      &      (itype(i-1).eq.21)))
5969      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5970      &     .or.(itype(i-2).eq.21)))
5971      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5972      &      (itype(i-1).eq.21)))) cycle
5973         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle
5974         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21))
5975      & cycle
5976         do j=1,nterm_sccor(isccori,isccori1)
5977           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5978           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5979           cosphi=dcos(j*tauangle(intertyp,i))
5980           sinphi=dsin(j*tauangle(intertyp,i))
5981           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5982           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5983         enddo
5984         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5985 c        write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
5986 c     &gloc_sc(intertyp,i-3,icg)
5987         if (lprn)
5988      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5989      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5990      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
5991      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
5992         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5993        enddo !intertyp
5994       enddo
5995 c        do i=1,nres
5996 c        write (iout,*) "W@T@F",  gloc_sc(1,i,icg),gloc(i,icg)
5997 c        enddo
5998       return
5999       end
6000 c----------------------------------------------------------------------------
6001       subroutine multibody(ecorr)
6002 C This subroutine calculates multi-body contributions to energy following
6003 C the idea of Skolnick et al. If side chains I and J make a contact and
6004 C at the same time side chains I+1 and J+1 make a contact, an extra
6005 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6006       implicit real*8 (a-h,o-z)
6007       include 'DIMENSIONS'
6008       include 'COMMON.IOUNITS'
6009       include 'COMMON.DERIV'
6010       include 'COMMON.INTERACT'
6011       include 'COMMON.CONTACTS'
6012       double precision gx(3),gx1(3)
6013       logical lprn
6014
6015 C Set lprn=.true. for debugging
6016       lprn=.false.
6017
6018       if (lprn) then
6019         write (iout,'(a)') 'Contact function values:'
6020         do i=nnt,nct-2
6021           write (iout,'(i2,20(1x,i2,f10.5))')
6022      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6023         enddo
6024       endif
6025       ecorr=0.0D0
6026       do i=nnt,nct
6027         do j=1,3
6028           gradcorr(j,i)=0.0D0
6029           gradxorr(j,i)=0.0D0
6030         enddo
6031       enddo
6032       do i=nnt,nct-2
6033
6034         DO ISHIFT = 3,4
6035
6036         i1=i+ishift
6037         num_conti=num_cont(i)
6038         num_conti1=num_cont(i1)
6039         do jj=1,num_conti
6040           j=jcont(jj,i)
6041           do kk=1,num_conti1
6042             j1=jcont(kk,i1)
6043             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6044 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6045 cd   &                   ' ishift=',ishift
6046 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6047 C The system gains extra energy.
6048               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6049             endif   ! j1==j+-ishift
6050           enddo     ! kk
6051         enddo       ! jj
6052
6053         ENDDO ! ISHIFT
6054
6055       enddo         ! i
6056       return
6057       end
6058 c------------------------------------------------------------------------------
6059       double precision function esccorr(i,j,k,l,jj,kk)
6060       implicit real*8 (a-h,o-z)
6061       include 'DIMENSIONS'
6062       include 'COMMON.IOUNITS'
6063       include 'COMMON.DERIV'
6064       include 'COMMON.INTERACT'
6065       include 'COMMON.CONTACTS'
6066       double precision gx(3),gx1(3)
6067       logical lprn
6068       lprn=.false.
6069       eij=facont(jj,i)
6070       ekl=facont(kk,k)
6071 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6072 C Calculate the multi-body contribution to energy.
6073 C Calculate multi-body contributions to the gradient.
6074 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6075 cd   & k,l,(gacont(m,kk,k),m=1,3)
6076       do m=1,3
6077         gx(m) =ekl*gacont(m,jj,i)
6078         gx1(m)=eij*gacont(m,kk,k)
6079         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6080         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6081         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6082         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6083       enddo
6084       do m=i,j-1
6085         do ll=1,3
6086           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6087         enddo
6088       enddo
6089       do m=k,l-1
6090         do ll=1,3
6091           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6092         enddo
6093       enddo
6094       esccorr=-eij*ekl
6095       return
6096       end
6097 c------------------------------------------------------------------------------
6098       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6099 C This subroutine calculates multi-body contributions to hydrogen-bonding
6100       implicit real*8 (a-h,o-z)
6101       include 'DIMENSIONS'
6102       include 'COMMON.IOUNITS'
6103 #ifdef MPI
6104       include "mpif.h"
6105       parameter (max_cont=maxconts)
6106       parameter (max_dim=26)
6107       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6108       double precision zapas(max_dim,maxconts,max_fg_procs),
6109      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6110       common /przechowalnia/ zapas
6111       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6112      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6113 #endif
6114       include 'COMMON.SETUP'
6115       include 'COMMON.FFIELD'
6116       include 'COMMON.DERIV'
6117       include 'COMMON.INTERACT'
6118       include 'COMMON.CONTACTS'
6119       include 'COMMON.CONTROL'
6120       include 'COMMON.LOCAL'
6121       double precision gx(3),gx1(3),time00
6122       logical lprn,ldone
6123
6124 C Set lprn=.true. for debugging
6125       lprn=.false.
6126 #ifdef MPI
6127       n_corr=0
6128       n_corr1=0
6129       if (nfgtasks.le.1) goto 30
6130       if (lprn) then
6131         write (iout,'(a)') 'Contact function values before RECEIVE:'
6132         do i=nnt,nct-2
6133           write (iout,'(2i3,50(1x,i2,f5.2))')
6134      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6135      &    j=1,num_cont_hb(i))
6136         enddo
6137       endif
6138       call flush(iout)
6139       do i=1,ntask_cont_from
6140         ncont_recv(i)=0
6141       enddo
6142       do i=1,ntask_cont_to
6143         ncont_sent(i)=0
6144       enddo
6145 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6146 c     & ntask_cont_to
6147 C Make the list of contacts to send to send to other procesors
6148 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6149 c      call flush(iout)
6150       do i=iturn3_start,iturn3_end
6151 c        write (iout,*) "make contact list turn3",i," num_cont",
6152 c     &    num_cont_hb(i)
6153         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6154       enddo
6155       do i=iturn4_start,iturn4_end
6156 c        write (iout,*) "make contact list turn4",i," num_cont",
6157 c     &   num_cont_hb(i)
6158         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6159       enddo
6160       do ii=1,nat_sent
6161         i=iat_sent(ii)
6162 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6163 c     &    num_cont_hb(i)
6164         do j=1,num_cont_hb(i)
6165         do k=1,4
6166           jjc=jcont_hb(j,i)
6167           iproc=iint_sent_local(k,jjc,ii)
6168 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6169           if (iproc.gt.0) then
6170             ncont_sent(iproc)=ncont_sent(iproc)+1
6171             nn=ncont_sent(iproc)
6172             zapas(1,nn,iproc)=i
6173             zapas(2,nn,iproc)=jjc
6174             zapas(3,nn,iproc)=facont_hb(j,i)
6175             zapas(4,nn,iproc)=ees0p(j,i)
6176             zapas(5,nn,iproc)=ees0m(j,i)
6177             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6178             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6179             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6180             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6181             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6182             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6183             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6184             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6185             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6186             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6187             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6188             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6189             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6190             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6191             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6192             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6193             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6194             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6195             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6196             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6197             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6198           endif
6199         enddo
6200         enddo
6201       enddo
6202       if (lprn) then
6203       write (iout,*)
6204      &  "Numbers of contacts to be sent to other processors",
6205      &  (ncont_sent(i),i=1,ntask_cont_to)
6206       write (iout,*) "Contacts sent"
6207       do ii=1,ntask_cont_to
6208         nn=ncont_sent(ii)
6209         iproc=itask_cont_to(ii)
6210         write (iout,*) nn," contacts to processor",iproc,
6211      &   " of CONT_TO_COMM group"
6212         do i=1,nn
6213           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6214         enddo
6215       enddo
6216       call flush(iout)
6217       endif
6218       CorrelType=477
6219       CorrelID=fg_rank+1
6220       CorrelType1=478
6221       CorrelID1=nfgtasks+fg_rank+1
6222       ireq=0
6223 C Receive the numbers of needed contacts from other processors
6224       do ii=1,ntask_cont_from
6225         iproc=itask_cont_from(ii)
6226         ireq=ireq+1
6227         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6228      &    FG_COMM,req(ireq),IERR)
6229       enddo
6230 c      write (iout,*) "IRECV ended"
6231 c      call flush(iout)
6232 C Send the number of contacts needed by other processors
6233       do ii=1,ntask_cont_to
6234         iproc=itask_cont_to(ii)
6235         ireq=ireq+1
6236         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6237      &    FG_COMM,req(ireq),IERR)
6238       enddo
6239 c      write (iout,*) "ISEND ended"
6240 c      write (iout,*) "number of requests (nn)",ireq
6241       call flush(iout)
6242       if (ireq.gt.0)
6243      &  call MPI_Waitall(ireq,req,status_array,ierr)
6244 c      write (iout,*)
6245 c     &  "Numbers of contacts to be received from other processors",
6246 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6247 c      call flush(iout)
6248 C Receive contacts
6249       ireq=0
6250       do ii=1,ntask_cont_from
6251         iproc=itask_cont_from(ii)
6252         nn=ncont_recv(ii)
6253 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6254 c     &   " of CONT_TO_COMM group"
6255         call flush(iout)
6256         if (nn.gt.0) then
6257           ireq=ireq+1
6258           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6259      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6260 c          write (iout,*) "ireq,req",ireq,req(ireq)
6261         endif
6262       enddo
6263 C Send the contacts to processors that need them
6264       do ii=1,ntask_cont_to
6265         iproc=itask_cont_to(ii)
6266         nn=ncont_sent(ii)
6267 c        write (iout,*) nn," contacts to processor",iproc,
6268 c     &   " of CONT_TO_COMM group"
6269         if (nn.gt.0) then
6270           ireq=ireq+1
6271           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6272      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6273 c          write (iout,*) "ireq,req",ireq,req(ireq)
6274 c          do i=1,nn
6275 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6276 c          enddo
6277         endif
6278       enddo
6279 c      write (iout,*) "number of requests (contacts)",ireq
6280 c      write (iout,*) "req",(req(i),i=1,4)
6281 c      call flush(iout)
6282       if (ireq.gt.0)
6283      & call MPI_Waitall(ireq,req,status_array,ierr)
6284       do iii=1,ntask_cont_from
6285         iproc=itask_cont_from(iii)
6286         nn=ncont_recv(iii)
6287         if (lprn) then
6288         write (iout,*) "Received",nn," contacts from processor",iproc,
6289      &   " of CONT_FROM_COMM group"
6290         call flush(iout)
6291         do i=1,nn
6292           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6293         enddo
6294         call flush(iout)
6295         endif
6296         do i=1,nn
6297           ii=zapas_recv(1,i,iii)
6298 c Flag the received contacts to prevent double-counting
6299           jj=-zapas_recv(2,i,iii)
6300 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6301 c          call flush(iout)
6302           nnn=num_cont_hb(ii)+1
6303           num_cont_hb(ii)=nnn
6304           jcont_hb(nnn,ii)=jj
6305           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6306           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6307           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6308           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6309           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6310           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6311           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6312           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6313           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6314           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6315           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6316           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6317           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6318           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6319           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6320           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6321           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6322           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6323           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6324           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6325           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6326           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6327           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6328           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6329         enddo
6330       enddo
6331       call flush(iout)
6332       if (lprn) then
6333         write (iout,'(a)') 'Contact function values after receive:'
6334         do i=nnt,nct-2
6335           write (iout,'(2i3,50(1x,i3,f5.2))')
6336      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6337      &    j=1,num_cont_hb(i))
6338         enddo
6339         call flush(iout)
6340       endif
6341    30 continue
6342 #endif
6343       if (lprn) then
6344         write (iout,'(a)') 'Contact function values:'
6345         do i=nnt,nct-2
6346           write (iout,'(2i3,50(1x,i3,f5.2))')
6347      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6348      &    j=1,num_cont_hb(i))
6349         enddo
6350       endif
6351       ecorr=0.0D0
6352 C Remove the loop below after debugging !!!
6353       do i=nnt,nct
6354         do j=1,3
6355           gradcorr(j,i)=0.0D0
6356           gradxorr(j,i)=0.0D0
6357         enddo
6358       enddo
6359 C Calculate the local-electrostatic correlation terms
6360       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6361         i1=i+1
6362         num_conti=num_cont_hb(i)
6363         num_conti1=num_cont_hb(i+1)
6364         do jj=1,num_conti
6365           j=jcont_hb(jj,i)
6366           jp=iabs(j)
6367           do kk=1,num_conti1
6368             j1=jcont_hb(kk,i1)
6369             jp1=iabs(j1)
6370 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6371 c     &         ' jj=',jj,' kk=',kk
6372             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6373      &          .or. j.lt.0 .and. j1.gt.0) .and.
6374      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6375 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6376 C The system gains extra energy.
6377               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6378               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6379      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6380               n_corr=n_corr+1
6381             else if (j1.eq.j) then
6382 C Contacts I-J and I-(J+1) occur simultaneously.
6383 C The system loses extra energy.
6384 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6385             endif
6386           enddo ! kk
6387           do kk=1,num_conti
6388             j1=jcont_hb(kk,i)
6389 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6390 c    &         ' jj=',jj,' kk=',kk
6391             if (j1.eq.j+1) then
6392 C Contacts I-J and (I+1)-J occur simultaneously.
6393 C The system loses extra energy.
6394 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6395             endif ! j1==j+1
6396           enddo ! kk
6397         enddo ! jj
6398       enddo ! i
6399       return
6400       end
6401 c------------------------------------------------------------------------------
6402       subroutine add_hb_contact(ii,jj,itask)
6403       implicit real*8 (a-h,o-z)
6404       include "DIMENSIONS"
6405       include "COMMON.IOUNITS"
6406       integer max_cont
6407       integer max_dim
6408       parameter (max_cont=maxconts)
6409       parameter (max_dim=26)
6410       include "COMMON.CONTACTS"
6411       double precision zapas(max_dim,maxconts,max_fg_procs),
6412      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6413       common /przechowalnia/ zapas
6414       integer i,j,ii,jj,iproc,itask(4),nn
6415 c      write (iout,*) "itask",itask
6416       do i=1,2
6417         iproc=itask(i)
6418         if (iproc.gt.0) then
6419           do j=1,num_cont_hb(ii)
6420             jjc=jcont_hb(j,ii)
6421 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6422             if (jjc.eq.jj) then
6423               ncont_sent(iproc)=ncont_sent(iproc)+1
6424               nn=ncont_sent(iproc)
6425               zapas(1,nn,iproc)=ii
6426               zapas(2,nn,iproc)=jjc
6427               zapas(3,nn,iproc)=facont_hb(j,ii)
6428               zapas(4,nn,iproc)=ees0p(j,ii)
6429               zapas(5,nn,iproc)=ees0m(j,ii)
6430               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6431               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6432               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6433               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6434               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6435               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6436               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6437               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6438               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6439               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6440               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6441               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6442               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6443               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6444               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6445               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6446               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6447               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6448               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6449               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6450               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6451               exit
6452             endif
6453           enddo
6454         endif
6455       enddo
6456       return
6457       end
6458 c------------------------------------------------------------------------------
6459       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6460      &  n_corr1)
6461 C This subroutine calculates multi-body contributions to hydrogen-bonding
6462       implicit real*8 (a-h,o-z)
6463       include 'DIMENSIONS'
6464       include 'COMMON.IOUNITS'
6465 #ifdef MPI
6466       include "mpif.h"
6467       parameter (max_cont=maxconts)
6468       parameter (max_dim=70)
6469       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6470       double precision zapas(max_dim,maxconts,max_fg_procs),
6471      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6472       common /przechowalnia/ zapas
6473       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6474      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6475 #endif
6476       include 'COMMON.SETUP'
6477       include 'COMMON.FFIELD'
6478       include 'COMMON.DERIV'
6479       include 'COMMON.LOCAL'
6480       include 'COMMON.INTERACT'
6481       include 'COMMON.CONTACTS'
6482       include 'COMMON.CHAIN'
6483       include 'COMMON.CONTROL'
6484       double precision gx(3),gx1(3)
6485       integer num_cont_hb_old(maxres)
6486       logical lprn,ldone
6487       double precision eello4,eello5,eelo6,eello_turn6
6488       external eello4,eello5,eello6,eello_turn6
6489 C Set lprn=.true. for debugging
6490       lprn=.false.
6491       eturn6=0.0d0
6492 #ifdef MPI
6493       do i=1,nres
6494         num_cont_hb_old(i)=num_cont_hb(i)
6495       enddo
6496       n_corr=0
6497       n_corr1=0
6498       if (nfgtasks.le.1) goto 30
6499       if (lprn) then
6500         write (iout,'(a)') 'Contact function values before RECEIVE:'
6501         do i=nnt,nct-2
6502           write (iout,'(2i3,50(1x,i2,f5.2))')
6503      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6504      &    j=1,num_cont_hb(i))
6505         enddo
6506       endif
6507       call flush(iout)
6508       do i=1,ntask_cont_from
6509         ncont_recv(i)=0
6510       enddo
6511       do i=1,ntask_cont_to
6512         ncont_sent(i)=0
6513       enddo
6514 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6515 c     & ntask_cont_to
6516 C Make the list of contacts to send to send to other procesors
6517       do i=iturn3_start,iturn3_end
6518 c        write (iout,*) "make contact list turn3",i," num_cont",
6519 c     &    num_cont_hb(i)
6520         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6521       enddo
6522       do i=iturn4_start,iturn4_end
6523 c        write (iout,*) "make contact list turn4",i," num_cont",
6524 c     &   num_cont_hb(i)
6525         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6526       enddo
6527       do ii=1,nat_sent
6528         i=iat_sent(ii)
6529 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6530 c     &    num_cont_hb(i)
6531         do j=1,num_cont_hb(i)
6532         do k=1,4
6533           jjc=jcont_hb(j,i)
6534           iproc=iint_sent_local(k,jjc,ii)
6535 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6536           if (iproc.ne.0) then
6537             ncont_sent(iproc)=ncont_sent(iproc)+1
6538             nn=ncont_sent(iproc)
6539             zapas(1,nn,iproc)=i
6540             zapas(2,nn,iproc)=jjc
6541             zapas(3,nn,iproc)=d_cont(j,i)
6542             ind=3
6543             do kk=1,3
6544               ind=ind+1
6545               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6546             enddo
6547             do kk=1,2
6548               do ll=1,2
6549                 ind=ind+1
6550                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6551               enddo
6552             enddo
6553             do jj=1,5
6554               do kk=1,3
6555                 do ll=1,2
6556                   do mm=1,2
6557                     ind=ind+1
6558                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6559                   enddo
6560                 enddo
6561               enddo
6562             enddo
6563           endif
6564         enddo
6565         enddo
6566       enddo
6567       if (lprn) then
6568       write (iout,*)
6569      &  "Numbers of contacts to be sent to other processors",
6570      &  (ncont_sent(i),i=1,ntask_cont_to)
6571       write (iout,*) "Contacts sent"
6572       do ii=1,ntask_cont_to
6573         nn=ncont_sent(ii)
6574         iproc=itask_cont_to(ii)
6575         write (iout,*) nn," contacts to processor",iproc,
6576      &   " of CONT_TO_COMM group"
6577         do i=1,nn
6578           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6579         enddo
6580       enddo
6581       call flush(iout)
6582       endif
6583       CorrelType=477
6584       CorrelID=fg_rank+1
6585       CorrelType1=478
6586       CorrelID1=nfgtasks+fg_rank+1
6587       ireq=0
6588 C Receive the numbers of needed contacts from other processors
6589       do ii=1,ntask_cont_from
6590         iproc=itask_cont_from(ii)
6591         ireq=ireq+1
6592         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6593      &    FG_COMM,req(ireq),IERR)
6594       enddo
6595 c      write (iout,*) "IRECV ended"
6596 c      call flush(iout)
6597 C Send the number of contacts needed by other processors
6598       do ii=1,ntask_cont_to
6599         iproc=itask_cont_to(ii)
6600         ireq=ireq+1
6601         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6602      &    FG_COMM,req(ireq),IERR)
6603       enddo
6604 c      write (iout,*) "ISEND ended"
6605 c      write (iout,*) "number of requests (nn)",ireq
6606       call flush(iout)
6607       if (ireq.gt.0)
6608      &  call MPI_Waitall(ireq,req,status_array,ierr)
6609 c      write (iout,*)
6610 c     &  "Numbers of contacts to be received from other processors",
6611 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6612 c      call flush(iout)
6613 C Receive contacts
6614       ireq=0
6615       do ii=1,ntask_cont_from
6616         iproc=itask_cont_from(ii)
6617         nn=ncont_recv(ii)
6618 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6619 c     &   " of CONT_TO_COMM group"
6620         call flush(iout)
6621         if (nn.gt.0) then
6622           ireq=ireq+1
6623           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6624      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6625 c          write (iout,*) "ireq,req",ireq,req(ireq)
6626         endif
6627       enddo
6628 C Send the contacts to processors that need them
6629       do ii=1,ntask_cont_to
6630         iproc=itask_cont_to(ii)
6631         nn=ncont_sent(ii)
6632 c        write (iout,*) nn," contacts to processor",iproc,
6633 c     &   " of CONT_TO_COMM group"
6634         if (nn.gt.0) then
6635           ireq=ireq+1
6636           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6637      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6638 c          write (iout,*) "ireq,req",ireq,req(ireq)
6639 c          do i=1,nn
6640 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6641 c          enddo
6642         endif
6643       enddo
6644 c      write (iout,*) "number of requests (contacts)",ireq
6645 c      write (iout,*) "req",(req(i),i=1,4)
6646 c      call flush(iout)
6647       if (ireq.gt.0)
6648      & call MPI_Waitall(ireq,req,status_array,ierr)
6649       do iii=1,ntask_cont_from
6650         iproc=itask_cont_from(iii)
6651         nn=ncont_recv(iii)
6652         if (lprn) then
6653         write (iout,*) "Received",nn," contacts from processor",iproc,
6654      &   " of CONT_FROM_COMM group"
6655         call flush(iout)
6656         do i=1,nn
6657           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6658         enddo
6659         call flush(iout)
6660         endif
6661         do i=1,nn
6662           ii=zapas_recv(1,i,iii)
6663 c Flag the received contacts to prevent double-counting
6664           jj=-zapas_recv(2,i,iii)
6665 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6666 c          call flush(iout)
6667           nnn=num_cont_hb(ii)+1
6668           num_cont_hb(ii)=nnn
6669           jcont_hb(nnn,ii)=jj
6670           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6671           ind=3
6672           do kk=1,3
6673             ind=ind+1
6674             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6675           enddo
6676           do kk=1,2
6677             do ll=1,2
6678               ind=ind+1
6679               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6680             enddo
6681           enddo
6682           do jj=1,5
6683             do kk=1,3
6684               do ll=1,2
6685                 do mm=1,2
6686                   ind=ind+1
6687                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6688                 enddo
6689               enddo
6690             enddo
6691           enddo
6692         enddo
6693       enddo
6694       call flush(iout)
6695       if (lprn) then
6696         write (iout,'(a)') 'Contact function values after receive:'
6697         do i=nnt,nct-2
6698           write (iout,'(2i3,50(1x,i3,5f6.3))')
6699      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6700      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6701         enddo
6702         call flush(iout)
6703       endif
6704    30 continue
6705 #endif
6706       if (lprn) then
6707         write (iout,'(a)') 'Contact function values:'
6708         do i=nnt,nct-2
6709           write (iout,'(2i3,50(1x,i2,5f6.3))')
6710      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6711      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6712         enddo
6713       endif
6714       ecorr=0.0D0
6715       ecorr5=0.0d0
6716       ecorr6=0.0d0
6717 C Remove the loop below after debugging !!!
6718       do i=nnt,nct
6719         do j=1,3
6720           gradcorr(j,i)=0.0D0
6721           gradxorr(j,i)=0.0D0
6722         enddo
6723       enddo
6724 C Calculate the dipole-dipole interaction energies
6725       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6726       do i=iatel_s,iatel_e+1
6727         num_conti=num_cont_hb(i)
6728         do jj=1,num_conti
6729           j=jcont_hb(jj,i)
6730 #ifdef MOMENT
6731           call dipole(i,j,jj)
6732 #endif
6733         enddo
6734       enddo
6735       endif
6736 C Calculate the local-electrostatic correlation terms
6737 c                write (iout,*) "gradcorr5 in eello5 before loop"
6738 c                do iii=1,nres
6739 c                  write (iout,'(i5,3f10.5)')
6740 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6741 c                enddo
6742       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6743 c        write (iout,*) "corr loop i",i
6744         i1=i+1
6745         num_conti=num_cont_hb(i)
6746         num_conti1=num_cont_hb(i+1)
6747         do jj=1,num_conti
6748           j=jcont_hb(jj,i)
6749           jp=iabs(j)
6750           do kk=1,num_conti1
6751             j1=jcont_hb(kk,i1)
6752             jp1=iabs(j1)
6753 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6754 c     &         ' jj=',jj,' kk=',kk
6755 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6756             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6757      &          .or. j.lt.0 .and. j1.gt.0) .and.
6758      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6759 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6760 C The system gains extra energy.
6761               n_corr=n_corr+1
6762               sqd1=dsqrt(d_cont(jj,i))
6763               sqd2=dsqrt(d_cont(kk,i1))
6764               sred_geom = sqd1*sqd2
6765               IF (sred_geom.lt.cutoff_corr) THEN
6766                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6767      &            ekont,fprimcont)
6768 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6769 cd     &         ' jj=',jj,' kk=',kk
6770                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6771                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6772                 do l=1,3
6773                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6774                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6775                 enddo
6776                 n_corr1=n_corr1+1
6777 cd               write (iout,*) 'sred_geom=',sred_geom,
6778 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6779 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6780 cd               write (iout,*) "g_contij",g_contij
6781 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6782 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6783                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6784                 if (wcorr4.gt.0.0d0)
6785      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6786                   if (energy_dec.and.wcorr4.gt.0.0d0)
6787      1                 write (iout,'(a6,4i5,0pf7.3)')
6788      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6789 c                write (iout,*) "gradcorr5 before eello5"
6790 c                do iii=1,nres
6791 c                  write (iout,'(i5,3f10.5)')
6792 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6793 c                enddo
6794                 if (wcorr5.gt.0.0d0)
6795      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6796 c                write (iout,*) "gradcorr5 after eello5"
6797 c                do iii=1,nres
6798 c                  write (iout,'(i5,3f10.5)')
6799 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6800 c                enddo
6801                   if (energy_dec.and.wcorr5.gt.0.0d0)
6802      1                 write (iout,'(a6,4i5,0pf7.3)')
6803      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6804 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6805 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6806                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6807      &               .or. wturn6.eq.0.0d0))then
6808 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6809                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6810                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6811      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6812 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6813 cd     &            'ecorr6=',ecorr6
6814 cd                write (iout,'(4e15.5)') sred_geom,
6815 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6816 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6817 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6818                 else if (wturn6.gt.0.0d0
6819      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6820 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6821                   eturn6=eturn6+eello_turn6(i,jj,kk)
6822                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6823      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6824 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6825                 endif
6826               ENDIF
6827 1111          continue
6828             endif
6829           enddo ! kk
6830         enddo ! jj
6831       enddo ! i
6832       do i=1,nres
6833         num_cont_hb(i)=num_cont_hb_old(i)
6834       enddo
6835 c                write (iout,*) "gradcorr5 in eello5"
6836 c                do iii=1,nres
6837 c                  write (iout,'(i5,3f10.5)')
6838 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6839 c                enddo
6840       return
6841       end
6842 c------------------------------------------------------------------------------
6843       subroutine add_hb_contact_eello(ii,jj,itask)
6844       implicit real*8 (a-h,o-z)
6845       include "DIMENSIONS"
6846       include "COMMON.IOUNITS"
6847       integer max_cont
6848       integer max_dim
6849       parameter (max_cont=maxconts)
6850       parameter (max_dim=70)
6851       include "COMMON.CONTACTS"
6852       double precision zapas(max_dim,maxconts,max_fg_procs),
6853      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6854       common /przechowalnia/ zapas
6855       integer i,j,ii,jj,iproc,itask(4),nn
6856 c      write (iout,*) "itask",itask
6857       do i=1,2
6858         iproc=itask(i)
6859         if (iproc.gt.0) then
6860           do j=1,num_cont_hb(ii)
6861             jjc=jcont_hb(j,ii)
6862 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6863             if (jjc.eq.jj) then
6864               ncont_sent(iproc)=ncont_sent(iproc)+1
6865               nn=ncont_sent(iproc)
6866               zapas(1,nn,iproc)=ii
6867               zapas(2,nn,iproc)=jjc
6868               zapas(3,nn,iproc)=d_cont(j,ii)
6869               ind=3
6870               do kk=1,3
6871                 ind=ind+1
6872                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6873               enddo
6874               do kk=1,2
6875                 do ll=1,2
6876                   ind=ind+1
6877                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6878                 enddo
6879               enddo
6880               do jj=1,5
6881                 do kk=1,3
6882                   do ll=1,2
6883                     do mm=1,2
6884                       ind=ind+1
6885                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6886                     enddo
6887                   enddo
6888                 enddo
6889               enddo
6890               exit
6891             endif
6892           enddo
6893         endif
6894       enddo
6895       return
6896       end
6897 c------------------------------------------------------------------------------
6898       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6899       implicit real*8 (a-h,o-z)
6900       include 'DIMENSIONS'
6901       include 'COMMON.IOUNITS'
6902       include 'COMMON.DERIV'
6903       include 'COMMON.INTERACT'
6904       include 'COMMON.CONTACTS'
6905       double precision gx(3),gx1(3)
6906       logical lprn
6907       lprn=.false.
6908       eij=facont_hb(jj,i)
6909       ekl=facont_hb(kk,k)
6910       ees0pij=ees0p(jj,i)
6911       ees0pkl=ees0p(kk,k)
6912       ees0mij=ees0m(jj,i)
6913       ees0mkl=ees0m(kk,k)
6914       ekont=eij*ekl
6915       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6916 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6917 C Following 4 lines for diagnostics.
6918 cd    ees0pkl=0.0D0
6919 cd    ees0pij=1.0D0
6920 cd    ees0mkl=0.0D0
6921 cd    ees0mij=1.0D0
6922 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6923 c     & 'Contacts ',i,j,
6924 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6925 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6926 c     & 'gradcorr_long'
6927 C Calculate the multi-body contribution to energy.
6928 c      ecorr=ecorr+ekont*ees
6929 C Calculate multi-body contributions to the gradient.
6930       coeffpees0pij=coeffp*ees0pij
6931       coeffmees0mij=coeffm*ees0mij
6932       coeffpees0pkl=coeffp*ees0pkl
6933       coeffmees0mkl=coeffm*ees0mkl
6934       do ll=1,3
6935 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6936         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6937      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6938      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6939         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6940      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6941      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6942 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6943         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6944      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6945      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6946         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6947      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6948      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6949         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6950      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6951      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6952         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6953         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6954         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6955      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6956      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6957         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6958         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6959 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6960       enddo
6961 c      write (iout,*)
6962 cgrad      do m=i+1,j-1
6963 cgrad        do ll=1,3
6964 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6965 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6966 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6967 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6968 cgrad        enddo
6969 cgrad      enddo
6970 cgrad      do m=k+1,l-1
6971 cgrad        do ll=1,3
6972 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6973 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6974 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6975 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6976 cgrad        enddo
6977 cgrad      enddo
6978 c      write (iout,*) "ehbcorr",ekont*ees
6979       ehbcorr=ekont*ees
6980       return
6981       end
6982 #ifdef MOMENT
6983 C---------------------------------------------------------------------------
6984       subroutine dipole(i,j,jj)
6985       implicit real*8 (a-h,o-z)
6986       include 'DIMENSIONS'
6987       include 'COMMON.IOUNITS'
6988       include 'COMMON.CHAIN'
6989       include 'COMMON.FFIELD'
6990       include 'COMMON.DERIV'
6991       include 'COMMON.INTERACT'
6992       include 'COMMON.CONTACTS'
6993       include 'COMMON.TORSION'
6994       include 'COMMON.VAR'
6995       include 'COMMON.GEO'
6996       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6997      &  auxmat(2,2)
6998       iti1 = itortyp(itype(i+1))
6999       if (j.lt.nres-1) then
7000         itj1 = itortyp(itype(j+1))
7001       else
7002         itj1=ntortyp+1
7003       endif
7004       do iii=1,2
7005         dipi(iii,1)=Ub2(iii,i)
7006         dipderi(iii)=Ub2der(iii,i)
7007         dipi(iii,2)=b1(iii,iti1)
7008         dipj(iii,1)=Ub2(iii,j)
7009         dipderj(iii)=Ub2der(iii,j)
7010         dipj(iii,2)=b1(iii,itj1)
7011       enddo
7012       kkk=0
7013       do iii=1,2
7014         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7015         do jjj=1,2
7016           kkk=kkk+1
7017           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7018         enddo
7019       enddo
7020       do kkk=1,5
7021         do lll=1,3
7022           mmm=0
7023           do iii=1,2
7024             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7025      &        auxvec(1))
7026             do jjj=1,2
7027               mmm=mmm+1
7028               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7029             enddo
7030           enddo
7031         enddo
7032       enddo
7033       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7034       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7035       do iii=1,2
7036         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7037       enddo
7038       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7039       do iii=1,2
7040         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7041       enddo
7042       return
7043       end
7044 #endif
7045 C---------------------------------------------------------------------------
7046       subroutine calc_eello(i,j,k,l,jj,kk)
7047 C
7048 C This subroutine computes matrices and vectors needed to calculate
7049 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7050 C
7051       implicit real*8 (a-h,o-z)
7052       include 'DIMENSIONS'
7053       include 'COMMON.IOUNITS'
7054       include 'COMMON.CHAIN'
7055       include 'COMMON.DERIV'
7056       include 'COMMON.INTERACT'
7057       include 'COMMON.CONTACTS'
7058       include 'COMMON.TORSION'
7059       include 'COMMON.VAR'
7060       include 'COMMON.GEO'
7061       include 'COMMON.FFIELD'
7062       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7063      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7064       logical lprn
7065       common /kutas/ lprn
7066 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7067 cd     & ' jj=',jj,' kk=',kk
7068 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7069 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7070 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7071       do iii=1,2
7072         do jjj=1,2
7073           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7074           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7075         enddo
7076       enddo
7077       call transpose2(aa1(1,1),aa1t(1,1))
7078       call transpose2(aa2(1,1),aa2t(1,1))
7079       do kkk=1,5
7080         do lll=1,3
7081           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7082      &      aa1tder(1,1,lll,kkk))
7083           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7084      &      aa2tder(1,1,lll,kkk))
7085         enddo
7086       enddo
7087       if (l.eq.j+1) then
7088 C parallel orientation of the two CA-CA-CA frames.
7089         if (i.gt.1) then
7090           iti=itortyp(itype(i))
7091         else
7092           iti=ntortyp+1
7093         endif
7094         itk1=itortyp(itype(k+1))
7095         itj=itortyp(itype(j))
7096         if (l.lt.nres-1) then
7097           itl1=itortyp(itype(l+1))
7098         else
7099           itl1=ntortyp+1
7100         endif
7101 C A1 kernel(j+1) A2T
7102 cd        do iii=1,2
7103 cd          write (iout,'(3f10.5,5x,3f10.5)')
7104 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7105 cd        enddo
7106         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7107      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7108      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7109 C Following matrices are needed only for 6-th order cumulants
7110         IF (wcorr6.gt.0.0d0) THEN
7111         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7112      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7113      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7114         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7115      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7116      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7117      &   ADtEAderx(1,1,1,1,1,1))
7118         lprn=.false.
7119         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7120      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7121      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7122      &   ADtEA1derx(1,1,1,1,1,1))
7123         ENDIF
7124 C End 6-th order cumulants
7125 cd        lprn=.false.
7126 cd        if (lprn) then
7127 cd        write (2,*) 'In calc_eello6'
7128 cd        do iii=1,2
7129 cd          write (2,*) 'iii=',iii
7130 cd          do kkk=1,5
7131 cd            write (2,*) 'kkk=',kkk
7132 cd            do jjj=1,2
7133 cd              write (2,'(3(2f10.5),5x)')
7134 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7135 cd            enddo
7136 cd          enddo
7137 cd        enddo
7138 cd        endif
7139         call transpose2(EUgder(1,1,k),auxmat(1,1))
7140         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7141         call transpose2(EUg(1,1,k),auxmat(1,1))
7142         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7143         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7144         do iii=1,2
7145           do kkk=1,5
7146             do lll=1,3
7147               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7148      &          EAEAderx(1,1,lll,kkk,iii,1))
7149             enddo
7150           enddo
7151         enddo
7152 C A1T kernel(i+1) A2
7153         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7154      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7155      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7156 C Following matrices are needed only for 6-th order cumulants
7157         IF (wcorr6.gt.0.0d0) THEN
7158         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7159      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7160      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7161         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7162      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7163      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7164      &   ADtEAderx(1,1,1,1,1,2))
7165         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7166      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7167      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7168      &   ADtEA1derx(1,1,1,1,1,2))
7169         ENDIF
7170 C End 6-th order cumulants
7171         call transpose2(EUgder(1,1,l),auxmat(1,1))
7172         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7173         call transpose2(EUg(1,1,l),auxmat(1,1))
7174         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7175         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7176         do iii=1,2
7177           do kkk=1,5
7178             do lll=1,3
7179               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7180      &          EAEAderx(1,1,lll,kkk,iii,2))
7181             enddo
7182           enddo
7183         enddo
7184 C AEAb1 and AEAb2
7185 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7186 C They are needed only when the fifth- or the sixth-order cumulants are
7187 C indluded.
7188         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7189         call transpose2(AEA(1,1,1),auxmat(1,1))
7190         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7191         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7192         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7193         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7194         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7195         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7196         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7197         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7198         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7199         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7200         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7201         call transpose2(AEA(1,1,2),auxmat(1,1))
7202         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7203         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7204         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7205         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7206         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7207         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7208         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7209         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7210         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7211         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7212         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7213 C Calculate the Cartesian derivatives of the vectors.
7214         do iii=1,2
7215           do kkk=1,5
7216             do lll=1,3
7217               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7218               call matvec2(auxmat(1,1),b1(1,iti),
7219      &          AEAb1derx(1,lll,kkk,iii,1,1))
7220               call matvec2(auxmat(1,1),Ub2(1,i),
7221      &          AEAb2derx(1,lll,kkk,iii,1,1))
7222               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7223      &          AEAb1derx(1,lll,kkk,iii,2,1))
7224               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7225      &          AEAb2derx(1,lll,kkk,iii,2,1))
7226               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7227               call matvec2(auxmat(1,1),b1(1,itj),
7228      &          AEAb1derx(1,lll,kkk,iii,1,2))
7229               call matvec2(auxmat(1,1),Ub2(1,j),
7230      &          AEAb2derx(1,lll,kkk,iii,1,2))
7231               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7232      &          AEAb1derx(1,lll,kkk,iii,2,2))
7233               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7234      &          AEAb2derx(1,lll,kkk,iii,2,2))
7235             enddo
7236           enddo
7237         enddo
7238         ENDIF
7239 C End vectors
7240       else
7241 C Antiparallel orientation of the two CA-CA-CA frames.
7242         if (i.gt.1) then
7243           iti=itortyp(itype(i))
7244         else
7245           iti=ntortyp+1
7246         endif
7247         itk1=itortyp(itype(k+1))
7248         itl=itortyp(itype(l))
7249         itj=itortyp(itype(j))
7250         if (j.lt.nres-1) then
7251           itj1=itortyp(itype(j+1))
7252         else
7253           itj1=ntortyp+1
7254         endif
7255 C A2 kernel(j-1)T A1T
7256         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7257      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7258      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7259 C Following matrices are needed only for 6-th order cumulants
7260         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7261      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7262         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7263      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7264      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7265         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7266      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7267      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7268      &   ADtEAderx(1,1,1,1,1,1))
7269         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7270      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7271      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7272      &   ADtEA1derx(1,1,1,1,1,1))
7273         ENDIF
7274 C End 6-th order cumulants
7275         call transpose2(EUgder(1,1,k),auxmat(1,1))
7276         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7277         call transpose2(EUg(1,1,k),auxmat(1,1))
7278         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7279         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7280         do iii=1,2
7281           do kkk=1,5
7282             do lll=1,3
7283               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7284      &          EAEAderx(1,1,lll,kkk,iii,1))
7285             enddo
7286           enddo
7287         enddo
7288 C A2T kernel(i+1)T A1
7289         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7290      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7291      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7292 C Following matrices are needed only for 6-th order cumulants
7293         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7294      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7295         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7296      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7297      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7298         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7299      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7300      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7301      &   ADtEAderx(1,1,1,1,1,2))
7302         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7303      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7304      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7305      &   ADtEA1derx(1,1,1,1,1,2))
7306         ENDIF
7307 C End 6-th order cumulants
7308         call transpose2(EUgder(1,1,j),auxmat(1,1))
7309         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7310         call transpose2(EUg(1,1,j),auxmat(1,1))
7311         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7312         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7313         do iii=1,2
7314           do kkk=1,5
7315             do lll=1,3
7316               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7317      &          EAEAderx(1,1,lll,kkk,iii,2))
7318             enddo
7319           enddo
7320         enddo
7321 C AEAb1 and AEAb2
7322 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7323 C They are needed only when the fifth- or the sixth-order cumulants are
7324 C indluded.
7325         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7326      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7327         call transpose2(AEA(1,1,1),auxmat(1,1))
7328         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7329         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7330         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7331         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7332         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7333         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7334         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7335         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7336         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7337         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7338         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7339         call transpose2(AEA(1,1,2),auxmat(1,1))
7340         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7341         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7342         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7343         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7344         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7345         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7346         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7347         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7348         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7349         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7350         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7351 C Calculate the Cartesian derivatives of the vectors.
7352         do iii=1,2
7353           do kkk=1,5
7354             do lll=1,3
7355               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7356               call matvec2(auxmat(1,1),b1(1,iti),
7357      &          AEAb1derx(1,lll,kkk,iii,1,1))
7358               call matvec2(auxmat(1,1),Ub2(1,i),
7359      &          AEAb2derx(1,lll,kkk,iii,1,1))
7360               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7361      &          AEAb1derx(1,lll,kkk,iii,2,1))
7362               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7363      &          AEAb2derx(1,lll,kkk,iii,2,1))
7364               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7365               call matvec2(auxmat(1,1),b1(1,itl),
7366      &          AEAb1derx(1,lll,kkk,iii,1,2))
7367               call matvec2(auxmat(1,1),Ub2(1,l),
7368      &          AEAb2derx(1,lll,kkk,iii,1,2))
7369               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7370      &          AEAb1derx(1,lll,kkk,iii,2,2))
7371               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7372      &          AEAb2derx(1,lll,kkk,iii,2,2))
7373             enddo
7374           enddo
7375         enddo
7376         ENDIF
7377 C End vectors
7378       endif
7379       return
7380       end
7381 C---------------------------------------------------------------------------
7382       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7383      &  KK,KKderg,AKA,AKAderg,AKAderx)
7384       implicit none
7385       integer nderg
7386       logical transp
7387       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7388      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7389      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7390       integer iii,kkk,lll
7391       integer jjj,mmm
7392       logical lprn
7393       common /kutas/ lprn
7394       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7395       do iii=1,nderg
7396         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7397      &    AKAderg(1,1,iii))
7398       enddo
7399 cd      if (lprn) write (2,*) 'In kernel'
7400       do kkk=1,5
7401 cd        if (lprn) write (2,*) 'kkk=',kkk
7402         do lll=1,3
7403           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7404      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7405 cd          if (lprn) then
7406 cd            write (2,*) 'lll=',lll
7407 cd            write (2,*) 'iii=1'
7408 cd            do jjj=1,2
7409 cd              write (2,'(3(2f10.5),5x)')
7410 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7411 cd            enddo
7412 cd          endif
7413           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7414      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7415 cd          if (lprn) then
7416 cd            write (2,*) 'lll=',lll
7417 cd            write (2,*) 'iii=2'
7418 cd            do jjj=1,2
7419 cd              write (2,'(3(2f10.5),5x)')
7420 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7421 cd            enddo
7422 cd          endif
7423         enddo
7424       enddo
7425       return
7426       end
7427 C---------------------------------------------------------------------------
7428       double precision function eello4(i,j,k,l,jj,kk)
7429       implicit real*8 (a-h,o-z)
7430       include 'DIMENSIONS'
7431       include 'COMMON.IOUNITS'
7432       include 'COMMON.CHAIN'
7433       include 'COMMON.DERIV'
7434       include 'COMMON.INTERACT'
7435       include 'COMMON.CONTACTS'
7436       include 'COMMON.TORSION'
7437       include 'COMMON.VAR'
7438       include 'COMMON.GEO'
7439       double precision pizda(2,2),ggg1(3),ggg2(3)
7440 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7441 cd        eello4=0.0d0
7442 cd        return
7443 cd      endif
7444 cd      print *,'eello4:',i,j,k,l,jj,kk
7445 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7446 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7447 cold      eij=facont_hb(jj,i)
7448 cold      ekl=facont_hb(kk,k)
7449 cold      ekont=eij*ekl
7450       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7451 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7452       gcorr_loc(k-1)=gcorr_loc(k-1)
7453      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7454       if (l.eq.j+1) then
7455         gcorr_loc(l-1)=gcorr_loc(l-1)
7456      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7457       else
7458         gcorr_loc(j-1)=gcorr_loc(j-1)
7459      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7460       endif
7461       do iii=1,2
7462         do kkk=1,5
7463           do lll=1,3
7464             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7465      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7466 cd            derx(lll,kkk,iii)=0.0d0
7467           enddo
7468         enddo
7469       enddo
7470 cd      gcorr_loc(l-1)=0.0d0
7471 cd      gcorr_loc(j-1)=0.0d0
7472 cd      gcorr_loc(k-1)=0.0d0
7473 cd      eel4=1.0d0
7474 cd      write (iout,*)'Contacts have occurred for peptide groups',
7475 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7476 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7477       if (j.lt.nres-1) then
7478         j1=j+1
7479         j2=j-1
7480       else
7481         j1=j-1
7482         j2=j-2
7483       endif
7484       if (l.lt.nres-1) then
7485         l1=l+1
7486         l2=l-1
7487       else
7488         l1=l-1
7489         l2=l-2
7490       endif
7491       do ll=1,3
7492 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7493 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7494         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7495         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7496 cgrad        ghalf=0.5d0*ggg1(ll)
7497         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7498         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7499         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7500         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7501         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7502         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7503 cgrad        ghalf=0.5d0*ggg2(ll)
7504         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7505         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7506         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7507         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7508         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7509         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7510       enddo
7511 cgrad      do m=i+1,j-1
7512 cgrad        do ll=1,3
7513 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7514 cgrad        enddo
7515 cgrad      enddo
7516 cgrad      do m=k+1,l-1
7517 cgrad        do ll=1,3
7518 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7519 cgrad        enddo
7520 cgrad      enddo
7521 cgrad      do m=i+2,j2
7522 cgrad        do ll=1,3
7523 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7524 cgrad        enddo
7525 cgrad      enddo
7526 cgrad      do m=k+2,l2
7527 cgrad        do ll=1,3
7528 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7529 cgrad        enddo
7530 cgrad      enddo
7531 cd      do iii=1,nres-3
7532 cd        write (2,*) iii,gcorr_loc(iii)
7533 cd      enddo
7534       eello4=ekont*eel4
7535 cd      write (2,*) 'ekont',ekont
7536 cd      write (iout,*) 'eello4',ekont*eel4
7537       return
7538       end
7539 C---------------------------------------------------------------------------
7540       double precision function eello5(i,j,k,l,jj,kk)
7541       implicit real*8 (a-h,o-z)
7542       include 'DIMENSIONS'
7543       include 'COMMON.IOUNITS'
7544       include 'COMMON.CHAIN'
7545       include 'COMMON.DERIV'
7546       include 'COMMON.INTERACT'
7547       include 'COMMON.CONTACTS'
7548       include 'COMMON.TORSION'
7549       include 'COMMON.VAR'
7550       include 'COMMON.GEO'
7551       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7552       double precision ggg1(3),ggg2(3)
7553 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7554 C                                                                              C
7555 C                            Parallel chains                                   C
7556 C                                                                              C
7557 C          o             o                   o             o                   C
7558 C         /l\           / \             \   / \           / \   /              C
7559 C        /   \         /   \             \ /   \         /   \ /               C
7560 C       j| o |l1       | o |              o| o |         | o |o                C
7561 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7562 C      \i/   \         /   \ /             /   \         /   \                 C
7563 C       o    k1             o                                                  C
7564 C         (I)          (II)                (III)          (IV)                 C
7565 C                                                                              C
7566 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7567 C                                                                              C
7568 C                            Antiparallel chains                               C
7569 C                                                                              C
7570 C          o             o                   o             o                   C
7571 C         /j\           / \             \   / \           / \   /              C
7572 C        /   \         /   \             \ /   \         /   \ /               C
7573 C      j1| o |l        | o |              o| o |         | o |o                C
7574 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7575 C      \i/   \         /   \ /             /   \         /   \                 C
7576 C       o     k1            o                                                  C
7577 C         (I)          (II)                (III)          (IV)                 C
7578 C                                                                              C
7579 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7580 C                                                                              C
7581 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7582 C                                                                              C
7583 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7584 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7585 cd        eello5=0.0d0
7586 cd        return
7587 cd      endif
7588 cd      write (iout,*)
7589 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7590 cd     &   ' and',k,l
7591       itk=itortyp(itype(k))
7592       itl=itortyp(itype(l))
7593       itj=itortyp(itype(j))
7594       eello5_1=0.0d0
7595       eello5_2=0.0d0
7596       eello5_3=0.0d0
7597       eello5_4=0.0d0
7598 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7599 cd     &   eel5_3_num,eel5_4_num)
7600       do iii=1,2
7601         do kkk=1,5
7602           do lll=1,3
7603             derx(lll,kkk,iii)=0.0d0
7604           enddo
7605         enddo
7606       enddo
7607 cd      eij=facont_hb(jj,i)
7608 cd      ekl=facont_hb(kk,k)
7609 cd      ekont=eij*ekl
7610 cd      write (iout,*)'Contacts have occurred for peptide groups',
7611 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7612 cd      goto 1111
7613 C Contribution from the graph I.
7614 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7615 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7616       call transpose2(EUg(1,1,k),auxmat(1,1))
7617       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7618       vv(1)=pizda(1,1)-pizda(2,2)
7619       vv(2)=pizda(1,2)+pizda(2,1)
7620       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7621      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7622 C Explicit gradient in virtual-dihedral angles.
7623       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7624      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7625      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7626       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7627       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7628       vv(1)=pizda(1,1)-pizda(2,2)
7629       vv(2)=pizda(1,2)+pizda(2,1)
7630       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7631      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7632      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7633       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7634       vv(1)=pizda(1,1)-pizda(2,2)
7635       vv(2)=pizda(1,2)+pizda(2,1)
7636       if (l.eq.j+1) then
7637         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7638      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7639      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7640       else
7641         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7642      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7643      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7644       endif
7645 C Cartesian gradient
7646       do iii=1,2
7647         do kkk=1,5
7648           do lll=1,3
7649             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7650      &        pizda(1,1))
7651             vv(1)=pizda(1,1)-pizda(2,2)
7652             vv(2)=pizda(1,2)+pizda(2,1)
7653             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7654      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7655      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7656           enddo
7657         enddo
7658       enddo
7659 c      goto 1112
7660 c1111  continue
7661 C Contribution from graph II
7662       call transpose2(EE(1,1,itk),auxmat(1,1))
7663       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7664       vv(1)=pizda(1,1)+pizda(2,2)
7665       vv(2)=pizda(2,1)-pizda(1,2)
7666       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7667      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7668 C Explicit gradient in virtual-dihedral angles.
7669       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7670      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7671       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7672       vv(1)=pizda(1,1)+pizda(2,2)
7673       vv(2)=pizda(2,1)-pizda(1,2)
7674       if (l.eq.j+1) then
7675         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7676      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7677      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7678       else
7679         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7680      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7681      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7682       endif
7683 C Cartesian gradient
7684       do iii=1,2
7685         do kkk=1,5
7686           do lll=1,3
7687             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7688      &        pizda(1,1))
7689             vv(1)=pizda(1,1)+pizda(2,2)
7690             vv(2)=pizda(2,1)-pizda(1,2)
7691             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7692      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7693      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7694           enddo
7695         enddo
7696       enddo
7697 cd      goto 1112
7698 cd1111  continue
7699       if (l.eq.j+1) then
7700 cd        goto 1110
7701 C Parallel orientation
7702 C Contribution from graph III
7703         call transpose2(EUg(1,1,l),auxmat(1,1))
7704         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7705         vv(1)=pizda(1,1)-pizda(2,2)
7706         vv(2)=pizda(1,2)+pizda(2,1)
7707         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7708      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7709 C Explicit gradient in virtual-dihedral angles.
7710         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7711      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7712      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7713         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7714         vv(1)=pizda(1,1)-pizda(2,2)
7715         vv(2)=pizda(1,2)+pizda(2,1)
7716         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7717      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7718      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7719         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7720         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7721         vv(1)=pizda(1,1)-pizda(2,2)
7722         vv(2)=pizda(1,2)+pizda(2,1)
7723         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7724      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7725      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7726 C Cartesian gradient
7727         do iii=1,2
7728           do kkk=1,5
7729             do lll=1,3
7730               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7731      &          pizda(1,1))
7732               vv(1)=pizda(1,1)-pizda(2,2)
7733               vv(2)=pizda(1,2)+pizda(2,1)
7734               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7735      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7736      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7737             enddo
7738           enddo
7739         enddo
7740 cd        goto 1112
7741 C Contribution from graph IV
7742 cd1110    continue
7743         call transpose2(EE(1,1,itl),auxmat(1,1))
7744         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7745         vv(1)=pizda(1,1)+pizda(2,2)
7746         vv(2)=pizda(2,1)-pizda(1,2)
7747         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7748      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7749 C Explicit gradient in virtual-dihedral angles.
7750         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7751      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7752         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7753         vv(1)=pizda(1,1)+pizda(2,2)
7754         vv(2)=pizda(2,1)-pizda(1,2)
7755         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7756      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7757      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7758 C Cartesian gradient
7759         do iii=1,2
7760           do kkk=1,5
7761             do lll=1,3
7762               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7763      &          pizda(1,1))
7764               vv(1)=pizda(1,1)+pizda(2,2)
7765               vv(2)=pizda(2,1)-pizda(1,2)
7766               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7767      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7768      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7769             enddo
7770           enddo
7771         enddo
7772       else
7773 C Antiparallel orientation
7774 C Contribution from graph III
7775 c        goto 1110
7776         call transpose2(EUg(1,1,j),auxmat(1,1))
7777         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7778         vv(1)=pizda(1,1)-pizda(2,2)
7779         vv(2)=pizda(1,2)+pizda(2,1)
7780         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7781      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7782 C Explicit gradient in virtual-dihedral angles.
7783         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7784      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7785      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7786         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7787         vv(1)=pizda(1,1)-pizda(2,2)
7788         vv(2)=pizda(1,2)+pizda(2,1)
7789         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7790      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7791      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7792         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7793         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7794         vv(1)=pizda(1,1)-pizda(2,2)
7795         vv(2)=pizda(1,2)+pizda(2,1)
7796         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7797      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7798      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7799 C Cartesian gradient
7800         do iii=1,2
7801           do kkk=1,5
7802             do lll=1,3
7803               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7804      &          pizda(1,1))
7805               vv(1)=pizda(1,1)-pizda(2,2)
7806               vv(2)=pizda(1,2)+pizda(2,1)
7807               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7808      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7809      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7810             enddo
7811           enddo
7812         enddo
7813 cd        goto 1112
7814 C Contribution from graph IV
7815 1110    continue
7816         call transpose2(EE(1,1,itj),auxmat(1,1))
7817         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7818         vv(1)=pizda(1,1)+pizda(2,2)
7819         vv(2)=pizda(2,1)-pizda(1,2)
7820         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7821      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7822 C Explicit gradient in virtual-dihedral angles.
7823         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7824      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7825         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7826         vv(1)=pizda(1,1)+pizda(2,2)
7827         vv(2)=pizda(2,1)-pizda(1,2)
7828         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7829      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7830      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7831 C Cartesian gradient
7832         do iii=1,2
7833           do kkk=1,5
7834             do lll=1,3
7835               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7836      &          pizda(1,1))
7837               vv(1)=pizda(1,1)+pizda(2,2)
7838               vv(2)=pizda(2,1)-pizda(1,2)
7839               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7840      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7841      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7842             enddo
7843           enddo
7844         enddo
7845       endif
7846 1112  continue
7847       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7848 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7849 cd        write (2,*) 'ijkl',i,j,k,l
7850 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7851 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7852 cd      endif
7853 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7854 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7855 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7856 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7857       if (j.lt.nres-1) then
7858         j1=j+1
7859         j2=j-1
7860       else
7861         j1=j-1
7862         j2=j-2
7863       endif
7864       if (l.lt.nres-1) then
7865         l1=l+1
7866         l2=l-1
7867       else
7868         l1=l-1
7869         l2=l-2
7870       endif
7871 cd      eij=1.0d0
7872 cd      ekl=1.0d0
7873 cd      ekont=1.0d0
7874 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7875 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7876 C        summed up outside the subrouine as for the other subroutines
7877 C        handling long-range interactions. The old code is commented out
7878 C        with "cgrad" to keep track of changes.
7879       do ll=1,3
7880 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7881 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7882         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7883         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7884 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7885 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7886 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7887 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7888 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7889 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7890 c     &   gradcorr5ij,
7891 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7892 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7893 cgrad        ghalf=0.5d0*ggg1(ll)
7894 cd        ghalf=0.0d0
7895         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7896         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7897         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7898         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7899         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7900         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7901 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7902 cgrad        ghalf=0.5d0*ggg2(ll)
7903 cd        ghalf=0.0d0
7904         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7905         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7906         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7907         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7908         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7909         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7910       enddo
7911 cd      goto 1112
7912 cgrad      do m=i+1,j-1
7913 cgrad        do ll=1,3
7914 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7915 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7916 cgrad        enddo
7917 cgrad      enddo
7918 cgrad      do m=k+1,l-1
7919 cgrad        do ll=1,3
7920 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7921 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7922 cgrad        enddo
7923 cgrad      enddo
7924 c1112  continue
7925 cgrad      do m=i+2,j2
7926 cgrad        do ll=1,3
7927 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7928 cgrad        enddo
7929 cgrad      enddo
7930 cgrad      do m=k+2,l2
7931 cgrad        do ll=1,3
7932 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7933 cgrad        enddo
7934 cgrad      enddo
7935 cd      do iii=1,nres-3
7936 cd        write (2,*) iii,g_corr5_loc(iii)
7937 cd      enddo
7938       eello5=ekont*eel5
7939 cd      write (2,*) 'ekont',ekont
7940 cd      write (iout,*) 'eello5',ekont*eel5
7941       return
7942       end
7943 c--------------------------------------------------------------------------
7944       double precision function eello6(i,j,k,l,jj,kk)
7945       implicit real*8 (a-h,o-z)
7946       include 'DIMENSIONS'
7947       include 'COMMON.IOUNITS'
7948       include 'COMMON.CHAIN'
7949       include 'COMMON.DERIV'
7950       include 'COMMON.INTERACT'
7951       include 'COMMON.CONTACTS'
7952       include 'COMMON.TORSION'
7953       include 'COMMON.VAR'
7954       include 'COMMON.GEO'
7955       include 'COMMON.FFIELD'
7956       double precision ggg1(3),ggg2(3)
7957 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7958 cd        eello6=0.0d0
7959 cd        return
7960 cd      endif
7961 cd      write (iout,*)
7962 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7963 cd     &   ' and',k,l
7964       eello6_1=0.0d0
7965       eello6_2=0.0d0
7966       eello6_3=0.0d0
7967       eello6_4=0.0d0
7968       eello6_5=0.0d0
7969       eello6_6=0.0d0
7970 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7971 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7972       do iii=1,2
7973         do kkk=1,5
7974           do lll=1,3
7975             derx(lll,kkk,iii)=0.0d0
7976           enddo
7977         enddo
7978       enddo
7979 cd      eij=facont_hb(jj,i)
7980 cd      ekl=facont_hb(kk,k)
7981 cd      ekont=eij*ekl
7982 cd      eij=1.0d0
7983 cd      ekl=1.0d0
7984 cd      ekont=1.0d0
7985       if (l.eq.j+1) then
7986         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7987         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7988         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7989         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7990         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7991         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7992       else
7993         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7994         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7995         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7996         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7997         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7998           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7999         else
8000           eello6_5=0.0d0
8001         endif
8002         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8003       endif
8004 C If turn contributions are considered, they will be handled separately.
8005       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8006 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8007 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8008 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8009 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8010 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8011 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8012 cd      goto 1112
8013       if (j.lt.nres-1) then
8014         j1=j+1
8015         j2=j-1
8016       else
8017         j1=j-1
8018         j2=j-2
8019       endif
8020       if (l.lt.nres-1) then
8021         l1=l+1
8022         l2=l-1
8023       else
8024         l1=l-1
8025         l2=l-2
8026       endif
8027       do ll=1,3
8028 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8029 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8030 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8031 cgrad        ghalf=0.5d0*ggg1(ll)
8032 cd        ghalf=0.0d0
8033         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8034         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8035         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8036         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8037         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8038         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8039         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8040         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8041 cgrad        ghalf=0.5d0*ggg2(ll)
8042 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8043 cd        ghalf=0.0d0
8044         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8045         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8046         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8047         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8048         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8049         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8050       enddo
8051 cd      goto 1112
8052 cgrad      do m=i+1,j-1
8053 cgrad        do ll=1,3
8054 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8055 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8056 cgrad        enddo
8057 cgrad      enddo
8058 cgrad      do m=k+1,l-1
8059 cgrad        do ll=1,3
8060 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8061 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8062 cgrad        enddo
8063 cgrad      enddo
8064 cgrad1112  continue
8065 cgrad      do m=i+2,j2
8066 cgrad        do ll=1,3
8067 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8068 cgrad        enddo
8069 cgrad      enddo
8070 cgrad      do m=k+2,l2
8071 cgrad        do ll=1,3
8072 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8073 cgrad        enddo
8074 cgrad      enddo
8075 cd      do iii=1,nres-3
8076 cd        write (2,*) iii,g_corr6_loc(iii)
8077 cd      enddo
8078       eello6=ekont*eel6
8079 cd      write (2,*) 'ekont',ekont
8080 cd      write (iout,*) 'eello6',ekont*eel6
8081       return
8082       end
8083 c--------------------------------------------------------------------------
8084       double precision function eello6_graph1(i,j,k,l,imat,swap)
8085       implicit real*8 (a-h,o-z)
8086       include 'DIMENSIONS'
8087       include 'COMMON.IOUNITS'
8088       include 'COMMON.CHAIN'
8089       include 'COMMON.DERIV'
8090       include 'COMMON.INTERACT'
8091       include 'COMMON.CONTACTS'
8092       include 'COMMON.TORSION'
8093       include 'COMMON.VAR'
8094       include 'COMMON.GEO'
8095       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8096       logical swap
8097       logical lprn
8098       common /kutas/ lprn
8099 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8100 C
8101 C      Parallel       Antiparallel
8102 C
8103 C          o             o
8104 C         /l\           /j\
8105 C        /   \         /   \
8106 C       /| o |         | o |\
8107 C     \ j|/k\|  /   \  |/k\|l /
8108 C      \ /   \ /     \ /   \ /
8109 C       o     o       o     o
8110 C       i             i
8111 C
8112 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8113       itk=itortyp(itype(k))
8114       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8115       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8116       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8117       call transpose2(EUgC(1,1,k),auxmat(1,1))
8118       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8119       vv1(1)=pizda1(1,1)-pizda1(2,2)
8120       vv1(2)=pizda1(1,2)+pizda1(2,1)
8121       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8122       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8123       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8124       s5=scalar2(vv(1),Dtobr2(1,i))
8125 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8126       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8127       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8128      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8129      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8130      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8131      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8132      & +scalar2(vv(1),Dtobr2der(1,i)))
8133       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8134       vv1(1)=pizda1(1,1)-pizda1(2,2)
8135       vv1(2)=pizda1(1,2)+pizda1(2,1)
8136       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8137       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8138       if (l.eq.j+1) then
8139         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8140      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8141      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8142      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8143      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8144       else
8145         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8146      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8147      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8148      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8149      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8150       endif
8151       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8152       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8153       vv1(1)=pizda1(1,1)-pizda1(2,2)
8154       vv1(2)=pizda1(1,2)+pizda1(2,1)
8155       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8156      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8157      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8158      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8159       do iii=1,2
8160         if (swap) then
8161           ind=3-iii
8162         else
8163           ind=iii
8164         endif
8165         do kkk=1,5
8166           do lll=1,3
8167             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8168             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8169             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8170             call transpose2(EUgC(1,1,k),auxmat(1,1))
8171             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8172      &        pizda1(1,1))
8173             vv1(1)=pizda1(1,1)-pizda1(2,2)
8174             vv1(2)=pizda1(1,2)+pizda1(2,1)
8175             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8176             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8177      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8178             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8179      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8180             s5=scalar2(vv(1),Dtobr2(1,i))
8181             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8182           enddo
8183         enddo
8184       enddo
8185       return
8186       end
8187 c----------------------------------------------------------------------------
8188       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8189       implicit real*8 (a-h,o-z)
8190       include 'DIMENSIONS'
8191       include 'COMMON.IOUNITS'
8192       include 'COMMON.CHAIN'
8193       include 'COMMON.DERIV'
8194       include 'COMMON.INTERACT'
8195       include 'COMMON.CONTACTS'
8196       include 'COMMON.TORSION'
8197       include 'COMMON.VAR'
8198       include 'COMMON.GEO'
8199       logical swap
8200       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8201      & auxvec1(2),auxvec2(1),auxmat1(2,2)
8202       logical lprn
8203       common /kutas/ lprn
8204 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8205 C                                                                              C
8206 C      Parallel       Antiparallel                                             C
8207 C                                                                              C
8208 C          o             o                                                     C
8209 C     \   /l\           /j\   /                                                C
8210 C      \ /   \         /   \ /                                                 C
8211 C       o| o |         | o |o                                                  C
8212 C     \ j|/k\|      \  |/k\|l                                                  C
8213 C      \ /   \       \ /   \                                                   C
8214 C       o             o                                                        C
8215 C       i             i                                                        C
8216 C                                                                              C
8217 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8218 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8219 C AL 7/4/01 s1 would occur in the sixth-order moment,
8220 C           but not in a cluster cumulant
8221 #ifdef MOMENT
8222       s1=dip(1,jj,i)*dip(1,kk,k)
8223 #endif
8224       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8225       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8226       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8227       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8228       call transpose2(EUg(1,1,k),auxmat(1,1))
8229       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8230       vv(1)=pizda(1,1)-pizda(2,2)
8231       vv(2)=pizda(1,2)+pizda(2,1)
8232       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8233 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8234 #ifdef MOMENT
8235       eello6_graph2=-(s1+s2+s3+s4)
8236 #else
8237       eello6_graph2=-(s2+s3+s4)
8238 #endif
8239 c      eello6_graph2=-s3
8240 C Derivatives in gamma(i-1)
8241       if (i.gt.1) then
8242 #ifdef MOMENT
8243         s1=dipderg(1,jj,i)*dip(1,kk,k)
8244 #endif
8245         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8246         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8247         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8248         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8249 #ifdef MOMENT
8250         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8251 #else
8252         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8253 #endif
8254 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8255       endif
8256 C Derivatives in gamma(k-1)
8257 #ifdef MOMENT
8258       s1=dip(1,jj,i)*dipderg(1,kk,k)
8259 #endif
8260       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8261       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8262       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8263       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8264       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8265       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8266       vv(1)=pizda(1,1)-pizda(2,2)
8267       vv(2)=pizda(1,2)+pizda(2,1)
8268       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8269 #ifdef MOMENT
8270       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8271 #else
8272       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8273 #endif
8274 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8275 C Derivatives in gamma(j-1) or gamma(l-1)
8276       if (j.gt.1) then
8277 #ifdef MOMENT
8278         s1=dipderg(3,jj,i)*dip(1,kk,k)
8279 #endif
8280         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8281         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8282         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8283         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8284         vv(1)=pizda(1,1)-pizda(2,2)
8285         vv(2)=pizda(1,2)+pizda(2,1)
8286         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8287 #ifdef MOMENT
8288         if (swap) then
8289           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8290         else
8291           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8292         endif
8293 #endif
8294         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8295 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8296       endif
8297 C Derivatives in gamma(l-1) or gamma(j-1)
8298       if (l.gt.1) then
8299 #ifdef MOMENT
8300         s1=dip(1,jj,i)*dipderg(3,kk,k)
8301 #endif
8302         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8303         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8304         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8305         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8306         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8307         vv(1)=pizda(1,1)-pizda(2,2)
8308         vv(2)=pizda(1,2)+pizda(2,1)
8309         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8310 #ifdef MOMENT
8311         if (swap) then
8312           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8313         else
8314           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8315         endif
8316 #endif
8317         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8318 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8319       endif
8320 C Cartesian derivatives.
8321       if (lprn) then
8322         write (2,*) 'In eello6_graph2'
8323         do iii=1,2
8324           write (2,*) 'iii=',iii
8325           do kkk=1,5
8326             write (2,*) 'kkk=',kkk
8327             do jjj=1,2
8328               write (2,'(3(2f10.5),5x)')
8329      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8330             enddo
8331           enddo
8332         enddo
8333       endif
8334       do iii=1,2
8335         do kkk=1,5
8336           do lll=1,3
8337 #ifdef MOMENT
8338             if (iii.eq.1) then
8339               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8340             else
8341               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8342             endif
8343 #endif
8344             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8345      &        auxvec(1))
8346             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8347             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8348      &        auxvec(1))
8349             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8350             call transpose2(EUg(1,1,k),auxmat(1,1))
8351             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8352      &        pizda(1,1))
8353             vv(1)=pizda(1,1)-pizda(2,2)
8354             vv(2)=pizda(1,2)+pizda(2,1)
8355             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8356 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8357 #ifdef MOMENT
8358             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8359 #else
8360             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8361 #endif
8362             if (swap) then
8363               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8364             else
8365               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8366             endif
8367           enddo
8368         enddo
8369       enddo
8370       return
8371       end
8372 c----------------------------------------------------------------------------
8373       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8374       implicit real*8 (a-h,o-z)
8375       include 'DIMENSIONS'
8376       include 'COMMON.IOUNITS'
8377       include 'COMMON.CHAIN'
8378       include 'COMMON.DERIV'
8379       include 'COMMON.INTERACT'
8380       include 'COMMON.CONTACTS'
8381       include 'COMMON.TORSION'
8382       include 'COMMON.VAR'
8383       include 'COMMON.GEO'
8384       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8385       logical swap
8386 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8387 C                                                                              C
8388 C      Parallel       Antiparallel                                             C
8389 C                                                                              C
8390 C          o             o                                                     C
8391 C         /l\   /   \   /j\                                                    C
8392 C        /   \ /     \ /   \                                                   C
8393 C       /| o |o       o| o |\                                                  C
8394 C       j|/k\|  /      |/k\|l /                                                C
8395 C        /   \ /       /   \ /                                                 C
8396 C       /     o       /     o                                                  C
8397 C       i             i                                                        C
8398 C                                                                              C
8399 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8400 C
8401 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8402 C           energy moment and not to the cluster cumulant.
8403       iti=itortyp(itype(i))
8404       if (j.lt.nres-1) then
8405         itj1=itortyp(itype(j+1))
8406       else
8407         itj1=ntortyp+1
8408       endif
8409       itk=itortyp(itype(k))
8410       itk1=itortyp(itype(k+1))
8411       if (l.lt.nres-1) then
8412         itl1=itortyp(itype(l+1))
8413       else
8414         itl1=ntortyp+1
8415       endif
8416 #ifdef MOMENT
8417       s1=dip(4,jj,i)*dip(4,kk,k)
8418 #endif
8419       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8420       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8421       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8422       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8423       call transpose2(EE(1,1,itk),auxmat(1,1))
8424       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8425       vv(1)=pizda(1,1)+pizda(2,2)
8426       vv(2)=pizda(2,1)-pizda(1,2)
8427       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8428 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8429 cd     & "sum",-(s2+s3+s4)
8430 #ifdef MOMENT
8431       eello6_graph3=-(s1+s2+s3+s4)
8432 #else
8433       eello6_graph3=-(s2+s3+s4)
8434 #endif
8435 c      eello6_graph3=-s4
8436 C Derivatives in gamma(k-1)
8437       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8438       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8439       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8440       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8441 C Derivatives in gamma(l-1)
8442       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8443       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8444       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8445       vv(1)=pizda(1,1)+pizda(2,2)
8446       vv(2)=pizda(2,1)-pizda(1,2)
8447       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8448       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8449 C Cartesian derivatives.
8450       do iii=1,2
8451         do kkk=1,5
8452           do lll=1,3
8453 #ifdef MOMENT
8454             if (iii.eq.1) then
8455               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8456             else
8457               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8458             endif
8459 #endif
8460             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8461      &        auxvec(1))
8462             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8463             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8464      &        auxvec(1))
8465             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8466             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8467      &        pizda(1,1))
8468             vv(1)=pizda(1,1)+pizda(2,2)
8469             vv(2)=pizda(2,1)-pizda(1,2)
8470             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8471 #ifdef MOMENT
8472             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8473 #else
8474             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8475 #endif
8476             if (swap) then
8477               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8478             else
8479               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8480             endif
8481 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8482           enddo
8483         enddo
8484       enddo
8485       return
8486       end
8487 c----------------------------------------------------------------------------
8488       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8489       implicit real*8 (a-h,o-z)
8490       include 'DIMENSIONS'
8491       include 'COMMON.IOUNITS'
8492       include 'COMMON.CHAIN'
8493       include 'COMMON.DERIV'
8494       include 'COMMON.INTERACT'
8495       include 'COMMON.CONTACTS'
8496       include 'COMMON.TORSION'
8497       include 'COMMON.VAR'
8498       include 'COMMON.GEO'
8499       include 'COMMON.FFIELD'
8500       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8501      & auxvec1(2),auxmat1(2,2)
8502       logical swap
8503 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8504 C                                                                              C
8505 C      Parallel       Antiparallel                                             C
8506 C                                                                              C
8507 C          o             o                                                     C
8508 C         /l\   /   \   /j\                                                    C
8509 C        /   \ /     \ /   \                                                   C
8510 C       /| o |o       o| o |\                                                  C
8511 C     \ j|/k\|      \  |/k\|l                                                  C
8512 C      \ /   \       \ /   \                                                   C
8513 C       o     \       o     \                                                  C
8514 C       i             i                                                        C
8515 C                                                                              C
8516 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8517 C
8518 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8519 C           energy moment and not to the cluster cumulant.
8520 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8521       iti=itortyp(itype(i))
8522       itj=itortyp(itype(j))
8523       if (j.lt.nres-1) then
8524         itj1=itortyp(itype(j+1))
8525       else
8526         itj1=ntortyp+1
8527       endif
8528       itk=itortyp(itype(k))
8529       if (k.lt.nres-1) then
8530         itk1=itortyp(itype(k+1))
8531       else
8532         itk1=ntortyp+1
8533       endif
8534       itl=itortyp(itype(l))
8535       if (l.lt.nres-1) then
8536         itl1=itortyp(itype(l+1))
8537       else
8538         itl1=ntortyp+1
8539       endif
8540 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8541 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8542 cd     & ' itl',itl,' itl1',itl1
8543 #ifdef MOMENT
8544       if (imat.eq.1) then
8545         s1=dip(3,jj,i)*dip(3,kk,k)
8546       else
8547         s1=dip(2,jj,j)*dip(2,kk,l)
8548       endif
8549 #endif
8550       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8551       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8552       if (j.eq.l+1) then
8553         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8554         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8555       else
8556         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8557         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8558       endif
8559       call transpose2(EUg(1,1,k),auxmat(1,1))
8560       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8561       vv(1)=pizda(1,1)-pizda(2,2)
8562       vv(2)=pizda(2,1)+pizda(1,2)
8563       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8564 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8565 #ifdef MOMENT
8566       eello6_graph4=-(s1+s2+s3+s4)
8567 #else
8568       eello6_graph4=-(s2+s3+s4)
8569 #endif
8570 C Derivatives in gamma(i-1)
8571       if (i.gt.1) then
8572 #ifdef MOMENT
8573         if (imat.eq.1) then
8574           s1=dipderg(2,jj,i)*dip(3,kk,k)
8575         else
8576           s1=dipderg(4,jj,j)*dip(2,kk,l)
8577         endif
8578 #endif
8579         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8580         if (j.eq.l+1) then
8581           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8582           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8583         else
8584           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8585           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8586         endif
8587         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8588         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8589 cd          write (2,*) 'turn6 derivatives'
8590 #ifdef MOMENT
8591           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8592 #else
8593           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8594 #endif
8595         else
8596 #ifdef MOMENT
8597           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8598 #else
8599           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8600 #endif
8601         endif
8602       endif
8603 C Derivatives in gamma(k-1)
8604 #ifdef MOMENT
8605       if (imat.eq.1) then
8606         s1=dip(3,jj,i)*dipderg(2,kk,k)
8607       else
8608         s1=dip(2,jj,j)*dipderg(4,kk,l)
8609       endif
8610 #endif
8611       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8612       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8613       if (j.eq.l+1) then
8614         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8615         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8616       else
8617         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8618         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8619       endif
8620       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8621       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8622       vv(1)=pizda(1,1)-pizda(2,2)
8623       vv(2)=pizda(2,1)+pizda(1,2)
8624       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8625       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8626 #ifdef MOMENT
8627         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8628 #else
8629         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8630 #endif
8631       else
8632 #ifdef MOMENT
8633         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8634 #else
8635         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8636 #endif
8637       endif
8638 C Derivatives in gamma(j-1) or gamma(l-1)
8639       if (l.eq.j+1 .and. l.gt.1) then
8640         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8641         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8642         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8643         vv(1)=pizda(1,1)-pizda(2,2)
8644         vv(2)=pizda(2,1)+pizda(1,2)
8645         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8646         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8647       else if (j.gt.1) then
8648         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8649         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8650         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8651         vv(1)=pizda(1,1)-pizda(2,2)
8652         vv(2)=pizda(2,1)+pizda(1,2)
8653         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8654         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8655           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8656         else
8657           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8658         endif
8659       endif
8660 C Cartesian derivatives.
8661       do iii=1,2
8662         do kkk=1,5
8663           do lll=1,3
8664 #ifdef MOMENT
8665             if (iii.eq.1) then
8666               if (imat.eq.1) then
8667                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8668               else
8669                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8670               endif
8671             else
8672               if (imat.eq.1) then
8673                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8674               else
8675                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8676               endif
8677             endif
8678 #endif
8679             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8680      &        auxvec(1))
8681             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8682             if (j.eq.l+1) then
8683               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8684      &          b1(1,itj1),auxvec(1))
8685               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8686             else
8687               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8688      &          b1(1,itl1),auxvec(1))
8689               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8690             endif
8691             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8692      &        pizda(1,1))
8693             vv(1)=pizda(1,1)-pizda(2,2)
8694             vv(2)=pizda(2,1)+pizda(1,2)
8695             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8696             if (swap) then
8697               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8698 #ifdef MOMENT
8699                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8700      &             -(s1+s2+s4)
8701 #else
8702                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8703      &             -(s2+s4)
8704 #endif
8705                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8706               else
8707 #ifdef MOMENT
8708                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8709 #else
8710                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8711 #endif
8712                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8713               endif
8714             else
8715 #ifdef MOMENT
8716               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8717 #else
8718               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8719 #endif
8720               if (l.eq.j+1) then
8721                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8722               else
8723                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8724               endif
8725             endif
8726           enddo
8727         enddo
8728       enddo
8729       return
8730       end
8731 c----------------------------------------------------------------------------
8732       double precision function eello_turn6(i,jj,kk)
8733       implicit real*8 (a-h,o-z)
8734       include 'DIMENSIONS'
8735       include 'COMMON.IOUNITS'
8736       include 'COMMON.CHAIN'
8737       include 'COMMON.DERIV'
8738       include 'COMMON.INTERACT'
8739       include 'COMMON.CONTACTS'
8740       include 'COMMON.TORSION'
8741       include 'COMMON.VAR'
8742       include 'COMMON.GEO'
8743       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8744      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8745      &  ggg1(3),ggg2(3)
8746       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8747      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8748 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8749 C           the respective energy moment and not to the cluster cumulant.
8750       s1=0.0d0
8751       s8=0.0d0
8752       s13=0.0d0
8753 c
8754       eello_turn6=0.0d0
8755       j=i+4
8756       k=i+1
8757       l=i+3
8758       iti=itortyp(itype(i))
8759       itk=itortyp(itype(k))
8760       itk1=itortyp(itype(k+1))
8761       itl=itortyp(itype(l))
8762       itj=itortyp(itype(j))
8763 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8764 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8765 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8766 cd        eello6=0.0d0
8767 cd        return
8768 cd      endif
8769 cd      write (iout,*)
8770 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8771 cd     &   ' and',k,l
8772 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8773       do iii=1,2
8774         do kkk=1,5
8775           do lll=1,3
8776             derx_turn(lll,kkk,iii)=0.0d0
8777           enddo
8778         enddo
8779       enddo
8780 cd      eij=1.0d0
8781 cd      ekl=1.0d0
8782 cd      ekont=1.0d0
8783       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8784 cd      eello6_5=0.0d0
8785 cd      write (2,*) 'eello6_5',eello6_5
8786 #ifdef MOMENT
8787       call transpose2(AEA(1,1,1),auxmat(1,1))
8788       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8789       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8790       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8791 #endif
8792       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8793       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8794       s2 = scalar2(b1(1,itk),vtemp1(1))
8795 #ifdef MOMENT
8796       call transpose2(AEA(1,1,2),atemp(1,1))
8797       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8798       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8799       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8800 #endif
8801       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8802       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8803       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8804 #ifdef MOMENT
8805       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8806       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8807       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8808       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8809       ss13 = scalar2(b1(1,itk),vtemp4(1))
8810       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8811 #endif
8812 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8813 c      s1=0.0d0
8814 c      s2=0.0d0
8815 c      s8=0.0d0
8816 c      s12=0.0d0
8817 c      s13=0.0d0
8818       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8819 C Derivatives in gamma(i+2)
8820       s1d =0.0d0
8821       s8d =0.0d0
8822 #ifdef MOMENT
8823       call transpose2(AEA(1,1,1),auxmatd(1,1))
8824       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8825       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8826       call transpose2(AEAderg(1,1,2),atempd(1,1))
8827       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8828       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8829 #endif
8830       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8831       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8832       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8833 c      s1d=0.0d0
8834 c      s2d=0.0d0
8835 c      s8d=0.0d0
8836 c      s12d=0.0d0
8837 c      s13d=0.0d0
8838       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8839 C Derivatives in gamma(i+3)
8840 #ifdef MOMENT
8841       call transpose2(AEA(1,1,1),auxmatd(1,1))
8842       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8843       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8844       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8845 #endif
8846       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8847       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8848       s2d = scalar2(b1(1,itk),vtemp1d(1))
8849 #ifdef MOMENT
8850       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8851       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8852 #endif
8853       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8854 #ifdef MOMENT
8855       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8856       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8857       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8858 #endif
8859 c      s1d=0.0d0
8860 c      s2d=0.0d0
8861 c      s8d=0.0d0
8862 c      s12d=0.0d0
8863 c      s13d=0.0d0
8864 #ifdef MOMENT
8865       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8866      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8867 #else
8868       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8869      &               -0.5d0*ekont*(s2d+s12d)
8870 #endif
8871 C Derivatives in gamma(i+4)
8872       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8873       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8874       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8875 #ifdef MOMENT
8876       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8877       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8878       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8879 #endif
8880 c      s1d=0.0d0
8881 c      s2d=0.0d0
8882 c      s8d=0.0d0
8883 C      s12d=0.0d0
8884 c      s13d=0.0d0
8885 #ifdef MOMENT
8886       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8887 #else
8888       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8889 #endif
8890 C Derivatives in gamma(i+5)
8891 #ifdef MOMENT
8892       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8893       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8894       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8895 #endif
8896       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8897       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8898       s2d = scalar2(b1(1,itk),vtemp1d(1))
8899 #ifdef MOMENT
8900       call transpose2(AEA(1,1,2),atempd(1,1))
8901       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8902       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8903 #endif
8904       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8905       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8906 #ifdef MOMENT
8907       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8908       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8909       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8910 #endif
8911 c      s1d=0.0d0
8912 c      s2d=0.0d0
8913 c      s8d=0.0d0
8914 c      s12d=0.0d0
8915 c      s13d=0.0d0
8916 #ifdef MOMENT
8917       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8918      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8919 #else
8920       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8921      &               -0.5d0*ekont*(s2d+s12d)
8922 #endif
8923 C Cartesian derivatives
8924       do iii=1,2
8925         do kkk=1,5
8926           do lll=1,3
8927 #ifdef MOMENT
8928             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8929             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8930             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8931 #endif
8932             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8933             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8934      &          vtemp1d(1))
8935             s2d = scalar2(b1(1,itk),vtemp1d(1))
8936 #ifdef MOMENT
8937             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8938             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8939             s8d = -(atempd(1,1)+atempd(2,2))*
8940      &           scalar2(cc(1,1,itl),vtemp2(1))
8941 #endif
8942             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8943      &           auxmatd(1,1))
8944             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8945             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8946 c      s1d=0.0d0
8947 c      s2d=0.0d0
8948 c      s8d=0.0d0
8949 c      s12d=0.0d0
8950 c      s13d=0.0d0
8951 #ifdef MOMENT
8952             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8953      &        - 0.5d0*(s1d+s2d)
8954 #else
8955             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8956      &        - 0.5d0*s2d
8957 #endif
8958 #ifdef MOMENT
8959             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8960      &        - 0.5d0*(s8d+s12d)
8961 #else
8962             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8963      &        - 0.5d0*s12d
8964 #endif
8965           enddo
8966         enddo
8967       enddo
8968 #ifdef MOMENT
8969       do kkk=1,5
8970         do lll=1,3
8971           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8972      &      achuj_tempd(1,1))
8973           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8974           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8975           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8976           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8977           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8978      &      vtemp4d(1))
8979           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8980           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8981           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8982         enddo
8983       enddo
8984 #endif
8985 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8986 cd     &  16*eel_turn6_num
8987 cd      goto 1112
8988       if (j.lt.nres-1) then
8989         j1=j+1
8990         j2=j-1
8991       else
8992         j1=j-1
8993         j2=j-2
8994       endif
8995       if (l.lt.nres-1) then
8996         l1=l+1
8997         l2=l-1
8998       else
8999         l1=l-1
9000         l2=l-2
9001       endif
9002       do ll=1,3
9003 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9004 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9005 cgrad        ghalf=0.5d0*ggg1(ll)
9006 cd        ghalf=0.0d0
9007         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9008         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9009         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9010      &    +ekont*derx_turn(ll,2,1)
9011         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9012         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9013      &    +ekont*derx_turn(ll,4,1)
9014         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9015         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9016         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9017 cgrad        ghalf=0.5d0*ggg2(ll)
9018 cd        ghalf=0.0d0
9019         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9020      &    +ekont*derx_turn(ll,2,2)
9021         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9022         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9023      &    +ekont*derx_turn(ll,4,2)
9024         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9025         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9026         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9027       enddo
9028 cd      goto 1112
9029 cgrad      do m=i+1,j-1
9030 cgrad        do ll=1,3
9031 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9032 cgrad        enddo
9033 cgrad      enddo
9034 cgrad      do m=k+1,l-1
9035 cgrad        do ll=1,3
9036 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9037 cgrad        enddo
9038 cgrad      enddo
9039 cgrad1112  continue
9040 cgrad      do m=i+2,j2
9041 cgrad        do ll=1,3
9042 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9043 cgrad        enddo
9044 cgrad      enddo
9045 cgrad      do m=k+2,l2
9046 cgrad        do ll=1,3
9047 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9048 cgrad        enddo
9049 cgrad      enddo
9050 cd      do iii=1,nres-3
9051 cd        write (2,*) iii,g_corr6_loc(iii)
9052 cd      enddo
9053       eello_turn6=ekont*eel_turn6
9054 cd      write (2,*) 'ekont',ekont
9055 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9056       return
9057       end
9058
9059 C-----------------------------------------------------------------------------
9060       double precision function scalar(u,v)
9061 !DIR$ INLINEALWAYS scalar
9062 #ifndef OSF
9063 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9064 #endif
9065       implicit none
9066       double precision u(3),v(3)
9067 cd      double precision sc
9068 cd      integer i
9069 cd      sc=0.0d0
9070 cd      do i=1,3
9071 cd        sc=sc+u(i)*v(i)
9072 cd      enddo
9073 cd      scalar=sc
9074
9075       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9076       return
9077       end
9078 crc-------------------------------------------------
9079       SUBROUTINE MATVEC2(A1,V1,V2)
9080 !DIR$ INLINEALWAYS MATVEC2
9081 #ifndef OSF
9082 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9083 #endif
9084       implicit real*8 (a-h,o-z)
9085       include 'DIMENSIONS'
9086       DIMENSION A1(2,2),V1(2),V2(2)
9087 c      DO 1 I=1,2
9088 c        VI=0.0
9089 c        DO 3 K=1,2
9090 c    3     VI=VI+A1(I,K)*V1(K)
9091 c        Vaux(I)=VI
9092 c    1 CONTINUE
9093
9094       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9095       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9096
9097       v2(1)=vaux1
9098       v2(2)=vaux2
9099       END
9100 C---------------------------------------
9101       SUBROUTINE MATMAT2(A1,A2,A3)
9102 #ifndef OSF
9103 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9104 #endif
9105       implicit real*8 (a-h,o-z)
9106       include 'DIMENSIONS'
9107       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9108 c      DIMENSION AI3(2,2)
9109 c        DO  J=1,2
9110 c          A3IJ=0.0
9111 c          DO K=1,2
9112 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9113 c          enddo
9114 c          A3(I,J)=A3IJ
9115 c       enddo
9116 c      enddo
9117
9118       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9119       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9120       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9121       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9122
9123       A3(1,1)=AI3_11
9124       A3(2,1)=AI3_21
9125       A3(1,2)=AI3_12
9126       A3(2,2)=AI3_22
9127       END
9128
9129 c-------------------------------------------------------------------------
9130       double precision function scalar2(u,v)
9131 !DIR$ INLINEALWAYS scalar2
9132       implicit none
9133       double precision u(2),v(2)
9134       double precision sc
9135       integer i
9136       scalar2=u(1)*v(1)+u(2)*v(2)
9137       return
9138       end
9139
9140 C-----------------------------------------------------------------------------
9141
9142       subroutine transpose2(a,at)
9143 !DIR$ INLINEALWAYS transpose2
9144 #ifndef OSF
9145 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9146 #endif
9147       implicit none
9148       double precision a(2,2),at(2,2)
9149       at(1,1)=a(1,1)
9150       at(1,2)=a(2,1)
9151       at(2,1)=a(1,2)
9152       at(2,2)=a(2,2)
9153       return
9154       end
9155 c--------------------------------------------------------------------------
9156       subroutine transpose(n,a,at)
9157       implicit none
9158       integer n,i,j
9159       double precision a(n,n),at(n,n)
9160       do i=1,n
9161         do j=1,n
9162           at(j,i)=a(i,j)
9163         enddo
9164       enddo
9165       return
9166       end
9167 C---------------------------------------------------------------------------
9168       subroutine prodmat3(a1,a2,kk,transp,prod)
9169 !DIR$ INLINEALWAYS prodmat3
9170 #ifndef OSF
9171 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9172 #endif
9173       implicit none
9174       integer i,j
9175       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9176       logical transp
9177 crc      double precision auxmat(2,2),prod_(2,2)
9178
9179       if (transp) then
9180 crc        call transpose2(kk(1,1),auxmat(1,1))
9181 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9182 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9183
9184            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9185      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9186            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9187      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9188            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9189      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9190            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9191      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9192
9193       else
9194 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9195 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9196
9197            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9198      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9199            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9200      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9201            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9202      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9203            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9204      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9205
9206       endif
9207 c      call transpose2(a2(1,1),a2t(1,1))
9208
9209 crc      print *,transp
9210 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9211 crc      print *,((prod(i,j),i=1,2),j=1,2)
9212
9213       return
9214       end
9215