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 #ifdef DEBUG
 778       write (iout,*) "gloc_sc before reduce"
 779       do i=1,nres
 780        do j=1,3
 781         write (iout,*) i,j,gloc_sc(j,i,icg)
 782        enddo
 783       enddo
 784 #endif
 785         do i=1,nres
 786          do j=1,3
 787           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 788          enddo
 789         enddo
 790         time00=MPI_Wtime()
 791         call MPI_Barrier(FG_COMM,IERR)
 792         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 793         time00=MPI_Wtime()
 794         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 795      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 796         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 797      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 798         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 799      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 800         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 801      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 802         time_reduce=time_reduce+MPI_Wtime()-time00
 803 #ifdef DEBUG
 804       write (iout,*) "gloc_sc after reduce"
 805       do i=1,nres
 806        do j=1,3
 807         write (iout,*) i,j,gloc_sc(j,i,icg)
 808        enddo
 809       enddo
 810 #endif
 811 #ifdef DEBUG
 812       write (iout,*) "gloc after reduce"
 813       do i=1,4*nres
 814         write (iout,*) i,gloc(i,icg)
 815       enddo
 816 #endif
 817       endif
 818 #endif
 819       if (gnorm_check) then
 820 c
 821 c Compute the maximum elements of the gradient
 822 c
 823       gvdwc_max=0.0d0
 824       gvdwc_scp_max=0.0d0
 825       gelc_max=0.0d0
 826       gvdwpp_max=0.0d0
 827       gradb_max=0.0d0
 828       ghpbc_max=0.0d0
 829       gradcorr_max=0.0d0
 830       gel_loc_max=0.0d0
 831       gcorr3_turn_max=0.0d0
 832       gcorr4_turn_max=0.0d0
 833       gradcorr5_max=0.0d0
 834       gradcorr6_max=0.0d0
 835       gcorr6_turn_max=0.0d0
 836       gsccorc_max=0.0d0
 837       gscloc_max=0.0d0
 838       gvdwx_max=0.0d0
 839       gradx_scp_max=0.0d0
 840       ghpbx_max=0.0d0
 841       gradxorr_max=0.0d0
 842       gsccorx_max=0.0d0
 843       gsclocx_max=0.0d0
 844       do i=1,nct
 845         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 846         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 847 #ifdef TSCSC
 848         gvdwc_norm=dsqrt(scalar(gvdwcT(1,i),gvdwcT(1,i)))
 849         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 850 #endif
 851         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 852         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 853      &   gvdwc_scp_max=gvdwc_scp_norm
 854         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 855         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 856         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 857         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 858         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 859         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 860         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 861         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 862         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 863         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 864         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 865         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 866         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 867      &    gcorr3_turn(1,i)))
 868         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 869      &    gcorr3_turn_max=gcorr3_turn_norm
 870         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 871      &    gcorr4_turn(1,i)))
 872         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 873      &    gcorr4_turn_max=gcorr4_turn_norm
 874         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 875         if (gradcorr5_norm.gt.gradcorr5_max)
 876      &    gradcorr5_max=gradcorr5_norm
 877         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 878         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 879         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 880      &    gcorr6_turn(1,i)))
 881         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 882      &    gcorr6_turn_max=gcorr6_turn_norm
 883         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 884         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 885         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 886         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 887         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 888         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 889 #ifdef TSCSC
 890         gvdwx_norm=dsqrt(scalar(gvdwxT(1,i),gvdwxT(1,i)))
 891         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 892 #endif
 893         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 894         if (gradx_scp_norm.gt.gradx_scp_max)
 895      &    gradx_scp_max=gradx_scp_norm
 896         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 897         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 898         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 899         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 900         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 901         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 902         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 903         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 904       enddo
 905       if (gradout) then
 906 #ifdef AIX
 907         open(istat,file=statname,position="append")
 908 #else
 909         open(istat,file=statname,access="append")
 910 #endif
 911         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 912      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 913      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 914      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 915      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 916      &     gsccorx_max,gsclocx_max
 917         close(istat)
 918         if (gvdwc_max.gt.1.0d4) then
 919           write (iout,*) "gvdwc gvdwx gradb gradbx"
 920           do i=nnt,nct
 921             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 922      &        gradb(j,i),gradbx(j,i),j=1,3)
 923           enddo
 924           call pdbout(0.0d0,'cipiszcze',iout)
 925           call flush(iout)
 926         endif
 927       endif
 928       endif
 929 #ifdef DEBUG
 930       write (iout,*) "gradc gradx gloc"
 931       do i=1,nres
 932         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 933      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 934       enddo
 935 #endif
 936 #ifdef TIMING
 937 #ifdef MPI
 938       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 939 #else
 940       time_sumgradient=time_sumgradient+tcpu()-time01
 941 #endif
 942 #endif
 943       return
 944       end
 945 c-------------------------------------------------------------------------------
 946       subroutine rescale_weights(t_bath)
 947       implicit real*8 (a-h,o-z)
 948       include 'DIMENSIONS'
 949       include 'COMMON.IOUNITS'
 950       include 'COMMON.FFIELD'
 951       include 'COMMON.SBRIDGE'
 952       double precision kfac /2.4d0/
 953       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 954 c      facT=temp0/t_bath
 955 c      facT=2*temp0/(t_bath+temp0)
 956       if (rescale_mode.eq.0) then
 957         facT=1.0d0
 958         facT2=1.0d0
 959         facT3=1.0d0
 960         facT4=1.0d0
 961         facT5=1.0d0
 962       else if (rescale_mode.eq.1) then
 963         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 964         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 965         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 966         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 967         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 968       else if (rescale_mode.eq.2) then
 969         x=t_bath/temp0
 970         x2=x*x
 971         x3=x2*x
 972         x4=x3*x
 973         x5=x4*x
 974         facT=licznik/dlog(dexp(x)+dexp(-x))
 975         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 976         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 977         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 978         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 979       else
 980         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 981         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 982 #ifdef MPI
 983        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 984 #endif
 985        stop 555
 986       endif
 987       welec=weights(3)*fact
 988       wcorr=weights(4)*fact3
 989       wcorr5=weights(5)*fact4
 990       wcorr6=weights(6)*fact5
 991       wel_loc=weights(7)*fact2
 992       wturn3=weights(8)*fact2
 993       wturn4=weights(9)*fact3
 994       wturn6=weights(10)*fact5
 995       wtor=weights(13)*fact
 996       wtor_d=weights(14)*fact2
 997       wsccor=weights(21)*fact
 998 #ifdef TSCSC
 999 c      wsct=t_bath/temp0
1000       wsct=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
1001 #endif
1002       return
1003       end
1004 C------------------------------------------------------------------------
1005       subroutine enerprint(energia)
1006       implicit real*8 (a-h,o-z)
1007       include 'DIMENSIONS'
1008       include 'COMMON.IOUNITS'
1009       include 'COMMON.FFIELD'
1010       include 'COMMON.SBRIDGE'
1011       include 'COMMON.MD'
1012       double precision energia(0:n_ene)
1013       etot=energia(0)
1014 #ifdef TSCSC
1015       evdw=energia(22)+wsct*energia(23)
1016 #else
1017       evdw=energia(1)
1018 #endif
1019       evdw2=energia(2)
1020 #ifdef SCP14
1021       evdw2=energia(2)+energia(18)
1022 #else
1023       evdw2=energia(2)
1024 #endif
1025       ees=energia(3)
1026 #ifdef SPLITELE
1027       evdw1=energia(16)
1028 #endif
1029       ecorr=energia(4)
1030       ecorr5=energia(5)
1031       ecorr6=energia(6)
1032       eel_loc=energia(7)
1033       eello_turn3=energia(8)
1034       eello_turn4=energia(9)
1035       eello_turn6=energia(10)
1036       ebe=energia(11)
1037       escloc=energia(12)
1038       etors=energia(13)
1039       etors_d=energia(14)
1040       ehpb=energia(15)
1041       edihcnstr=energia(19)
1042       estr=energia(17)
1043       Uconst=energia(20)
1044       esccor=energia(21)
1045 #ifdef SPLITELE
1046       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1047      &  estr,wbond,ebe,wang,
1048      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1049      &  ecorr,wcorr,
1050      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1051      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
1052      &  edihcnstr,ebr*nss,
1053      &  Uconst,etot
1054    10 format (/'Virtual-chain energies:'//
1055      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1056      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1057      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1058      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
1059      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1060      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1061      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1062      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1063      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1064      & 'EHPB=  ',1pE16.6,' WEIGHT=',1pD16.6,
1065      & ' (SS bridges & dist. cnstr.)'/
1066      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1067      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1068      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1069      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1070      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1071      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1072      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1073      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1074      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1075      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1076      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1077      & 'ETOT=  ',1pE16.6,' (total)')
1078 #else
1079       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1080      &  estr,wbond,ebe,wang,
1081      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1082      &  ecorr,wcorr,
1083      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1084      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1085      &  ebr*nss,Uconst,etot
1086    10 format (/'Virtual-chain energies:'//
1087      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1088      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1089      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1090      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1091      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1092      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1093      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1094      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1095      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1096      & ' (SS bridges & dist. cnstr.)'/
1097      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1098      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1099      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1100      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1101      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1102      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1103      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1104      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1105      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1106      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1107      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1108      & 'ETOT=  ',1pE16.6,' (total)')
1109 #endif
1110       return
1111       end
1112 C-----------------------------------------------------------------------
1113       subroutine elj(evdw,evdw_p,evdw_m)
1114 C
1115 C This subroutine calculates the interaction energy of nonbonded side chains
1116 C assuming the LJ potential of interaction.
1117 C
1118       implicit real*8 (a-h,o-z)
1119       include 'DIMENSIONS'
1120       parameter (accur=1.0d-10)
1121       include 'COMMON.GEO'
1122       include 'COMMON.VAR'
1123       include 'COMMON.LOCAL'
1124       include 'COMMON.CHAIN'
1125       include 'COMMON.DERIV'
1126       include 'COMMON.INTERACT'
1127       include 'COMMON.TORSION'
1128       include 'COMMON.SBRIDGE'
1129       include 'COMMON.NAMES'
1130       include 'COMMON.IOUNITS'
1131       include 'COMMON.CONTACTS'
1132       dimension gg(3)
1133 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1134       evdw=0.0D0
1135       do i=iatsc_s,iatsc_e
1136         itypi=itype(i)
1137         itypi1=itype(i+1)
1138         xi=c(1,nres+i)
1139         yi=c(2,nres+i)
1140         zi=c(3,nres+i)
1141 C Change 12/1/95
1142         num_conti=0
1143 C
1144 C Calculate SC interaction energy.
1145 C
1146         do iint=1,nint_gr(i)
1147 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1148 cd   &                  'iend=',iend(i,iint)
1149           do j=istart(i,iint),iend(i,iint)
1150             itypj=itype(j)
1151             xj=c(1,nres+j)-xi
1152             yj=c(2,nres+j)-yi
1153             zj=c(3,nres+j)-zi
1154 C Change 12/1/95 to calculate four-body interactions
1155             rij=xj*xj+yj*yj+zj*zj
1156             rrij=1.0D0/rij
1157 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1158             eps0ij=eps(itypi,itypj)
1159             fac=rrij**expon2
1160             e1=fac*fac*aa(itypi,itypj)
1161             e2=fac*bb(itypi,itypj)
1162             evdwij=e1+e2
1163 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1164 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1165 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1166 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1167 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1168 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1169 #ifdef TSCSC
1170             if (bb(itypi,itypj).gt.0) then
1171                evdw_p=evdw_p+evdwij
1172             else
1173                evdw_m=evdw_m+evdwij
1174             endif
1175 #else
1176             evdw=evdw+evdwij
1177 #endif
1178 C
1179 C Calculate the components of the gradient in DC and X
1180 C
1181             fac=-rrij*(e1+evdwij)
1182             gg(1)=xj*fac
1183             gg(2)=yj*fac
1184             gg(3)=zj*fac
1185 #ifdef TSCSC
1186             if (bb(itypi,itypj).gt.0.0d0) then
1187               do k=1,3
1188                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1189                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1190                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1191                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1192               enddo
1193             else
1194               do k=1,3
1195                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1196                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1197                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1198                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1199               enddo
1200             endif
1201 #else
1202             do k=1,3
1203               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1204               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1205               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1206               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1207             enddo
1208 #endif
1209 cgrad            do k=i,j-1
1210 cgrad              do l=1,3
1211 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1212 cgrad              enddo
1213 cgrad            enddo
1214 C
1215 C 12/1/95, revised on 5/20/97
1216 C
1217 C Calculate the contact function. The ith column of the array JCONT will
1218 C contain the numbers of atoms that make contacts with the atom I (of numbers
1219 C greater than I). The arrays FACONT and GACONT will contain the values of
1220 C the contact function and its derivative.
1221 C
1222 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1223 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1224 C Uncomment next line, if the correlation interactions are contact function only
1225             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1226               rij=dsqrt(rij)
1227               sigij=sigma(itypi,itypj)
1228               r0ij=rs0(itypi,itypj)
1229 C
1230 C Check whether the SC's are not too far to make a contact.
1231 C
1232               rcut=1.5d0*r0ij
1233               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1234 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1235 C
1236               if (fcont.gt.0.0D0) then
1237 C If the SC-SC distance if close to sigma, apply spline.
1238 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1239 cAdam &             fcont1,fprimcont1)
1240 cAdam           fcont1=1.0d0-fcont1
1241 cAdam           if (fcont1.gt.0.0d0) then
1242 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1243 cAdam             fcont=fcont*fcont1
1244 cAdam           endif
1245 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1246 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1247 cga             do k=1,3
1248 cga               gg(k)=gg(k)*eps0ij
1249 cga             enddo
1250 cga             eps0ij=-evdwij*eps0ij
1251 C Uncomment for AL's type of SC correlation interactions.
1252 cadam           eps0ij=-evdwij
1253                 num_conti=num_conti+1
1254                 jcont(num_conti,i)=j
1255                 facont(num_conti,i)=fcont*eps0ij
1256                 fprimcont=eps0ij*fprimcont/rij
1257                 fcont=expon*fcont
1258 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1259 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1260 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1261 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1262                 gacont(1,num_conti,i)=-fprimcont*xj
1263                 gacont(2,num_conti,i)=-fprimcont*yj
1264                 gacont(3,num_conti,i)=-fprimcont*zj
1265 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1266 cd              write (iout,'(2i3,3f10.5)')
1267 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1268               endif
1269             endif
1270           enddo      ! j
1271         enddo        ! iint
1272 C Change 12/1/95
1273         num_cont(i)=num_conti
1274       enddo          ! i
1275       do i=1,nct
1276         do j=1,3
1277           gvdwc(j,i)=expon*gvdwc(j,i)
1278           gvdwx(j,i)=expon*gvdwx(j,i)
1279         enddo
1280       enddo
1281 C******************************************************************************
1282 C
1283 C                              N O T E !!!
1284 C
1285 C To save time, the factor of EXPON has been extracted from ALL components
1286 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1287 C use!
1288 C
1289 C******************************************************************************
1290       return
1291       end
1292 C-----------------------------------------------------------------------------
1293       subroutine eljk(evdw,evdw_p,evdw_m)
1294 C
1295 C This subroutine calculates the interaction energy of nonbonded side chains
1296 C assuming the LJK potential of interaction.
1297 C
1298       implicit real*8 (a-h,o-z)
1299       include 'DIMENSIONS'
1300       include 'COMMON.GEO'
1301       include 'COMMON.VAR'
1302       include 'COMMON.LOCAL'
1303       include 'COMMON.CHAIN'
1304       include 'COMMON.DERIV'
1305       include 'COMMON.INTERACT'
1306       include 'COMMON.IOUNITS'
1307       include 'COMMON.NAMES'
1308       dimension gg(3)
1309       logical scheck
1310 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1311       evdw=0.0D0
1312       do i=iatsc_s,iatsc_e
1313         itypi=itype(i)
1314         itypi1=itype(i+1)
1315         xi=c(1,nres+i)
1316         yi=c(2,nres+i)
1317         zi=c(3,nres+i)
1318 C
1319 C Calculate SC interaction energy.
1320 C
1321         do iint=1,nint_gr(i)
1322           do j=istart(i,iint),iend(i,iint)
1323             itypj=itype(j)
1324             xj=c(1,nres+j)-xi
1325             yj=c(2,nres+j)-yi
1326             zj=c(3,nres+j)-zi
1327             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1328             fac_augm=rrij**expon
1329             e_augm=augm(itypi,itypj)*fac_augm
1330             r_inv_ij=dsqrt(rrij)
1331             rij=1.0D0/r_inv_ij
1332             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1333             fac=r_shift_inv**expon
1334             e1=fac*fac*aa(itypi,itypj)
1335             e2=fac*bb(itypi,itypj)
1336             evdwij=e_augm+e1+e2
1337 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1338 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1339 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1340 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1341 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1342 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1343 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1344 #ifdef TSCSC
1345             if (bb(itypi,itypj).gt.0) then
1346                evdw_p=evdw_p+evdwij
1347             else
1348                evdw_m=evdw_m+evdwij
1349             endif
1350 #else
1351             evdw=evdw+evdwij
1352 #endif
1353 C
1354 C Calculate the components of the gradient in DC and X
1355 C
1356             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1357             gg(1)=xj*fac
1358             gg(2)=yj*fac
1359             gg(3)=zj*fac
1360 #ifdef TSCSC
1361             if (bb(itypi,itypj).gt.0.0d0) then
1362               do k=1,3
1363                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1364                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1365                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1366                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1367               enddo
1368             else
1369               do k=1,3
1370                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1371                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1372                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1373                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1374               enddo
1375             endif
1376 #else
1377             do k=1,3
1378               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1379               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1380               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1381               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1382             enddo
1383 #endif
1384 cgrad            do k=i,j-1
1385 cgrad              do l=1,3
1386 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1387 cgrad              enddo
1388 cgrad            enddo
1389           enddo      ! j
1390         enddo        ! iint
1391       enddo          ! i
1392       do i=1,nct
1393         do j=1,3
1394           gvdwc(j,i)=expon*gvdwc(j,i)
1395           gvdwx(j,i)=expon*gvdwx(j,i)
1396         enddo
1397       enddo
1398       return
1399       end
1400 C-----------------------------------------------------------------------------
1401       subroutine ebp(evdw,evdw_p,evdw_m)
1402 C
1403 C This subroutine calculates the interaction energy of nonbonded side chains
1404 C assuming the Berne-Pechukas potential of interaction.
1405 C
1406       implicit real*8 (a-h,o-z)
1407       include 'DIMENSIONS'
1408       include 'COMMON.GEO'
1409       include 'COMMON.VAR'
1410       include 'COMMON.LOCAL'
1411       include 'COMMON.CHAIN'
1412       include 'COMMON.DERIV'
1413       include 'COMMON.NAMES'
1414       include 'COMMON.INTERACT'
1415       include 'COMMON.IOUNITS'
1416       include 'COMMON.CALC'
1417       common /srutu/ icall
1418 c     double precision rrsave(maxdim)
1419       logical lprn
1420       evdw=0.0D0
1421 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1422       evdw=0.0D0
1423 c     if (icall.eq.0) then
1424 c       lprn=.true.
1425 c     else
1426         lprn=.false.
1427 c     endif
1428       ind=0
1429       do i=iatsc_s,iatsc_e
1430         itypi=itype(i)
1431         itypi1=itype(i+1)
1432         xi=c(1,nres+i)
1433         yi=c(2,nres+i)
1434         zi=c(3,nres+i)
1435         dxi=dc_norm(1,nres+i)
1436         dyi=dc_norm(2,nres+i)
1437         dzi=dc_norm(3,nres+i)
1438 c        dsci_inv=dsc_inv(itypi)
1439         dsci_inv=vbld_inv(i+nres)
1440 C
1441 C Calculate SC interaction energy.
1442 C
1443         do iint=1,nint_gr(i)
1444           do j=istart(i,iint),iend(i,iint)
1445             ind=ind+1
1446             itypj=itype(j)
1447 c            dscj_inv=dsc_inv(itypj)
1448             dscj_inv=vbld_inv(j+nres)
1449             chi1=chi(itypi,itypj)
1450             chi2=chi(itypj,itypi)
1451             chi12=chi1*chi2
1452             chip1=chip(itypi)
1453             chip2=chip(itypj)
1454             chip12=chip1*chip2
1455             alf1=alp(itypi)
1456             alf2=alp(itypj)
1457             alf12=0.5D0*(alf1+alf2)
1458 C For diagnostics only!!!
1459 c           chi1=0.0D0
1460 c           chi2=0.0D0
1461 c           chi12=0.0D0
1462 c           chip1=0.0D0
1463 c           chip2=0.0D0
1464 c           chip12=0.0D0
1465 c           alf1=0.0D0
1466 c           alf2=0.0D0
1467 c           alf12=0.0D0
1468             xj=c(1,nres+j)-xi
1469             yj=c(2,nres+j)-yi
1470             zj=c(3,nres+j)-zi
1471             dxj=dc_norm(1,nres+j)
1472             dyj=dc_norm(2,nres+j)
1473             dzj=dc_norm(3,nres+j)
1474             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1475 cd          if (icall.eq.0) then
1476 cd            rrsave(ind)=rrij
1477 cd          else
1478 cd            rrij=rrsave(ind)
1479 cd          endif
1480             rij=dsqrt(rrij)
1481 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1482             call sc_angular
1483 C Calculate whole angle-dependent part of epsilon and contributions
1484 C to its derivatives
1485             fac=(rrij*sigsq)**expon2
1486             e1=fac*fac*aa(itypi,itypj)
1487             e2=fac*bb(itypi,itypj)
1488             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1489             eps2der=evdwij*eps3rt
1490             eps3der=evdwij*eps2rt
1491             evdwij=evdwij*eps2rt*eps3rt
1492 #ifdef TSCSC
1493             if (bb(itypi,itypj).gt.0) then
1494                evdw_p=evdw_p+evdwij
1495             else
1496                evdw_m=evdw_m+evdwij
1497             endif
1498 #else
1499             evdw=evdw+evdwij
1500 #endif
1501             if (lprn) then
1502             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1503             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1504 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1505 cd     &        restyp(itypi),i,restyp(itypj),j,
1506 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1507 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1508 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1509 cd     &        evdwij
1510             endif
1511 C Calculate gradient components.
1512             e1=e1*eps1*eps2rt**2*eps3rt**2
1513             fac=-expon*(e1+evdwij)
1514             sigder=fac/sigsq
1515             fac=rrij*fac
1516 C Calculate radial part of the gradient
1517             gg(1)=xj*fac
1518             gg(2)=yj*fac
1519             gg(3)=zj*fac
1520 C Calculate the angular part of the gradient and sum add the contributions
1521 C to the appropriate components of the Cartesian gradient.
1522 #ifdef TSCSC
1523             if (bb(itypi,itypj).gt.0) then
1524                call sc_grad
1525             else
1526                call sc_grad_T
1527             endif
1528 #else
1529             call sc_grad
1530 #endif
1531           enddo      ! j
1532         enddo        ! iint
1533       enddo          ! i
1534 c     stop
1535       return
1536       end
1537 C-----------------------------------------------------------------------------
1538       subroutine egb(evdw,evdw_p,evdw_m)
1539 C
1540 C This subroutine calculates the interaction energy of nonbonded side chains
1541 C assuming the Gay-Berne potential of interaction.
1542 C
1543       implicit real*8 (a-h,o-z)
1544       include 'DIMENSIONS'
1545       include 'COMMON.GEO'
1546       include 'COMMON.VAR'
1547       include 'COMMON.LOCAL'
1548       include 'COMMON.CHAIN'
1549       include 'COMMON.DERIV'
1550       include 'COMMON.NAMES'
1551       include 'COMMON.INTERACT'
1552       include 'COMMON.IOUNITS'
1553       include 'COMMON.CALC'
1554       include 'COMMON.CONTROL'
1555       logical lprn
1556       evdw=0.0D0
1557 ccccc      energy_dec=.false.
1558 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1559       evdw=0.0D0
1560       evdw_p=0.0D0
1561       evdw_m=0.0D0
1562       lprn=.false.
1563 c     if (icall.eq.0) lprn=.false.
1564       ind=0
1565       do i=iatsc_s,iatsc_e
1566         itypi=itype(i)
1567         itypi1=itype(i+1)
1568         xi=c(1,nres+i)
1569         yi=c(2,nres+i)
1570         zi=c(3,nres+i)
1571         dxi=dc_norm(1,nres+i)
1572         dyi=dc_norm(2,nres+i)
1573         dzi=dc_norm(3,nres+i)
1574 c        dsci_inv=dsc_inv(itypi)
1575         dsci_inv=vbld_inv(i+nres)
1576 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1577 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1578 C
1579 C Calculate SC interaction energy.
1580 C
1581         do iint=1,nint_gr(i)
1582           do j=istart(i,iint),iend(i,iint)
1583             ind=ind+1
1584             itypj=itype(j)
1585 c            dscj_inv=dsc_inv(itypj)
1586             dscj_inv=vbld_inv(j+nres)
1587 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1588 c     &       1.0d0/vbld(j+nres)
1589 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1590             sig0ij=sigma(itypi,itypj)
1591             chi1=chi(itypi,itypj)
1592             chi2=chi(itypj,itypi)
1593             chi12=chi1*chi2
1594             chip1=chip(itypi)
1595             chip2=chip(itypj)
1596             chip12=chip1*chip2
1597             alf1=alp(itypi)
1598             alf2=alp(itypj)
1599             alf12=0.5D0*(alf1+alf2)
1600 C For diagnostics only!!!
1601 c           chi1=0.0D0
1602 c           chi2=0.0D0
1603 c           chi12=0.0D0
1604 c           chip1=0.0D0
1605 c           chip2=0.0D0
1606 c           chip12=0.0D0
1607 c           alf1=0.0D0
1608 c           alf2=0.0D0
1609 c           alf12=0.0D0
1610             xj=c(1,nres+j)-xi
1611             yj=c(2,nres+j)-yi
1612             zj=c(3,nres+j)-zi
1613             dxj=dc_norm(1,nres+j)
1614             dyj=dc_norm(2,nres+j)
1615             dzj=dc_norm(3,nres+j)
1616 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1617 c            write (iout,*) "j",j," dc_norm",
1618 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1619             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1620             rij=dsqrt(rrij)
1621 C Calculate angle-dependent terms of energy and contributions to their
1622 C derivatives.
1623             call sc_angular
1624             sigsq=1.0D0/sigsq
1625             sig=sig0ij*dsqrt(sigsq)
1626             rij_shift=1.0D0/rij-sig+sig0ij
1627 c for diagnostics; uncomment
1628 c            rij_shift=1.2*sig0ij
1629 C I hate to put IF's in the loops, but here don't have another choice!!!!
1630             if (rij_shift.le.0.0D0) then
1631               evdw=1.0D20
1632 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1633 cd     &        restyp(itypi),i,restyp(itypj),j,
1634 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1635               return
1636             endif
1637             sigder=-sig*sigsq
1638 c---------------------------------------------------------------
1639             rij_shift=1.0D0/rij_shift
1640             fac=rij_shift**expon
1641             e1=fac*fac*aa(itypi,itypj)
1642             e2=fac*bb(itypi,itypj)
1643             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1644             eps2der=evdwij*eps3rt
1645             eps3der=evdwij*eps2rt
1646 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1647 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1648             evdwij=evdwij*eps2rt*eps3rt
1649 #ifdef TSCSC
1650             if (bb(itypi,itypj).gt.0) then
1651                evdw_p=evdw_p+evdwij
1652             else
1653                evdw_m=evdw_m+evdwij
1654             endif
1655 #else
1656             evdw=evdw+evdwij
1657 #endif
1658             if (lprn) then
1659             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1660             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1661             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1662      &        restyp(itypi),i,restyp(itypj),j,
1663      &        epsi,sigm,chi1,chi2,chip1,chip2,
1664      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1665      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1666      &        evdwij
1667             endif
1668
1669             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1670      &                        'evdw',i,j,evdwij
1671
1672 C Calculate gradient components.
1673             e1=e1*eps1*eps2rt**2*eps3rt**2
1674             fac=-expon*(e1+evdwij)*rij_shift
1675             sigder=fac*sigder
1676             fac=rij*fac
1677 c            fac=0.0d0
1678 C Calculate the radial part of the gradient
1679             gg(1)=xj*fac
1680             gg(2)=yj*fac
1681             gg(3)=zj*fac
1682 C Calculate angular part of the gradient.
1683 #ifdef TSCSC
1684             if (bb(itypi,itypj).gt.0) then
1685                call sc_grad
1686             else
1687                call sc_grad_T
1688             endif
1689 #else
1690             call sc_grad
1691 #endif
1692           enddo      ! j
1693         enddo        ! iint
1694       enddo          ! i
1695 c      write (iout,*) "Number of loop steps in EGB:",ind
1696 cccc      energy_dec=.false.
1697       return
1698       end
1699 C-----------------------------------------------------------------------------
1700       subroutine egbv(evdw,evdw_p,evdw_m)
1701 C
1702 C This subroutine calculates the interaction energy of nonbonded side chains
1703 C assuming the Gay-Berne-Vorobjev potential of interaction.
1704 C
1705       implicit real*8 (a-h,o-z)
1706       include 'DIMENSIONS'
1707       include 'COMMON.GEO'
1708       include 'COMMON.VAR'
1709       include 'COMMON.LOCAL'
1710       include 'COMMON.CHAIN'
1711       include 'COMMON.DERIV'
1712       include 'COMMON.NAMES'
1713       include 'COMMON.INTERACT'
1714       include 'COMMON.IOUNITS'
1715       include 'COMMON.CALC'
1716       common /srutu/ icall
1717       logical lprn
1718       evdw=0.0D0
1719 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1720       evdw=0.0D0
1721       lprn=.false.
1722 c     if (icall.eq.0) lprn=.true.
1723       ind=0
1724       do i=iatsc_s,iatsc_e
1725         itypi=itype(i)
1726         itypi1=itype(i+1)
1727         xi=c(1,nres+i)
1728         yi=c(2,nres+i)
1729         zi=c(3,nres+i)
1730         dxi=dc_norm(1,nres+i)
1731         dyi=dc_norm(2,nres+i)
1732         dzi=dc_norm(3,nres+i)
1733 c        dsci_inv=dsc_inv(itypi)
1734         dsci_inv=vbld_inv(i+nres)
1735 C
1736 C Calculate SC interaction energy.
1737 C
1738         do iint=1,nint_gr(i)
1739           do j=istart(i,iint),iend(i,iint)
1740             ind=ind+1
1741             itypj=itype(j)
1742 c            dscj_inv=dsc_inv(itypj)
1743             dscj_inv=vbld_inv(j+nres)
1744             sig0ij=sigma(itypi,itypj)
1745             r0ij=r0(itypi,itypj)
1746             chi1=chi(itypi,itypj)
1747             chi2=chi(itypj,itypi)
1748             chi12=chi1*chi2
1749             chip1=chip(itypi)
1750             chip2=chip(itypj)
1751             chip12=chip1*chip2
1752             alf1=alp(itypi)
1753             alf2=alp(itypj)
1754             alf12=0.5D0*(alf1+alf2)
1755 C For diagnostics only!!!
1756 c           chi1=0.0D0
1757 c           chi2=0.0D0
1758 c           chi12=0.0D0
1759 c           chip1=0.0D0
1760 c           chip2=0.0D0
1761 c           chip12=0.0D0
1762 c           alf1=0.0D0
1763 c           alf2=0.0D0
1764 c           alf12=0.0D0
1765             xj=c(1,nres+j)-xi
1766             yj=c(2,nres+j)-yi
1767             zj=c(3,nres+j)-zi
1768             dxj=dc_norm(1,nres+j)
1769             dyj=dc_norm(2,nres+j)
1770             dzj=dc_norm(3,nres+j)
1771             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1772             rij=dsqrt(rrij)
1773 C Calculate angle-dependent terms of energy and contributions to their
1774 C derivatives.
1775             call sc_angular
1776             sigsq=1.0D0/sigsq
1777             sig=sig0ij*dsqrt(sigsq)
1778             rij_shift=1.0D0/rij-sig+r0ij
1779 C I hate to put IF's in the loops, but here don't have another choice!!!!
1780             if (rij_shift.le.0.0D0) then
1781               evdw=1.0D20
1782               return
1783             endif
1784             sigder=-sig*sigsq
1785 c---------------------------------------------------------------
1786             rij_shift=1.0D0/rij_shift
1787             fac=rij_shift**expon
1788             e1=fac*fac*aa(itypi,itypj)
1789             e2=fac*bb(itypi,itypj)
1790             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1791             eps2der=evdwij*eps3rt
1792             eps3der=evdwij*eps2rt
1793             fac_augm=rrij**expon
1794             e_augm=augm(itypi,itypj)*fac_augm
1795             evdwij=evdwij*eps2rt*eps3rt
1796 #ifdef TSCSC
1797             if (bb(itypi,itypj).gt.0) then
1798                evdw_p=evdw_p+evdwij+e_augm
1799             else
1800                evdw_m=evdw_m+evdwij+e_augm
1801             endif
1802 #else
1803             evdw=evdw+evdwij+e_augm
1804 #endif
1805             if (lprn) then
1806             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1807             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1808             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1809      &        restyp(itypi),i,restyp(itypj),j,
1810      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1811      &        chi1,chi2,chip1,chip2,
1812      &        eps1,eps2rt**2,eps3rt**2,
1813      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1814      &        evdwij+e_augm
1815             endif
1816 C Calculate gradient components.
1817             e1=e1*eps1*eps2rt**2*eps3rt**2
1818             fac=-expon*(e1+evdwij)*rij_shift
1819             sigder=fac*sigder
1820             fac=rij*fac-2*expon*rrij*e_augm
1821 C Calculate the radial part of the gradient
1822             gg(1)=xj*fac
1823             gg(2)=yj*fac
1824             gg(3)=zj*fac
1825 C Calculate angular part of the gradient.
1826 #ifdef TSCSC
1827             if (bb(itypi,itypj).gt.0) then
1828                call sc_grad
1829             else
1830                call sc_grad_T
1831             endif
1832 #else
1833             call sc_grad
1834 #endif
1835           enddo      ! j
1836         enddo        ! iint
1837       enddo          ! i
1838       end
1839 C-----------------------------------------------------------------------------
1840       subroutine sc_angular
1841 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1842 C om12. Called by ebp, egb, and egbv.
1843       implicit none
1844       include 'COMMON.CALC'
1845       include 'COMMON.IOUNITS'
1846       erij(1)=xj*rij
1847       erij(2)=yj*rij
1848       erij(3)=zj*rij
1849       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1850       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1851       om12=dxi*dxj+dyi*dyj+dzi*dzj
1852       chiom12=chi12*om12
1853 C Calculate eps1(om12) and its derivative in om12
1854       faceps1=1.0D0-om12*chiom12
1855       faceps1_inv=1.0D0/faceps1
1856       eps1=dsqrt(faceps1_inv)
1857 C Following variable is eps1*deps1/dom12
1858       eps1_om12=faceps1_inv*chiom12
1859 c diagnostics only
1860 c      faceps1_inv=om12
1861 c      eps1=om12
1862 c      eps1_om12=1.0d0
1863 c      write (iout,*) "om12",om12," eps1",eps1
1864 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1865 C and om12.
1866       om1om2=om1*om2
1867       chiom1=chi1*om1
1868       chiom2=chi2*om2
1869       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1870       sigsq=1.0D0-facsig*faceps1_inv
1871       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1872       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1873       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1874 c diagnostics only
1875 c      sigsq=1.0d0
1876 c      sigsq_om1=0.0d0
1877 c      sigsq_om2=0.0d0
1878 c      sigsq_om12=0.0d0
1879 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1880 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1881 c     &    " eps1",eps1
1882 C Calculate eps2 and its derivatives in om1, om2, and om12.
1883       chipom1=chip1*om1
1884       chipom2=chip2*om2
1885       chipom12=chip12*om12
1886       facp=1.0D0-om12*chipom12
1887       facp_inv=1.0D0/facp
1888       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1889 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1890 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1891 C Following variable is the square root of eps2
1892       eps2rt=1.0D0-facp1*facp_inv
1893 C Following three variables are the derivatives of the square root of eps
1894 C in om1, om2, and om12.
1895       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1896       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1897       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1898 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1899       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1900 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1901 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1902 c     &  " eps2rt_om12",eps2rt_om12
1903 C Calculate whole angle-dependent part of epsilon and contributions
1904 C to its derivatives
1905       return
1906       end
1907
1908 C----------------------------------------------------------------------------
1909       subroutine sc_grad_T
1910       implicit real*8 (a-h,o-z)
1911       include 'DIMENSIONS'
1912       include 'COMMON.CHAIN'
1913       include 'COMMON.DERIV'
1914       include 'COMMON.CALC'
1915       include 'COMMON.IOUNITS'
1916       double precision dcosom1(3),dcosom2(3)
1917       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1918       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1919       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1920      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1921 c diagnostics only
1922 c      eom1=0.0d0
1923 c      eom2=0.0d0
1924 c      eom12=evdwij*eps1_om12
1925 c end diagnostics
1926 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1927 c     &  " sigder",sigder
1928 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1929 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1930       do k=1,3
1931         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1932         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1933       enddo
1934       do k=1,3
1935         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1936       enddo
1937 c      write (iout,*) "gg",(gg(k),k=1,3)
1938       do k=1,3
1939         gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1940      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1941      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1942         gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1943      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1944      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1945 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1946 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1947 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1948 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1949       enddo
1950 C
1951 C Calculate the components of the gradient in DC and X
1952 C
1953 cgrad      do k=i,j-1
1954 cgrad        do l=1,3
1955 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1956 cgrad        enddo
1957 cgrad      enddo
1958       do l=1,3
1959         gvdwcT(l,i)=gvdwcT(l,i)-gg(l)
1960         gvdwcT(l,j)=gvdwcT(l,j)+gg(l)
1961       enddo
1962       return
1963       end
1964
1965 C----------------------------------------------------------------------------
1966       subroutine sc_grad
1967       implicit real*8 (a-h,o-z)
1968       include 'DIMENSIONS'
1969       include 'COMMON.CHAIN'
1970       include 'COMMON.DERIV'
1971       include 'COMMON.CALC'
1972       include 'COMMON.IOUNITS'
1973       double precision dcosom1(3),dcosom2(3)
1974       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1975       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1976       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1977      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1978 c diagnostics only
1979 c      eom1=0.0d0
1980 c      eom2=0.0d0
1981 c      eom12=evdwij*eps1_om12
1982 c end diagnostics
1983 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1984 c     &  " sigder",sigder
1985 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1986 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1987       do k=1,3
1988         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1989         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1990       enddo
1991       do k=1,3
1992         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1993       enddo
1994 c      write (iout,*) "gg",(gg(k),k=1,3)
1995       do k=1,3
1996         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1997      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1998      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1999         gvdwx(k,j)=gvdwx(k,j)+gg(k)
2000      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2001      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2002 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2003 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2004 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2005 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2006       enddo
2007 C
2008 C Calculate the components of the gradient in DC and X
2009 C
2010 cgrad      do k=i,j-1
2011 cgrad        do l=1,3
2012 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2013 cgrad        enddo
2014 cgrad      enddo
2015       do l=1,3
2016         gvdwc(l,i)=gvdwc(l,i)-gg(l)
2017         gvdwc(l,j)=gvdwc(l,j)+gg(l)
2018       enddo
2019       return
2020       end
2021 C-----------------------------------------------------------------------
2022       subroutine e_softsphere(evdw)
2023 C
2024 C This subroutine calculates the interaction energy of nonbonded side chains
2025 C assuming the LJ potential of interaction.
2026 C
2027       implicit real*8 (a-h,o-z)
2028       include 'DIMENSIONS'
2029       parameter (accur=1.0d-10)
2030       include 'COMMON.GEO'
2031       include 'COMMON.VAR'
2032       include 'COMMON.LOCAL'
2033       include 'COMMON.CHAIN'
2034       include 'COMMON.DERIV'
2035       include 'COMMON.INTERACT'
2036       include 'COMMON.TORSION'
2037       include 'COMMON.SBRIDGE'
2038       include 'COMMON.NAMES'
2039       include 'COMMON.IOUNITS'
2040       include 'COMMON.CONTACTS'
2041       dimension gg(3)
2042 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2043       evdw=0.0D0
2044       do i=iatsc_s,iatsc_e
2045         itypi=itype(i)
2046         itypi1=itype(i+1)
2047         xi=c(1,nres+i)
2048         yi=c(2,nres+i)
2049         zi=c(3,nres+i)
2050 C
2051 C Calculate SC interaction energy.
2052 C
2053         do iint=1,nint_gr(i)
2054 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2055 cd   &                  'iend=',iend(i,iint)
2056           do j=istart(i,iint),iend(i,iint)
2057             itypj=itype(j)
2058             xj=c(1,nres+j)-xi
2059             yj=c(2,nres+j)-yi
2060             zj=c(3,nres+j)-zi
2061             rij=xj*xj+yj*yj+zj*zj
2062 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2063             r0ij=r0(itypi,itypj)
2064             r0ijsq=r0ij*r0ij
2065 c            print *,i,j,r0ij,dsqrt(rij)
2066             if (rij.lt.r0ijsq) then
2067               evdwij=0.25d0*(rij-r0ijsq)**2
2068               fac=rij-r0ijsq
2069             else
2070               evdwij=0.0d0
2071               fac=0.0d0
2072             endif
2073             evdw=evdw+evdwij
2074 C
2075 C Calculate the components of the gradient in DC and X
2076 C
2077             gg(1)=xj*fac
2078             gg(2)=yj*fac
2079             gg(3)=zj*fac
2080             do k=1,3
2081               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2082               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2083               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2084               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2085             enddo
2086 cgrad            do k=i,j-1
2087 cgrad              do l=1,3
2088 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2089 cgrad              enddo
2090 cgrad            enddo
2091           enddo ! j
2092         enddo ! iint
2093       enddo ! i
2094       return
2095       end
2096 C--------------------------------------------------------------------------
2097       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2098      &              eello_turn4)
2099 C
2100 C Soft-sphere potential of p-p interaction
2101 C
2102       implicit real*8 (a-h,o-z)
2103       include 'DIMENSIONS'
2104       include 'COMMON.CONTROL'
2105       include 'COMMON.IOUNITS'
2106       include 'COMMON.GEO'
2107       include 'COMMON.VAR'
2108       include 'COMMON.LOCAL'
2109       include 'COMMON.CHAIN'
2110       include 'COMMON.DERIV'
2111       include 'COMMON.INTERACT'
2112       include 'COMMON.CONTACTS'
2113       include 'COMMON.TORSION'
2114       include 'COMMON.VECTORS'
2115       include 'COMMON.FFIELD'
2116       dimension ggg(3)
2117 cd      write(iout,*) 'In EELEC_soft_sphere'
2118       ees=0.0D0
2119       evdw1=0.0D0
2120       eel_loc=0.0d0
2121       eello_turn3=0.0d0
2122       eello_turn4=0.0d0
2123       ind=0
2124       do i=iatel_s,iatel_e
2125         dxi=dc(1,i)
2126         dyi=dc(2,i)
2127         dzi=dc(3,i)
2128         xmedi=c(1,i)+0.5d0*dxi
2129         ymedi=c(2,i)+0.5d0*dyi
2130         zmedi=c(3,i)+0.5d0*dzi
2131         num_conti=0
2132 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2133         do j=ielstart(i),ielend(i)
2134           ind=ind+1
2135           iteli=itel(i)
2136           itelj=itel(j)
2137           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2138           r0ij=rpp(iteli,itelj)
2139           r0ijsq=r0ij*r0ij
2140           dxj=dc(1,j)
2141           dyj=dc(2,j)
2142           dzj=dc(3,j)
2143           xj=c(1,j)+0.5D0*dxj-xmedi
2144           yj=c(2,j)+0.5D0*dyj-ymedi
2145           zj=c(3,j)+0.5D0*dzj-zmedi
2146           rij=xj*xj+yj*yj+zj*zj
2147           if (rij.lt.r0ijsq) then
2148             evdw1ij=0.25d0*(rij-r0ijsq)**2
2149             fac=rij-r0ijsq
2150           else
2151             evdw1ij=0.0d0
2152             fac=0.0d0
2153           endif
2154           evdw1=evdw1+evdw1ij
2155 C
2156 C Calculate contributions to the Cartesian gradient.
2157 C
2158           ggg(1)=fac*xj
2159           ggg(2)=fac*yj
2160           ggg(3)=fac*zj
2161           do k=1,3
2162             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2163             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2164           enddo
2165 *
2166 * Loop over residues i+1 thru j-1.
2167 *
2168 cgrad          do k=i+1,j-1
2169 cgrad            do l=1,3
2170 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2171 cgrad            enddo
2172 cgrad          enddo
2173         enddo ! j
2174       enddo   ! i
2175 cgrad      do i=nnt,nct-1
2176 cgrad        do k=1,3
2177 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2178 cgrad        enddo
2179 cgrad        do j=i+1,nct-1
2180 cgrad          do k=1,3
2181 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2182 cgrad          enddo
2183 cgrad        enddo
2184 cgrad      enddo
2185       return
2186       end
2187 c------------------------------------------------------------------------------
2188       subroutine vec_and_deriv
2189       implicit real*8 (a-h,o-z)
2190       include 'DIMENSIONS'
2191 #ifdef MPI
2192       include 'mpif.h'
2193 #endif
2194       include 'COMMON.IOUNITS'
2195       include 'COMMON.GEO'
2196       include 'COMMON.VAR'
2197       include 'COMMON.LOCAL'
2198       include 'COMMON.CHAIN'
2199       include 'COMMON.VECTORS'
2200       include 'COMMON.SETUP'
2201       include 'COMMON.TIME1'
2202       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2203 C Compute the local reference systems. For reference system (i), the
2204 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2205 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2206 #ifdef PARVEC
2207       do i=ivec_start,ivec_end
2208 #else
2209       do i=1,nres-1
2210 #endif
2211           if (i.eq.nres-1) then
2212 C Case of the last full residue
2213 C Compute the Z-axis
2214             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2215             costh=dcos(pi-theta(nres))
2216             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2217             do k=1,3
2218               uz(k,i)=fac*uz(k,i)
2219             enddo
2220 C Compute the derivatives of uz
2221             uzder(1,1,1)= 0.0d0
2222             uzder(2,1,1)=-dc_norm(3,i-1)
2223             uzder(3,1,1)= dc_norm(2,i-1)
2224             uzder(1,2,1)= dc_norm(3,i-1)
2225             uzder(2,2,1)= 0.0d0
2226             uzder(3,2,1)=-dc_norm(1,i-1)
2227             uzder(1,3,1)=-dc_norm(2,i-1)
2228             uzder(2,3,1)= dc_norm(1,i-1)
2229             uzder(3,3,1)= 0.0d0
2230             uzder(1,1,2)= 0.0d0
2231             uzder(2,1,2)= dc_norm(3,i)
2232             uzder(3,1,2)=-dc_norm(2,i)
2233             uzder(1,2,2)=-dc_norm(3,i)
2234             uzder(2,2,2)= 0.0d0
2235             uzder(3,2,2)= dc_norm(1,i)
2236             uzder(1,3,2)= dc_norm(2,i)
2237             uzder(2,3,2)=-dc_norm(1,i)
2238             uzder(3,3,2)= 0.0d0
2239 C Compute the Y-axis
2240             facy=fac
2241             do k=1,3
2242               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2243             enddo
2244 C Compute the derivatives of uy
2245             do j=1,3
2246               do k=1,3
2247                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2248      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2249                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2250               enddo
2251               uyder(j,j,1)=uyder(j,j,1)-costh
2252               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2253             enddo
2254             do j=1,2
2255               do k=1,3
2256                 do l=1,3
2257                   uygrad(l,k,j,i)=uyder(l,k,j)
2258                   uzgrad(l,k,j,i)=uzder(l,k,j)
2259                 enddo
2260               enddo
2261             enddo
2262             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2263             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2264             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2265             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2266           else
2267 C Other residues
2268 C Compute the Z-axis
2269             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2270             costh=dcos(pi-theta(i+2))
2271             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2272             do k=1,3
2273               uz(k,i)=fac*uz(k,i)
2274             enddo
2275 C Compute the derivatives of uz
2276             uzder(1,1,1)= 0.0d0
2277             uzder(2,1,1)=-dc_norm(3,i+1)
2278             uzder(3,1,1)= dc_norm(2,i+1)
2279             uzder(1,2,1)= dc_norm(3,i+1)
2280             uzder(2,2,1)= 0.0d0
2281             uzder(3,2,1)=-dc_norm(1,i+1)
2282             uzder(1,3,1)=-dc_norm(2,i+1)
2283             uzder(2,3,1)= dc_norm(1,i+1)
2284             uzder(3,3,1)= 0.0d0
2285             uzder(1,1,2)= 0.0d0
2286             uzder(2,1,2)= dc_norm(3,i)
2287             uzder(3,1,2)=-dc_norm(2,i)
2288             uzder(1,2,2)=-dc_norm(3,i)
2289             uzder(2,2,2)= 0.0d0
2290             uzder(3,2,2)= dc_norm(1,i)
2291             uzder(1,3,2)= dc_norm(2,i)
2292             uzder(2,3,2)=-dc_norm(1,i)
2293             uzder(3,3,2)= 0.0d0
2294 C Compute the Y-axis
2295             facy=fac
2296             do k=1,3
2297               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2298             enddo
2299 C Compute the derivatives of uy
2300             do j=1,3
2301               do k=1,3
2302                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2303      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2304                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2305               enddo
2306               uyder(j,j,1)=uyder(j,j,1)-costh
2307               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2308             enddo
2309             do j=1,2
2310               do k=1,3
2311                 do l=1,3
2312                   uygrad(l,k,j,i)=uyder(l,k,j)
2313                   uzgrad(l,k,j,i)=uzder(l,k,j)
2314                 enddo
2315               enddo
2316             enddo
2317             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2318             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2319             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2320             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2321           endif
2322       enddo
2323       do i=1,nres-1
2324         vbld_inv_temp(1)=vbld_inv(i+1)
2325         if (i.lt.nres-1) then
2326           vbld_inv_temp(2)=vbld_inv(i+2)
2327           else
2328           vbld_inv_temp(2)=vbld_inv(i)
2329           endif
2330         do j=1,2
2331           do k=1,3
2332             do l=1,3
2333               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2334               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2335             enddo
2336           enddo
2337         enddo
2338       enddo
2339 #if defined(PARVEC) && defined(MPI)
2340       if (nfgtasks1.gt.1) then
2341         time00=MPI_Wtime()
2342 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2343 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2344 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2345         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2346      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2347      &   FG_COMM1,IERR)
2348         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2349      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2350      &   FG_COMM1,IERR)
2351         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2352      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2353      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2354         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2355      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2356      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2357         time_gather=time_gather+MPI_Wtime()-time00
2358       endif
2359 c      if (fg_rank.eq.0) then
2360 c        write (iout,*) "Arrays UY and UZ"
2361 c        do i=1,nres-1
2362 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2363 c     &     (uz(k,i),k=1,3)
2364 c        enddo
2365 c      endif
2366 #endif
2367       return
2368       end
2369 C-----------------------------------------------------------------------------
2370       subroutine check_vecgrad
2371       implicit real*8 (a-h,o-z)
2372       include 'DIMENSIONS'
2373       include 'COMMON.IOUNITS'
2374       include 'COMMON.GEO'
2375       include 'COMMON.VAR'
2376       include 'COMMON.LOCAL'
2377       include 'COMMON.CHAIN'
2378       include 'COMMON.VECTORS'
2379       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2380       dimension uyt(3,maxres),uzt(3,maxres)
2381       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2382       double precision delta /1.0d-7/
2383       call vec_and_deriv
2384 cd      do i=1,nres
2385 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2386 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2387 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2388 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2389 cd     &     (dc_norm(if90,i),if90=1,3)
2390 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2391 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2392 cd          write(iout,'(a)')
2393 cd      enddo
2394       do i=1,nres
2395         do j=1,2
2396           do k=1,3
2397             do l=1,3
2398               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2399               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2400             enddo
2401           enddo
2402         enddo
2403       enddo
2404       call vec_and_deriv
2405       do i=1,nres
2406         do j=1,3
2407           uyt(j,i)=uy(j,i)
2408           uzt(j,i)=uz(j,i)
2409         enddo
2410       enddo
2411       do i=1,nres
2412 cd        write (iout,*) 'i=',i
2413         do k=1,3
2414           erij(k)=dc_norm(k,i)
2415         enddo
2416         do j=1,3
2417           do k=1,3
2418             dc_norm(k,i)=erij(k)
2419           enddo
2420           dc_norm(j,i)=dc_norm(j,i)+delta
2421 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2422 c          do k=1,3
2423 c            dc_norm(k,i)=dc_norm(k,i)/fac
2424 c          enddo
2425 c          write (iout,*) (dc_norm(k,i),k=1,3)
2426 c          write (iout,*) (erij(k),k=1,3)
2427           call vec_and_deriv
2428           do k=1,3
2429             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2430             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2431             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2432             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2433           enddo
2434 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2435 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2436 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2437         enddo
2438         do k=1,3
2439           dc_norm(k,i)=erij(k)
2440         enddo
2441 cd        do k=1,3
2442 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2443 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2444 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2445 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2446 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2447 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2448 cd          write (iout,'(a)')
2449 cd        enddo
2450       enddo
2451       return
2452       end
2453 C--------------------------------------------------------------------------
2454       subroutine set_matrices
2455       implicit real*8 (a-h,o-z)
2456       include 'DIMENSIONS'
2457 #ifdef MPI
2458       include "mpif.h"
2459       include "COMMON.SETUP"
2460       integer IERR
2461       integer status(MPI_STATUS_SIZE)
2462 #endif
2463       include 'COMMON.IOUNITS'
2464       include 'COMMON.GEO'
2465       include 'COMMON.VAR'
2466       include 'COMMON.LOCAL'
2467       include 'COMMON.CHAIN'
2468       include 'COMMON.DERIV'
2469       include 'COMMON.INTERACT'
2470       include 'COMMON.CONTACTS'
2471       include 'COMMON.TORSION'
2472       include 'COMMON.VECTORS'
2473       include 'COMMON.FFIELD'
2474       double precision auxvec(2),auxmat(2,2)
2475 C
2476 C Compute the virtual-bond-torsional-angle dependent quantities needed
2477 C to calculate the el-loc multibody terms of various order.
2478 C
2479 #ifdef PARMAT
2480       do i=ivec_start+2,ivec_end+2
2481 #else
2482       do i=3,nres+1
2483 #endif
2484         if (i .lt. nres+1) then
2485           sin1=dsin(phi(i))
2486           cos1=dcos(phi(i))
2487           sintab(i-2)=sin1
2488           costab(i-2)=cos1
2489           obrot(1,i-2)=cos1
2490           obrot(2,i-2)=sin1
2491           sin2=dsin(2*phi(i))
2492           cos2=dcos(2*phi(i))
2493           sintab2(i-2)=sin2
2494           costab2(i-2)=cos2
2495           obrot2(1,i-2)=cos2
2496           obrot2(2,i-2)=sin2
2497           Ug(1,1,i-2)=-cos1
2498           Ug(1,2,i-2)=-sin1
2499           Ug(2,1,i-2)=-sin1
2500           Ug(2,2,i-2)= cos1
2501           Ug2(1,1,i-2)=-cos2
2502           Ug2(1,2,i-2)=-sin2
2503           Ug2(2,1,i-2)=-sin2
2504           Ug2(2,2,i-2)= cos2
2505         else
2506           costab(i-2)=1.0d0
2507           sintab(i-2)=0.0d0
2508           obrot(1,i-2)=1.0d0
2509           obrot(2,i-2)=0.0d0
2510           obrot2(1,i-2)=0.0d0
2511           obrot2(2,i-2)=0.0d0
2512           Ug(1,1,i-2)=1.0d0
2513           Ug(1,2,i-2)=0.0d0
2514           Ug(2,1,i-2)=0.0d0
2515           Ug(2,2,i-2)=1.0d0
2516           Ug2(1,1,i-2)=0.0d0
2517           Ug2(1,2,i-2)=0.0d0
2518           Ug2(2,1,i-2)=0.0d0
2519           Ug2(2,2,i-2)=0.0d0
2520         endif
2521         if (i .gt. 3 .and. i .lt. nres+1) then
2522           obrot_der(1,i-2)=-sin1
2523           obrot_der(2,i-2)= cos1
2524           Ugder(1,1,i-2)= sin1
2525           Ugder(1,2,i-2)=-cos1
2526           Ugder(2,1,i-2)=-cos1
2527           Ugder(2,2,i-2)=-sin1
2528           dwacos2=cos2+cos2
2529           dwasin2=sin2+sin2
2530           obrot2_der(1,i-2)=-dwasin2
2531           obrot2_der(2,i-2)= dwacos2
2532           Ug2der(1,1,i-2)= dwasin2
2533           Ug2der(1,2,i-2)=-dwacos2
2534           Ug2der(2,1,i-2)=-dwacos2
2535           Ug2der(2,2,i-2)=-dwasin2
2536         else
2537           obrot_der(1,i-2)=0.0d0
2538           obrot_der(2,i-2)=0.0d0
2539           Ugder(1,1,i-2)=0.0d0
2540           Ugder(1,2,i-2)=0.0d0
2541           Ugder(2,1,i-2)=0.0d0
2542           Ugder(2,2,i-2)=0.0d0
2543           obrot2_der(1,i-2)=0.0d0
2544           obrot2_der(2,i-2)=0.0d0
2545           Ug2der(1,1,i-2)=0.0d0
2546           Ug2der(1,2,i-2)=0.0d0
2547           Ug2der(2,1,i-2)=0.0d0
2548           Ug2der(2,2,i-2)=0.0d0
2549         endif
2550 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2551         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2552           iti = itortyp(itype(i-2))
2553         else
2554           iti=ntortyp+1
2555         endif
2556 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2557         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2558           iti1 = itortyp(itype(i-1))
2559         else
2560           iti1=ntortyp+1
2561         endif
2562 cd        write (iout,*) '*******i',i,' iti1',iti
2563 cd        write (iout,*) 'b1',b1(:,iti)
2564 cd        write (iout,*) 'b2',b2(:,iti)
2565 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2566 c        if (i .gt. iatel_s+2) then
2567         if (i .gt. nnt+2) then
2568           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2569           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2570           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2571      &    then
2572           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2573           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2574           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2575           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2576           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2577           endif
2578         else
2579           do k=1,2
2580             Ub2(k,i-2)=0.0d0
2581             Ctobr(k,i-2)=0.0d0
2582             Dtobr2(k,i-2)=0.0d0
2583             do l=1,2
2584               EUg(l,k,i-2)=0.0d0
2585               CUg(l,k,i-2)=0.0d0
2586               DUg(l,k,i-2)=0.0d0
2587               DtUg2(l,k,i-2)=0.0d0
2588             enddo
2589           enddo
2590         endif
2591         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2592         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2593         do k=1,2
2594           muder(k,i-2)=Ub2der(k,i-2)
2595         enddo
2596 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2597         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2598           iti1 = itortyp(itype(i-1))
2599         else
2600           iti1=ntortyp+1
2601         endif
2602         do k=1,2
2603           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2604         enddo
2605 cd        write (iout,*) 'mu ',mu(:,i-2)
2606 cd        write (iout,*) 'mu1',mu1(:,i-2)
2607 cd        write (iout,*) 'mu2',mu2(:,i-2)
2608         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2609      &  then
2610         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2611         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2612         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2613         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2614         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2615 C Vectors and matrices dependent on a single virtual-bond dihedral.
2616         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2617         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2618         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2619         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2620         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2621         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2622         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2623         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2624         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2625         endif
2626       enddo
2627 C Matrices dependent on two consecutive virtual-bond dihedrals.
2628 C The order of matrices is from left to right.
2629       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2630      &then
2631 c      do i=max0(ivec_start,2),ivec_end
2632       do i=2,nres-1
2633         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2634         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2635         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2636         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2637         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2638         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2639         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2640         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2641       enddo
2642       endif
2643 #if defined(MPI) && defined(PARMAT)
2644 #ifdef DEBUG
2645 c      if (fg_rank.eq.0) then
2646         write (iout,*) "Arrays UG and UGDER before GATHER"
2647         do i=1,nres-1
2648           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2649      &     ((ug(l,k,i),l=1,2),k=1,2),
2650      &     ((ugder(l,k,i),l=1,2),k=1,2)
2651         enddo
2652         write (iout,*) "Arrays UG2 and UG2DER"
2653         do i=1,nres-1
2654           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2655      &     ((ug2(l,k,i),l=1,2),k=1,2),
2656      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2657         enddo
2658         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2659         do i=1,nres-1
2660           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2661      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2662      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2663         enddo
2664         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2665         do i=1,nres-1
2666           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2667      &     costab(i),sintab(i),costab2(i),sintab2(i)
2668         enddo
2669         write (iout,*) "Array MUDER"
2670         do i=1,nres-1
2671           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2672         enddo
2673 c      endif
2674 #endif
2675       if (nfgtasks.gt.1) then
2676         time00=MPI_Wtime()
2677 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2678 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2679 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2680 #ifdef MATGATHER
2681         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2682      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2683      &   FG_COMM1,IERR)
2684         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2685      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2686      &   FG_COMM1,IERR)
2687         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2688      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2689      &   FG_COMM1,IERR)
2690         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2691      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2692      &   FG_COMM1,IERR)
2693         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2694      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2695      &   FG_COMM1,IERR)
2696         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2697      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2698      &   FG_COMM1,IERR)
2699         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2700      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2701      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2702         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2703      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2704      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2705         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2706      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2707      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2708         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2709      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2710      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2711         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2712      &  then
2713         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2714      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2715      &   FG_COMM1,IERR)
2716         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2717      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2718      &   FG_COMM1,IERR)
2719         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2720      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2721      &   FG_COMM1,IERR)
2722        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2723      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2724      &   FG_COMM1,IERR)
2725         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2726      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2727      &   FG_COMM1,IERR)
2728         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2729      &   ivec_count(fg_rank1),
2730      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2731      &   FG_COMM1,IERR)
2732         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2733      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2734      &   FG_COMM1,IERR)
2735         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2736      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2737      &   FG_COMM1,IERR)
2738         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2739      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2740      &   FG_COMM1,IERR)
2741         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2742      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2743      &   FG_COMM1,IERR)
2744         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2745      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2746      &   FG_COMM1,IERR)
2747         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2748      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2749      &   FG_COMM1,IERR)
2750         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2751      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2752      &   FG_COMM1,IERR)
2753         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2754      &   ivec_count(fg_rank1),
2755      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2756      &   FG_COMM1,IERR)
2757         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2758      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2759      &   FG_COMM1,IERR)
2760        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2761      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2762      &   FG_COMM1,IERR)
2763         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2764      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2765      &   FG_COMM1,IERR)
2766        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2767      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2768      &   FG_COMM1,IERR)
2769         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2770      &   ivec_count(fg_rank1),
2771      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2772      &   FG_COMM1,IERR)
2773         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2774      &   ivec_count(fg_rank1),
2775      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2776      &   FG_COMM1,IERR)
2777         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2778      &   ivec_count(fg_rank1),
2779      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2780      &   MPI_MAT2,FG_COMM1,IERR)
2781         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2782      &   ivec_count(fg_rank1),
2783      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2784      &   MPI_MAT2,FG_COMM1,IERR)
2785         endif
2786 #else
2787 c Passes matrix info through the ring
2788       isend=fg_rank1
2789       irecv=fg_rank1-1
2790       if (irecv.lt.0) irecv=nfgtasks1-1
2791       iprev=irecv
2792       inext=fg_rank1+1
2793       if (inext.ge.nfgtasks1) inext=0
2794       do i=1,nfgtasks1-1
2795 c        write (iout,*) "isend",isend," irecv",irecv
2796 c        call flush(iout)
2797         lensend=lentyp(isend)
2798         lenrecv=lentyp(irecv)
2799 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2800 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2801 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2802 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2803 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2804 c        write (iout,*) "Gather ROTAT1"
2805 c        call flush(iout)
2806 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2807 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2808 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2809 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2810 c        write (iout,*) "Gather ROTAT2"
2811 c        call flush(iout)
2812         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2813      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2814      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2815      &   iprev,4400+irecv,FG_COMM,status,IERR)
2816 c        write (iout,*) "Gather ROTAT_OLD"
2817 c        call flush(iout)
2818         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2819      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2820      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2821      &   iprev,5500+irecv,FG_COMM,status,IERR)
2822 c        write (iout,*) "Gather PRECOMP11"
2823 c        call flush(iout)
2824         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2825      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2826      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2827      &   iprev,6600+irecv,FG_COMM,status,IERR)
2828 c        write (iout,*) "Gather PRECOMP12"
2829 c        call flush(iout)
2830         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2831      &  then
2832         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2833      &   MPI_ROTAT2(lensend),inext,7700+isend,
2834      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2835      &   iprev,7700+irecv,FG_COMM,status,IERR)
2836 c        write (iout,*) "Gather PRECOMP21"
2837 c        call flush(iout)
2838         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2839      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2840      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2841      &   iprev,8800+irecv,FG_COMM,status,IERR)
2842 c        write (iout,*) "Gather PRECOMP22"
2843 c        call flush(iout)
2844         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2845      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2846      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2847      &   MPI_PRECOMP23(lenrecv),
2848      &   iprev,9900+irecv,FG_COMM,status,IERR)
2849 c        write (iout,*) "Gather PRECOMP23"
2850 c        call flush(iout)
2851         endif
2852         isend=irecv
2853         irecv=irecv-1
2854         if (irecv.lt.0) irecv=nfgtasks1-1
2855       enddo
2856 #endif
2857         time_gather=time_gather+MPI_Wtime()-time00
2858       endif
2859 #ifdef DEBUG
2860 c      if (fg_rank.eq.0) then
2861         write (iout,*) "Arrays UG and UGDER"
2862         do i=1,nres-1
2863           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2864      &     ((ug(l,k,i),l=1,2),k=1,2),
2865      &     ((ugder(l,k,i),l=1,2),k=1,2)
2866         enddo
2867         write (iout,*) "Arrays UG2 and UG2DER"
2868         do i=1,nres-1
2869           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2870      &     ((ug2(l,k,i),l=1,2),k=1,2),
2871      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2872         enddo
2873         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2874         do i=1,nres-1
2875           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2876      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2877      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2878         enddo
2879         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2880         do i=1,nres-1
2881           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2882      &     costab(i),sintab(i),costab2(i),sintab2(i)
2883         enddo
2884         write (iout,*) "Array MUDER"
2885         do i=1,nres-1
2886           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2887         enddo
2888 c      endif
2889 #endif
2890 #endif
2891 cd      do i=1,nres
2892 cd        iti = itortyp(itype(i))
2893 cd        write (iout,*) i
2894 cd        do j=1,2
2895 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2896 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2897 cd        enddo
2898 cd      enddo
2899       return
2900       end
2901 C--------------------------------------------------------------------------
2902       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2903 C
2904 C This subroutine calculates the average interaction energy and its gradient
2905 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2906 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2907 C The potential depends both on the distance of peptide-group centers and on
2908 C the orientation of the CA-CA virtual bonds.
2909 C
2910       implicit real*8 (a-h,o-z)
2911 #ifdef MPI
2912       include 'mpif.h'
2913 #endif
2914       include 'DIMENSIONS'
2915       include 'COMMON.CONTROL'
2916       include 'COMMON.SETUP'
2917       include 'COMMON.IOUNITS'
2918       include 'COMMON.GEO'
2919       include 'COMMON.VAR'
2920       include 'COMMON.LOCAL'
2921       include 'COMMON.CHAIN'
2922       include 'COMMON.DERIV'
2923       include 'COMMON.INTERACT'
2924       include 'COMMON.CONTACTS'
2925       include 'COMMON.TORSION'
2926       include 'COMMON.VECTORS'
2927       include 'COMMON.FFIELD'
2928       include 'COMMON.TIME1'
2929       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2930      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2931       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2932      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2933       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2934      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2935      &    num_conti,j1,j2
2936 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2937 #ifdef MOMENT
2938       double precision scal_el /1.0d0/
2939 #else
2940       double precision scal_el /0.5d0/
2941 #endif
2942 C 12/13/98
2943 C 13-go grudnia roku pamietnego...
2944       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2945      &                   0.0d0,1.0d0,0.0d0,
2946      &                   0.0d0,0.0d0,1.0d0/
2947 cd      write(iout,*) 'In EELEC'
2948 cd      do i=1,nloctyp
2949 cd        write(iout,*) 'Type',i
2950 cd        write(iout,*) 'B1',B1(:,i)
2951 cd        write(iout,*) 'B2',B2(:,i)
2952 cd        write(iout,*) 'CC',CC(:,:,i)
2953 cd        write(iout,*) 'DD',DD(:,:,i)
2954 cd        write(iout,*) 'EE',EE(:,:,i)
2955 cd      enddo
2956 cd      call check_vecgrad
2957 cd      stop
2958       if (icheckgrad.eq.1) then
2959         do i=1,nres-1
2960           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2961           do k=1,3
2962             dc_norm(k,i)=dc(k,i)*fac
2963           enddo
2964 c          write (iout,*) 'i',i,' fac',fac
2965         enddo
2966       endif
2967       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2968      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2969      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2970 c        call vec_and_deriv
2971 #ifdef TIMING
2972         time01=MPI_Wtime()
2973 #endif
2974         call set_matrices
2975 #ifdef TIMING
2976         time_mat=time_mat+MPI_Wtime()-time01
2977 #endif
2978       endif
2979 cd      do i=1,nres-1
2980 cd        write (iout,*) 'i=',i
2981 cd        do k=1,3
2982 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2983 cd        enddo
2984 cd        do k=1,3
2985 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2986 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2987 cd        enddo
2988 cd      enddo
2989       t_eelecij=0.0d0
2990       ees=0.0D0
2991       evdw1=0.0D0
2992       eel_loc=0.0d0
2993       eello_turn3=0.0d0
2994       eello_turn4=0.0d0
2995       ind=0
2996       do i=1,nres
2997         num_cont_hb(i)=0
2998       enddo
2999 cd      print '(a)','Enter EELEC'
3000 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3001       do i=1,nres
3002         gel_loc_loc(i)=0.0d0
3003         gcorr_loc(i)=0.0d0
3004       enddo
3005 c
3006 c
3007 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3008 C
3009 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3010 C
3011       do i=iturn3_start,iturn3_end
3012         dxi=dc(1,i)
3013         dyi=dc(2,i)
3014         dzi=dc(3,i)
3015         dx_normi=dc_norm(1,i)
3016         dy_normi=dc_norm(2,i)
3017         dz_normi=dc_norm(3,i)
3018         xmedi=c(1,i)+0.5d0*dxi
3019         ymedi=c(2,i)+0.5d0*dyi
3020         zmedi=c(3,i)+0.5d0*dzi
3021         num_conti=0
3022         call eelecij(i,i+2,ees,evdw1,eel_loc)
3023         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3024         num_cont_hb(i)=num_conti
3025       enddo
3026       do i=iturn4_start,iturn4_end
3027         dxi=dc(1,i)
3028         dyi=dc(2,i)
3029         dzi=dc(3,i)
3030         dx_normi=dc_norm(1,i)
3031         dy_normi=dc_norm(2,i)
3032         dz_normi=dc_norm(3,i)
3033         xmedi=c(1,i)+0.5d0*dxi
3034         ymedi=c(2,i)+0.5d0*dyi
3035         zmedi=c(3,i)+0.5d0*dzi
3036         num_conti=num_cont_hb(i)
3037         call eelecij(i,i+3,ees,evdw1,eel_loc)
3038         if (wturn4.gt.0.0d0) call eturn4(i,eello_turn4)
3039         num_cont_hb(i)=num_conti
3040       enddo   ! i
3041 c
3042 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3043 c
3044       do i=iatel_s,iatel_e
3045         dxi=dc(1,i)
3046         dyi=dc(2,i)
3047         dzi=dc(3,i)
3048         dx_normi=dc_norm(1,i)
3049         dy_normi=dc_norm(2,i)
3050         dz_normi=dc_norm(3,i)
3051         xmedi=c(1,i)+0.5d0*dxi
3052         ymedi=c(2,i)+0.5d0*dyi
3053         zmedi=c(3,i)+0.5d0*dzi
3054 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3055         num_conti=num_cont_hb(i)
3056         do j=ielstart(i),ielend(i)
3057           call eelecij(i,j,ees,evdw1,eel_loc)
3058         enddo ! j
3059         num_cont_hb(i)=num_conti
3060       enddo   ! i
3061 c      write (iout,*) "Number of loop steps in EELEC:",ind
3062 cd      do i=1,nres
3063 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3064 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3065 cd      enddo
3066 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3067 ccc      eel_loc=eel_loc+eello_turn3
3068 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3069       return
3070       end
3071 C-------------------------------------------------------------------------------
3072       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3073       implicit real*8 (a-h,o-z)
3074       include 'DIMENSIONS'
3075 #ifdef MPI
3076       include "mpif.h"
3077 #endif
3078       include 'COMMON.CONTROL'
3079       include 'COMMON.IOUNITS'
3080       include 'COMMON.GEO'
3081       include 'COMMON.VAR'
3082       include 'COMMON.LOCAL'
3083       include 'COMMON.CHAIN'
3084       include 'COMMON.DERIV'
3085       include 'COMMON.INTERACT'
3086       include 'COMMON.CONTACTS'
3087       include 'COMMON.TORSION'
3088       include 'COMMON.VECTORS'
3089       include 'COMMON.FFIELD'
3090       include 'COMMON.TIME1'
3091       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3092      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3093       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3094      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3095       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3096      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3097      &    num_conti,j1,j2
3098 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3099 #ifdef MOMENT
3100       double precision scal_el /1.0d0/
3101 #else
3102       double precision scal_el /0.5d0/
3103 #endif
3104 C 12/13/98
3105 C 13-go grudnia roku pamietnego...
3106       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3107      &                   0.0d0,1.0d0,0.0d0,
3108      &                   0.0d0,0.0d0,1.0d0/
3109 c          time00=MPI_Wtime()
3110 cd      write (iout,*) "eelecij",i,j
3111 c          ind=ind+1
3112           iteli=itel(i)
3113           itelj=itel(j)
3114           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3115           aaa=app(iteli,itelj)
3116           bbb=bpp(iteli,itelj)
3117           ael6i=ael6(iteli,itelj)
3118           ael3i=ael3(iteli,itelj)
3119           dxj=dc(1,j)
3120           dyj=dc(2,j)
3121           dzj=dc(3,j)
3122           dx_normj=dc_norm(1,j)
3123           dy_normj=dc_norm(2,j)
3124           dz_normj=dc_norm(3,j)
3125           xj=c(1,j)+0.5D0*dxj-xmedi
3126           yj=c(2,j)+0.5D0*dyj-ymedi
3127           zj=c(3,j)+0.5D0*dzj-zmedi
3128           rij=xj*xj+yj*yj+zj*zj
3129           rrmij=1.0D0/rij
3130           rij=dsqrt(rij)
3131           rmij=1.0D0/rij
3132           r3ij=rrmij*rmij
3133           r6ij=r3ij*r3ij
3134           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3135           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3136           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3137           fac=cosa-3.0D0*cosb*cosg
3138           ev1=aaa*r6ij*r6ij
3139 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3140           if (j.eq.i+2) ev1=scal_el*ev1
3141           ev2=bbb*r6ij
3142           fac3=ael6i*r6ij
3143           fac4=ael3i*r3ij
3144           evdwij=ev1+ev2
3145           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3146           el2=fac4*fac
3147           eesij=el1+el2
3148 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3149           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3150           ees=ees+eesij
3151           evdw1=evdw1+evdwij
3152 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3153 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3154 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3155 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3156
3157           if (energy_dec) then
3158               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3159               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3160           endif
3161
3162 C
3163 C Calculate contributions to the Cartesian gradient.
3164 C
3165 #ifdef SPLITELE
3166           facvdw=-6*rrmij*(ev1+evdwij)
3167           facel=-3*rrmij*(el1+eesij)
3168           fac1=fac
3169           erij(1)=xj*rmij
3170           erij(2)=yj*rmij
3171           erij(3)=zj*rmij
3172 *
3173 * Radial derivatives. First process both termini of the fragment (i,j)
3174 *
3175           ggg(1)=facel*xj
3176           ggg(2)=facel*yj
3177           ggg(3)=facel*zj
3178 c          do k=1,3
3179 c            ghalf=0.5D0*ggg(k)
3180 c            gelc(k,i)=gelc(k,i)+ghalf
3181 c            gelc(k,j)=gelc(k,j)+ghalf
3182 c          enddo
3183 c 9/28/08 AL Gradient compotents will be summed only at the end
3184           do k=1,3
3185             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3186             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3187           enddo
3188 *
3189 * Loop over residues i+1 thru j-1.
3190 *
3191 cgrad          do k=i+1,j-1
3192 cgrad            do l=1,3
3193 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3194 cgrad            enddo
3195 cgrad          enddo
3196           ggg(1)=facvdw*xj
3197           ggg(2)=facvdw*yj
3198           ggg(3)=facvdw*zj
3199 c          do k=1,3
3200 c            ghalf=0.5D0*ggg(k)
3201 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3202 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3203 c          enddo
3204 c 9/28/08 AL Gradient compotents will be summed only at the end
3205           do k=1,3
3206             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3207             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3208           enddo
3209 *
3210 * Loop over residues i+1 thru j-1.
3211 *
3212 cgrad          do k=i+1,j-1
3213 cgrad            do l=1,3
3214 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3215 cgrad            enddo
3216 cgrad          enddo
3217 #else
3218           facvdw=ev1+evdwij
3219           facel=el1+eesij
3220           fac1=fac
3221           fac=-3*rrmij*(facvdw+facvdw+facel)
3222           erij(1)=xj*rmij
3223           erij(2)=yj*rmij
3224           erij(3)=zj*rmij
3225 *
3226 * Radial derivatives. First process both termini of the fragment (i,j)
3227 *
3228           ggg(1)=fac*xj
3229           ggg(2)=fac*yj
3230           ggg(3)=fac*zj
3231 c          do k=1,3
3232 c            ghalf=0.5D0*ggg(k)
3233 c            gelc(k,i)=gelc(k,i)+ghalf
3234 c            gelc(k,j)=gelc(k,j)+ghalf
3235 c          enddo
3236 c 9/28/08 AL Gradient compotents will be summed only at the end
3237           do k=1,3
3238             gelc_long(k,j)=gelc(k,j)+ggg(k)
3239             gelc_long(k,i)=gelc(k,i)-ggg(k)
3240           enddo
3241 *
3242 * Loop over residues i+1 thru j-1.
3243 *
3244 cgrad          do k=i+1,j-1
3245 cgrad            do l=1,3
3246 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3247 cgrad            enddo
3248 cgrad          enddo
3249 c 9/28/08 AL Gradient compotents will be summed only at the end
3250           ggg(1)=facvdw*xj
3251           ggg(2)=facvdw*yj
3252           ggg(3)=facvdw*zj
3253           do k=1,3
3254             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3255             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3256           enddo
3257 #endif
3258 *
3259 * Angular part
3260 *
3261           ecosa=2.0D0*fac3*fac1+fac4
3262           fac4=-3.0D0*fac4
3263           fac3=-6.0D0*fac3
3264           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3265           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3266           do k=1,3
3267             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3268             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3269           enddo
3270 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3271 cd   &          (dcosg(k),k=1,3)
3272           do k=1,3
3273             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3274           enddo
3275 c          do k=1,3
3276 c            ghalf=0.5D0*ggg(k)
3277 c            gelc(k,i)=gelc(k,i)+ghalf
3278 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3279 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3280 c            gelc(k,j)=gelc(k,j)+ghalf
3281 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3282 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3283 c          enddo
3284 cgrad          do k=i+1,j-1
3285 cgrad            do l=1,3
3286 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3287 cgrad            enddo
3288 cgrad          enddo
3289           do k=1,3
3290             gelc(k,i)=gelc(k,i)
3291      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3292      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3293             gelc(k,j)=gelc(k,j)
3294      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3295      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3296             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3297             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3298           enddo
3299           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3300      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3301      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3302 C
3303 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3304 C   energy of a peptide unit is assumed in the form of a second-order
3305 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3306 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3307 C   are computed for EVERY pair of non-contiguous peptide groups.
3308 C
3309           if (j.lt.nres-1) then
3310             j1=j+1
3311             j2=j-1
3312           else
3313             j1=j-1
3314             j2=j-2
3315           endif
3316           kkk=0
3317           do k=1,2
3318             do l=1,2
3319               kkk=kkk+1
3320               muij(kkk)=mu(k,i)*mu(l,j)
3321             enddo
3322           enddo
3323 cd         write (iout,*) 'EELEC: i',i,' j',j
3324 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3325 cd          write(iout,*) 'muij',muij
3326           ury=scalar(uy(1,i),erij)
3327           urz=scalar(uz(1,i),erij)
3328           vry=scalar(uy(1,j),erij)
3329           vrz=scalar(uz(1,j),erij)
3330           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3331           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3332           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3333           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3334           fac=dsqrt(-ael6i)*r3ij
3335           a22=a22*fac
3336           a23=a23*fac
3337           a32=a32*fac
3338           a33=a33*fac
3339 cd          write (iout,'(4i5,4f10.5)')
3340 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3341 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3342 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3343 cd     &      uy(:,j),uz(:,j)
3344 cd          write (iout,'(4f10.5)')
3345 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3346 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3347 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3348 cd           write (iout,'(9f10.5/)')
3349 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3350 C Derivatives of the elements of A in virtual-bond vectors
3351           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3352           do k=1,3
3353             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3354             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3355             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3356             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3357             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3358             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3359             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3360             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3361             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3362             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3363             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3364             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3365           enddo
3366 C Compute radial contributions to the gradient
3367           facr=-3.0d0*rrmij
3368           a22der=a22*facr
3369           a23der=a23*facr
3370           a32der=a32*facr
3371           a33der=a33*facr
3372           agg(1,1)=a22der*xj
3373           agg(2,1)=a22der*yj
3374           agg(3,1)=a22der*zj
3375           agg(1,2)=a23der*xj
3376           agg(2,2)=a23der*yj
3377           agg(3,2)=a23der*zj
3378           agg(1,3)=a32der*xj
3379           agg(2,3)=a32der*yj
3380           agg(3,3)=a32der*zj
3381           agg(1,4)=a33der*xj
3382           agg(2,4)=a33der*yj
3383           agg(3,4)=a33der*zj
3384 C Add the contributions coming from er
3385           fac3=-3.0d0*fac
3386           do k=1,3
3387             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3388             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3389             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3390             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3391           enddo
3392           do k=1,3
3393 C Derivatives in DC(i)
3394 cgrad            ghalf1=0.5d0*agg(k,1)
3395 cgrad            ghalf2=0.5d0*agg(k,2)
3396 cgrad            ghalf3=0.5d0*agg(k,3)
3397 cgrad            ghalf4=0.5d0*agg(k,4)
3398             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3399      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3400             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3401      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3402             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3403      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3404             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3405      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3406 C Derivatives in DC(i+1)
3407             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3408      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3409             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3410      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3411             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3412      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3413             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3414      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3415 C Derivatives in DC(j)
3416             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3417      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3418             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3419      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3420             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3421      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3422             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3423      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3424 C Derivatives in DC(j+1) or DC(nres-1)
3425             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3426      &      -3.0d0*vryg(k,3)*ury)
3427             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3428      &      -3.0d0*vrzg(k,3)*ury)
3429             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3430      &      -3.0d0*vryg(k,3)*urz)
3431             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3432      &      -3.0d0*vrzg(k,3)*urz)
3433 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3434 cgrad              do l=1,4
3435 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3436 cgrad              enddo
3437 cgrad            endif
3438           enddo
3439           acipa(1,1)=a22
3440           acipa(1,2)=a23
3441           acipa(2,1)=a32
3442           acipa(2,2)=a33
3443           a22=-a22
3444           a23=-a23
3445           do l=1,2
3446             do k=1,3
3447               agg(k,l)=-agg(k,l)
3448               aggi(k,l)=-aggi(k,l)
3449               aggi1(k,l)=-aggi1(k,l)
3450               aggj(k,l)=-aggj(k,l)
3451               aggj1(k,l)=-aggj1(k,l)
3452             enddo
3453           enddo
3454           if (j.lt.nres-1) then
3455             a22=-a22
3456             a32=-a32
3457             do l=1,3,2
3458               do k=1,3
3459                 agg(k,l)=-agg(k,l)
3460                 aggi(k,l)=-aggi(k,l)
3461                 aggi1(k,l)=-aggi1(k,l)
3462                 aggj(k,l)=-aggj(k,l)
3463                 aggj1(k,l)=-aggj1(k,l)
3464               enddo
3465             enddo
3466           else
3467             a22=-a22
3468             a23=-a23
3469             a32=-a32
3470             a33=-a33
3471             do l=1,4
3472               do k=1,3
3473                 agg(k,l)=-agg(k,l)
3474                 aggi(k,l)=-aggi(k,l)
3475                 aggi1(k,l)=-aggi1(k,l)
3476                 aggj(k,l)=-aggj(k,l)
3477                 aggj1(k,l)=-aggj1(k,l)
3478               enddo
3479             enddo
3480           endif
3481           ENDIF ! WCORR
3482           IF (wel_loc.gt.0.0d0) THEN
3483 C Contribution to the local-electrostatic energy coming from the i-j pair
3484           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3485      &     +a33*muij(4)
3486 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3487
3488           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3489      &            'eelloc',i,j,eel_loc_ij
3490
3491           eel_loc=eel_loc+eel_loc_ij
3492 C Partial derivatives in virtual-bond dihedral angles gamma
3493           if (i.gt.1)
3494      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3495      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3496      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3497           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3498      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3499      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3500 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3501           do l=1,3
3502             ggg(l)=agg(l,1)*muij(1)+
3503      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3504             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3505             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3506 cgrad            ghalf=0.5d0*ggg(l)
3507 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3508 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3509           enddo
3510 cgrad          do k=i+1,j2
3511 cgrad            do l=1,3
3512 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3513 cgrad            enddo
3514 cgrad          enddo
3515 C Remaining derivatives of eello
3516           do l=1,3
3517             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3518      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3519             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3520      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3521             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3522      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3523             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3524      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3525           enddo
3526           ENDIF
3527 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3528 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3529           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3530      &       .and. num_conti.le.maxconts) then
3531 c            write (iout,*) i,j," entered corr"
3532 C
3533 C Calculate the contact function. The ith column of the array JCONT will
3534 C contain the numbers of atoms that make contacts with the atom I (of numbers
3535 C greater than I). The arrays FACONT and GACONT will contain the values of
3536 C the contact function and its derivative.
3537 c           r0ij=1.02D0*rpp(iteli,itelj)
3538 c           r0ij=1.11D0*rpp(iteli,itelj)
3539             r0ij=2.20D0*rpp(iteli,itelj)
3540 c           r0ij=1.55D0*rpp(iteli,itelj)
3541             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3542             if (fcont.gt.0.0D0) then
3543               num_conti=num_conti+1
3544               if (num_conti.gt.maxconts) then
3545                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3546      &                         ' will skip next contacts for this conf.'
3547               else
3548                 jcont_hb(num_conti,i)=j
3549 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3550 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3551                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3552      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3553 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3554 C  terms.
3555                 d_cont(num_conti,i)=rij
3556 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3557 C     --- Electrostatic-interaction matrix ---
3558                 a_chuj(1,1,num_conti,i)=a22
3559                 a_chuj(1,2,num_conti,i)=a23
3560                 a_chuj(2,1,num_conti,i)=a32
3561                 a_chuj(2,2,num_conti,i)=a33
3562 C     --- Gradient of rij
3563                 do kkk=1,3
3564                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3565                 enddo
3566                 kkll=0
3567                 do k=1,2
3568                   do l=1,2
3569                     kkll=kkll+1
3570                     do m=1,3
3571                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3572                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3573                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3574                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3575                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3576                     enddo
3577                   enddo
3578                 enddo
3579                 ENDIF
3580                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3581 C Calculate contact energies
3582                 cosa4=4.0D0*cosa
3583                 wij=cosa-3.0D0*cosb*cosg
3584                 cosbg1=cosb+cosg
3585                 cosbg2=cosb-cosg
3586 c               fac3=dsqrt(-ael6i)/r0ij**3
3587                 fac3=dsqrt(-ael6i)*r3ij
3588 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3589                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3590                 if (ees0tmp.gt.0) then
3591                   ees0pij=dsqrt(ees0tmp)
3592                 else
3593                   ees0pij=0
3594                 endif
3595 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3596                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3597                 if (ees0tmp.gt.0) then
3598                   ees0mij=dsqrt(ees0tmp)
3599                 else
3600                   ees0mij=0
3601                 endif
3602 c               ees0mij=0.0D0
3603                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3604                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3605 C Diagnostics. Comment out or remove after debugging!
3606 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3607 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3608 c               ees0m(num_conti,i)=0.0D0
3609 C End diagnostics.
3610 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3611 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3612 C Angular derivatives of the contact function
3613                 ees0pij1=fac3/ees0pij
3614                 ees0mij1=fac3/ees0mij
3615                 fac3p=-3.0D0*fac3*rrmij
3616                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3617                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3618 c               ees0mij1=0.0D0
3619                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3620                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3621                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3622                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3623                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3624                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3625                 ecosap=ecosa1+ecosa2
3626                 ecosbp=ecosb1+ecosb2
3627                 ecosgp=ecosg1+ecosg2
3628                 ecosam=ecosa1-ecosa2
3629                 ecosbm=ecosb1-ecosb2
3630                 ecosgm=ecosg1-ecosg2
3631 C Diagnostics
3632 c               ecosap=ecosa1
3633 c               ecosbp=ecosb1
3634 c               ecosgp=ecosg1
3635 c               ecosam=0.0D0
3636 c               ecosbm=0.0D0
3637 c               ecosgm=0.0D0
3638 C End diagnostics
3639                 facont_hb(num_conti,i)=fcont
3640                 fprimcont=fprimcont/rij
3641 cd              facont_hb(num_conti,i)=1.0D0
3642 C Following line is for diagnostics.
3643 cd              fprimcont=0.0D0
3644                 do k=1,3
3645                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3646                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3647                 enddo
3648                 do k=1,3
3649                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3650                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3651                 enddo
3652                 gggp(1)=gggp(1)+ees0pijp*xj
3653                 gggp(2)=gggp(2)+ees0pijp*yj
3654                 gggp(3)=gggp(3)+ees0pijp*zj
3655                 gggm(1)=gggm(1)+ees0mijp*xj
3656                 gggm(2)=gggm(2)+ees0mijp*yj
3657                 gggm(3)=gggm(3)+ees0mijp*zj
3658 C Derivatives due to the contact function
3659                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3660                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3661                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3662                 do k=1,3
3663 c
3664 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3665 c          following the change of gradient-summation algorithm.
3666 c
3667 cgrad                  ghalfp=0.5D0*gggp(k)
3668 cgrad                  ghalfm=0.5D0*gggm(k)
3669                   gacontp_hb1(k,num_conti,i)=!ghalfp
3670      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3671      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3672                   gacontp_hb2(k,num_conti,i)=!ghalfp
3673      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3674      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3675                   gacontp_hb3(k,num_conti,i)=gggp(k)
3676                   gacontm_hb1(k,num_conti,i)=!ghalfm
3677      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3678      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3679                   gacontm_hb2(k,num_conti,i)=!ghalfm
3680      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3681      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3682                   gacontm_hb3(k,num_conti,i)=gggm(k)
3683                 enddo
3684 C Diagnostics. Comment out or remove after debugging!
3685 cdiag           do k=1,3
3686 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3687 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3688 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3689 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3690 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3691 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3692 cdiag           enddo
3693               ENDIF ! wcorr
3694               endif  ! num_conti.le.maxconts
3695             endif  ! fcont.gt.0
3696           endif    ! j.gt.i+1
3697           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3698             do k=1,4
3699               do l=1,3
3700                 ghalf=0.5d0*agg(l,k)
3701                 aggi(l,k)=aggi(l,k)+ghalf
3702                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3703                 aggj(l,k)=aggj(l,k)+ghalf
3704               enddo
3705             enddo
3706             if (j.eq.nres-1 .and. i.lt.j-2) then
3707               do k=1,4
3708                 do l=1,3
3709                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3710                 enddo
3711               enddo
3712             endif
3713           endif
3714 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3715       return
3716       end
3717 C-----------------------------------------------------------------------------
3718       subroutine eturn3(i,eello_turn3)
3719 C Third- and fourth-order contributions from turns
3720       implicit real*8 (a-h,o-z)
3721       include 'DIMENSIONS'
3722       include 'COMMON.IOUNITS'
3723       include 'COMMON.GEO'
3724       include 'COMMON.VAR'
3725       include 'COMMON.LOCAL'
3726       include 'COMMON.CHAIN'
3727       include 'COMMON.DERIV'
3728       include 'COMMON.INTERACT'
3729       include 'COMMON.CONTACTS'
3730       include 'COMMON.TORSION'
3731       include 'COMMON.VECTORS'
3732       include 'COMMON.FFIELD'
3733       include 'COMMON.CONTROL'
3734       dimension ggg(3)
3735       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3736      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3737      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3738       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3739      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3740       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3741      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3742      &    num_conti,j1,j2
3743       j=i+2
3744 c      write (iout,*) "eturn3",i,j,j1,j2
3745       a_temp(1,1)=a22
3746       a_temp(1,2)=a23
3747       a_temp(2,1)=a32
3748       a_temp(2,2)=a33
3749 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3750 C
3751 C               Third-order contributions
3752 C
3753 C                 (i+2)o----(i+3)
3754 C                      | |
3755 C                      | |
3756 C                 (i+1)o----i
3757 C
3758 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3759 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3760         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3761         call transpose2(auxmat(1,1),auxmat1(1,1))
3762         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3763         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3764         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3765      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3766 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3767 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3768 cd     &    ' eello_turn3_num',4*eello_turn3_num
3769 C Derivatives in gamma(i)
3770         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3771         call transpose2(auxmat2(1,1),auxmat3(1,1))
3772         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3773         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3774 C Derivatives in gamma(i+1)
3775         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3776         call transpose2(auxmat2(1,1),auxmat3(1,1))
3777         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3778         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3779      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3780 C Cartesian derivatives
3781         do l=1,3
3782 c            ghalf1=0.5d0*agg(l,1)
3783 c            ghalf2=0.5d0*agg(l,2)
3784 c            ghalf3=0.5d0*agg(l,3)
3785 c            ghalf4=0.5d0*agg(l,4)
3786           a_temp(1,1)=aggi(l,1)!+ghalf1
3787           a_temp(1,2)=aggi(l,2)!+ghalf2
3788           a_temp(2,1)=aggi(l,3)!+ghalf3
3789           a_temp(2,2)=aggi(l,4)!+ghalf4
3790           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3791           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3792      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3793           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3794           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3795           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3796           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3797           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3798           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3799      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3800           a_temp(1,1)=aggj(l,1)!+ghalf1
3801           a_temp(1,2)=aggj(l,2)!+ghalf2
3802           a_temp(2,1)=aggj(l,3)!+ghalf3
3803           a_temp(2,2)=aggj(l,4)!+ghalf4
3804           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3805           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3806      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3807           a_temp(1,1)=aggj1(l,1)
3808           a_temp(1,2)=aggj1(l,2)
3809           a_temp(2,1)=aggj1(l,3)
3810           a_temp(2,2)=aggj1(l,4)
3811           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3812           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3813      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3814         enddo
3815       return
3816       end
3817 C-------------------------------------------------------------------------------
3818       subroutine eturn4(i,eello_turn4)
3819 C Third- and fourth-order contributions from turns
3820       implicit real*8 (a-h,o-z)
3821       include 'DIMENSIONS'
3822       include 'COMMON.IOUNITS'
3823       include 'COMMON.GEO'
3824       include 'COMMON.VAR'
3825       include 'COMMON.LOCAL'
3826       include 'COMMON.CHAIN'
3827       include 'COMMON.DERIV'
3828       include 'COMMON.INTERACT'
3829       include 'COMMON.CONTACTS'
3830       include 'COMMON.TORSION'
3831       include 'COMMON.VECTORS'
3832       include 'COMMON.FFIELD'
3833       include 'COMMON.CONTROL'
3834       dimension ggg(3)
3835       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3836      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3837      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3838       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3839      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3840       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3841      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3842      &    num_conti,j1,j2
3843       j=i+3
3844 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3845 C
3846 C               Fourth-order contributions
3847 C
3848 C                 (i+3)o----(i+4)
3849 C                     /  |
3850 C               (i+2)o   |
3851 C                     \  |
3852 C                 (i+1)o----i
3853 C
3854 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3855 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3856 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3857         a_temp(1,1)=a22
3858         a_temp(1,2)=a23
3859         a_temp(2,1)=a32
3860         a_temp(2,2)=a33
3861         iti1=itortyp(itype(i+1))
3862         iti2=itortyp(itype(i+2))
3863         iti3=itortyp(itype(i+3))
3864 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3865         call transpose2(EUg(1,1,i+1),e1t(1,1))
3866         call transpose2(Eug(1,1,i+2),e2t(1,1))
3867         call transpose2(Eug(1,1,i+3),e3t(1,1))
3868         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3869         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3870         s1=scalar2(b1(1,iti2),auxvec(1))
3871         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3872         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3873         s2=scalar2(b1(1,iti1),auxvec(1))
3874         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3875         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3876         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3877         eello_turn4=eello_turn4-(s1+s2+s3)
3878         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3879      &      'eturn4',i,j,-(s1+s2+s3)
3880 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3881 cd     &    ' eello_turn4_num',8*eello_turn4_num
3882 C Derivatives in gamma(i)
3883         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3884         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3885         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3886         s1=scalar2(b1(1,iti2),auxvec(1))
3887         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3888         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3889         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3890 C Derivatives in gamma(i+1)
3891         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3892         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3893         s2=scalar2(b1(1,iti1),auxvec(1))
3894         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3895         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3896         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3897         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3898 C Derivatives in gamma(i+2)
3899         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3900         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3901         s1=scalar2(b1(1,iti2),auxvec(1))
3902         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3903         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3904         s2=scalar2(b1(1,iti1),auxvec(1))
3905         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3906         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3907         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3908         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3909 C Cartesian derivatives
3910 C Derivatives of this turn contributions in DC(i+2)
3911         if (j.lt.nres-1) then
3912           do l=1,3
3913             a_temp(1,1)=agg(l,1)
3914             a_temp(1,2)=agg(l,2)
3915             a_temp(2,1)=agg(l,3)
3916             a_temp(2,2)=agg(l,4)
3917             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3918             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3919             s1=scalar2(b1(1,iti2),auxvec(1))
3920             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3921             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3922             s2=scalar2(b1(1,iti1),auxvec(1))
3923             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3924             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3925             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3926             ggg(l)=-(s1+s2+s3)
3927             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3928           enddo
3929         endif
3930 C Remaining derivatives of this turn contribution
3931         do l=1,3
3932           a_temp(1,1)=aggi(l,1)
3933           a_temp(1,2)=aggi(l,2)
3934           a_temp(2,1)=aggi(l,3)
3935           a_temp(2,2)=aggi(l,4)
3936           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3937           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3938           s1=scalar2(b1(1,iti2),auxvec(1))
3939           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3940           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3941           s2=scalar2(b1(1,iti1),auxvec(1))
3942           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3943           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3944           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3945           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3946           a_temp(1,1)=aggi1(l,1)
3947           a_temp(1,2)=aggi1(l,2)
3948           a_temp(2,1)=aggi1(l,3)
3949           a_temp(2,2)=aggi1(l,4)
3950           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3951           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3952           s1=scalar2(b1(1,iti2),auxvec(1))
3953           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3954           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3955           s2=scalar2(b1(1,iti1),auxvec(1))
3956           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3957           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3958           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3959           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3960           a_temp(1,1)=aggj(l,1)
3961           a_temp(1,2)=aggj(l,2)
3962           a_temp(2,1)=aggj(l,3)
3963           a_temp(2,2)=aggj(l,4)
3964           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3965           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3966           s1=scalar2(b1(1,iti2),auxvec(1))
3967           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3968           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3969           s2=scalar2(b1(1,iti1),auxvec(1))
3970           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3971           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3972           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3973           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3974           a_temp(1,1)=aggj1(l,1)
3975           a_temp(1,2)=aggj1(l,2)
3976           a_temp(2,1)=aggj1(l,3)
3977           a_temp(2,2)=aggj1(l,4)
3978           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3979           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3980           s1=scalar2(b1(1,iti2),auxvec(1))
3981           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3982           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3983           s2=scalar2(b1(1,iti1),auxvec(1))
3984           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3985           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3986           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3987 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3988           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3989         enddo
3990       return
3991       end
3992 C-----------------------------------------------------------------------------
3993       subroutine vecpr(u,v,w)
3994       implicit real*8(a-h,o-z)
3995       dimension u(3),v(3),w(3)
3996       w(1)=u(2)*v(3)-u(3)*v(2)
3997       w(2)=-u(1)*v(3)+u(3)*v(1)
3998       w(3)=u(1)*v(2)-u(2)*v(1)
3999       return
4000       end
4001 C-----------------------------------------------------------------------------
4002       subroutine unormderiv(u,ugrad,unorm,ungrad)
4003 C This subroutine computes the derivatives of a normalized vector u, given
4004 C the derivatives computed without normalization conditions, ugrad. Returns
4005 C ungrad.
4006       implicit none
4007       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4008       double precision vec(3)
4009       double precision scalar
4010       integer i,j
4011 c      write (2,*) 'ugrad',ugrad
4012 c      write (2,*) 'u',u
4013       do i=1,3
4014         vec(i)=scalar(ugrad(1,i),u(1))
4015       enddo
4016 c      write (2,*) 'vec',vec
4017       do i=1,3
4018         do j=1,3
4019           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4020         enddo
4021       enddo
4022 c      write (2,*) 'ungrad',ungrad
4023       return
4024       end
4025 C-----------------------------------------------------------------------------
4026       subroutine escp_soft_sphere(evdw2,evdw2_14)
4027 C
4028 C This subroutine calculates the excluded-volume interaction energy between
4029 C peptide-group centers and side chains and its gradient in virtual-bond and
4030 C side-chain vectors.
4031 C
4032       implicit real*8 (a-h,o-z)
4033       include 'DIMENSIONS'
4034       include 'COMMON.GEO'
4035       include 'COMMON.VAR'
4036       include 'COMMON.LOCAL'
4037       include 'COMMON.CHAIN'
4038       include 'COMMON.DERIV'
4039       include 'COMMON.INTERACT'
4040       include 'COMMON.FFIELD'
4041       include 'COMMON.IOUNITS'
4042       include 'COMMON.CONTROL'
4043       dimension ggg(3)
4044       evdw2=0.0D0
4045       evdw2_14=0.0d0
4046       r0_scp=4.5d0
4047 cd    print '(a)','Enter ESCP'
4048 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4049       do i=iatscp_s,iatscp_e
4050         iteli=itel(i)
4051         xi=0.5D0*(c(1,i)+c(1,i+1))
4052         yi=0.5D0*(c(2,i)+c(2,i+1))
4053         zi=0.5D0*(c(3,i)+c(3,i+1))
4054
4055         do iint=1,nscp_gr(i)
4056
4057         do j=iscpstart(i,iint),iscpend(i,iint)
4058           itypj=itype(j)
4059 C Uncomment following three lines for SC-p interactions
4060 c         xj=c(1,nres+j)-xi
4061 c         yj=c(2,nres+j)-yi
4062 c         zj=c(3,nres+j)-zi
4063 C Uncomment following three lines for Ca-p interactions
4064           xj=c(1,j)-xi
4065           yj=c(2,j)-yi
4066           zj=c(3,j)-zi
4067           rij=xj*xj+yj*yj+zj*zj
4068           r0ij=r0_scp
4069           r0ijsq=r0ij*r0ij
4070           if (rij.lt.r0ijsq) then
4071             evdwij=0.25d0*(rij-r0ijsq)**2
4072             fac=rij-r0ijsq
4073           else
4074             evdwij=0.0d0
4075             fac=0.0d0
4076           endif
4077           evdw2=evdw2+evdwij
4078 C
4079 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4080 C
4081           ggg(1)=xj*fac
4082           ggg(2)=yj*fac
4083           ggg(3)=zj*fac
4084 cgrad          if (j.lt.i) then
4085 cd          write (iout,*) 'j<i'
4086 C Uncomment following three lines for SC-p interactions
4087 c           do k=1,3
4088 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4089 c           enddo
4090 cgrad          else
4091 cd          write (iout,*) 'j>i'
4092 cgrad            do k=1,3
4093 cgrad              ggg(k)=-ggg(k)
4094 C Uncomment following line for SC-p interactions
4095 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4096 cgrad            enddo
4097 cgrad          endif
4098 cgrad          do k=1,3
4099 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4100 cgrad          enddo
4101 cgrad          kstart=min0(i+1,j)
4102 cgrad          kend=max0(i-1,j-1)
4103 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4104 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4105 cgrad          do k=kstart,kend
4106 cgrad            do l=1,3
4107 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4108 cgrad            enddo
4109 cgrad          enddo
4110           do k=1,3
4111             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4112             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4113           enddo
4114         enddo
4115
4116         enddo ! iint
4117       enddo ! i
4118       return
4119       end
4120 C-----------------------------------------------------------------------------
4121       subroutine escp(evdw2,evdw2_14)
4122 C
4123 C This subroutine calculates the excluded-volume interaction energy between
4124 C peptide-group centers and side chains and its gradient in virtual-bond and
4125 C side-chain vectors.
4126 C
4127       implicit real*8 (a-h,o-z)
4128       include 'DIMENSIONS'
4129       include 'COMMON.GEO'
4130       include 'COMMON.VAR'
4131       include 'COMMON.LOCAL'
4132       include 'COMMON.CHAIN'
4133       include 'COMMON.DERIV'
4134       include 'COMMON.INTERACT'
4135       include 'COMMON.FFIELD'
4136       include 'COMMON.IOUNITS'
4137       include 'COMMON.CONTROL'
4138       dimension ggg(3)
4139       evdw2=0.0D0
4140       evdw2_14=0.0d0
4141 cd    print '(a)','Enter ESCP'
4142 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4143       do i=iatscp_s,iatscp_e
4144         iteli=itel(i)
4145         xi=0.5D0*(c(1,i)+c(1,i+1))
4146         yi=0.5D0*(c(2,i)+c(2,i+1))
4147         zi=0.5D0*(c(3,i)+c(3,i+1))
4148
4149         do iint=1,nscp_gr(i)
4150
4151         do j=iscpstart(i,iint),iscpend(i,iint)
4152           itypj=itype(j)
4153 C Uncomment following three lines for SC-p interactions
4154 c         xj=c(1,nres+j)-xi
4155 c         yj=c(2,nres+j)-yi
4156 c         zj=c(3,nres+j)-zi
4157 C Uncomment following three lines for Ca-p interactions
4158           xj=c(1,j)-xi
4159           yj=c(2,j)-yi
4160           zj=c(3,j)-zi
4161           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4162           fac=rrij**expon2
4163           e1=fac*fac*aad(itypj,iteli)
4164           e2=fac*bad(itypj,iteli)
4165           if (iabs(j-i) .le. 2) then
4166             e1=scal14*e1
4167             e2=scal14*e2
4168             evdw2_14=evdw2_14+e1+e2
4169           endif
4170           evdwij=e1+e2
4171           evdw2=evdw2+evdwij
4172           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4173      &        'evdw2',i,j,evdwij
4174 C
4175 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4176 C
4177           fac=-(evdwij+e1)*rrij
4178           ggg(1)=xj*fac
4179           ggg(2)=yj*fac
4180           ggg(3)=zj*fac
4181 cgrad          if (j.lt.i) then
4182 cd          write (iout,*) 'j<i'
4183 C Uncomment following three lines for SC-p interactions
4184 c           do k=1,3
4185 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4186 c           enddo
4187 cgrad          else
4188 cd          write (iout,*) 'j>i'
4189 cgrad            do k=1,3
4190 cgrad              ggg(k)=-ggg(k)
4191 C Uncomment following line for SC-p interactions
4192 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4193 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4194 cgrad            enddo
4195 cgrad          endif
4196 cgrad          do k=1,3
4197 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4198 cgrad          enddo
4199 cgrad          kstart=min0(i+1,j)
4200 cgrad          kend=max0(i-1,j-1)
4201 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4202 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4203 cgrad          do k=kstart,kend
4204 cgrad            do l=1,3
4205 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4206 cgrad            enddo
4207 cgrad          enddo
4208           do k=1,3
4209             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4210             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4211           enddo
4212         enddo
4213
4214         enddo ! iint
4215       enddo ! i
4216       do i=1,nct
4217         do j=1,3
4218           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4219           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4220           gradx_scp(j,i)=expon*gradx_scp(j,i)
4221         enddo
4222       enddo
4223 C******************************************************************************
4224 C
4225 C                              N O T E !!!
4226 C
4227 C To save time the factor EXPON has been extracted from ALL components
4228 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4229 C use!
4230 C
4231 C******************************************************************************
4232       return
4233       end
4234 C--------------------------------------------------------------------------
4235       subroutine edis(ehpb)
4236 C
4237 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4238 C
4239       implicit real*8 (a-h,o-z)
4240       include 'DIMENSIONS'
4241       include 'COMMON.SBRIDGE'
4242       include 'COMMON.CHAIN'
4243       include 'COMMON.DERIV'
4244       include 'COMMON.VAR'
4245       include 'COMMON.INTERACT'
4246       include 'COMMON.IOUNITS'
4247       dimension ggg(3)
4248       ehpb=0.0D0
4249 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4250 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4251       if (link_end.eq.0) return
4252       do i=link_start,link_end
4253 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4254 C CA-CA distance used in regularization of structure.
4255         ii=ihpb(i)
4256         jj=jhpb(i)
4257 C iii and jjj point to the residues for which the distance is assigned.
4258         if (ii.gt.nres) then
4259           iii=ii-nres
4260           jjj=jj-nres
4261         else
4262           iii=ii
4263           jjj=jj
4264         endif
4265 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4266 c     &    dhpb(i),dhpb1(i),forcon(i)
4267 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4268 C    distance and angle dependent SS bond potential.
4269         if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4270           call ssbond_ene(iii,jjj,eij)
4271           ehpb=ehpb+2*eij
4272 cd          write (iout,*) "eij",eij
4273         else if (ii.gt.nres .and. jj.gt.nres) then
4274 c Restraints from contact prediction
4275           dd=dist(ii,jj)
4276           if (dhpb1(i).gt.0.0d0) then
4277             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4278             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4279 c            write (iout,*) "beta nmr",
4280 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4281           else
4282             dd=dist(ii,jj)
4283             rdis=dd-dhpb(i)
4284 C Get the force constant corresponding to this distance.
4285             waga=forcon(i)
4286 C Calculate the contribution to energy.
4287             ehpb=ehpb+waga*rdis*rdis
4288 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
4289 C
4290 C Evaluate gradient.
4291 C
4292             fac=waga*rdis/dd
4293           endif
4294           do j=1,3
4295             ggg(j)=fac*(c(j,jj)-c(j,ii))
4296           enddo
4297           do j=1,3
4298             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4299             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4300           enddo
4301           do k=1,3
4302             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4303             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4304           enddo
4305         else
4306 C Calculate the distance between the two points and its difference from the
4307 C target distance.
4308           dd=dist(ii,jj)
4309           if (dhpb1(i).gt.0.0d0) then
4310             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4311             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4312 c            write (iout,*) "alph nmr",
4313 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4314           else
4315             rdis=dd-dhpb(i)
4316 C Get the force constant corresponding to this distance.
4317             waga=forcon(i)
4318 C Calculate the contribution to energy.
4319             ehpb=ehpb+waga*rdis*rdis
4320 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
4321 C
4322 C Evaluate gradient.
4323 C
4324             fac=waga*rdis/dd
4325           endif
4326 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4327 cd   &   ' waga=',waga,' fac=',fac
4328             do j=1,3
4329               ggg(j)=fac*(c(j,jj)-c(j,ii))
4330             enddo
4331 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4332 C If this is a SC-SC distance, we need to calculate the contributions to the
4333 C Cartesian gradient in the SC vectors (ghpbx).
4334           if (iii.lt.ii) then
4335           do j=1,3
4336             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4337             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4338           enddo
4339           endif
4340 cgrad        do j=iii,jjj-1
4341 cgrad          do k=1,3
4342 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4343 cgrad          enddo
4344 cgrad        enddo
4345           do k=1,3
4346             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4347             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4348           enddo
4349         endif
4350       enddo
4351       ehpb=0.5D0*ehpb
4352       return
4353       end
4354 C--------------------------------------------------------------------------
4355       subroutine ssbond_ene(i,j,eij)
4356 C
4357 C Calculate the distance and angle dependent SS-bond potential energy
4358 C using a free-energy function derived based on RHF/6-31G** ab initio
4359 C calculations of diethyl disulfide.
4360 C
4361 C A. Liwo and U. Kozlowska, 11/24/03
4362 C
4363       implicit real*8 (a-h,o-z)
4364       include 'DIMENSIONS'
4365       include 'COMMON.SBRIDGE'
4366       include 'COMMON.CHAIN'
4367       include 'COMMON.DERIV'
4368       include 'COMMON.LOCAL'
4369       include 'COMMON.INTERACT'
4370       include 'COMMON.VAR'
4371       include 'COMMON.IOUNITS'
4372       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4373       itypi=itype(i)
4374       xi=c(1,nres+i)
4375       yi=c(2,nres+i)
4376       zi=c(3,nres+i)
4377       dxi=dc_norm(1,nres+i)
4378       dyi=dc_norm(2,nres+i)
4379       dzi=dc_norm(3,nres+i)
4380 c      dsci_inv=dsc_inv(itypi)
4381       dsci_inv=vbld_inv(nres+i)
4382       itypj=itype(j)
4383 c      dscj_inv=dsc_inv(itypj)
4384       dscj_inv=vbld_inv(nres+j)
4385       xj=c(1,nres+j)-xi
4386       yj=c(2,nres+j)-yi
4387       zj=c(3,nres+j)-zi
4388       dxj=dc_norm(1,nres+j)
4389       dyj=dc_norm(2,nres+j)
4390       dzj=dc_norm(3,nres+j)
4391       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4392       rij=dsqrt(rrij)
4393       erij(1)=xj*rij
4394       erij(2)=yj*rij
4395       erij(3)=zj*rij
4396       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4397       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4398       om12=dxi*dxj+dyi*dyj+dzi*dzj
4399       do k=1,3
4400         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4401         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4402       enddo
4403       rij=1.0d0/rij
4404       deltad=rij-d0cm
4405       deltat1=1.0d0-om1
4406       deltat2=1.0d0+om2
4407       deltat12=om2-om1+2.0d0
4408       cosphi=om12-om1*om2
4409       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4410      &  +akct*deltad*deltat12
4411      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4412 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4413 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4414 c     &  " deltat12",deltat12," eij",eij
4415       ed=2*akcm*deltad+akct*deltat12
4416       pom1=akct*deltad
4417       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4418       eom1=-2*akth*deltat1-pom1-om2*pom2
4419       eom2= 2*akth*deltat2+pom1-om1*pom2
4420       eom12=pom2
4421       do k=1,3
4422         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4423         ghpbx(k,i)=ghpbx(k,i)-ggk
4424      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4425      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4426         ghpbx(k,j)=ghpbx(k,j)+ggk
4427      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4428      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4429         ghpbc(k,i)=ghpbc(k,i)-ggk
4430         ghpbc(k,j)=ghpbc(k,j)+ggk
4431       enddo
4432 C
4433 C Calculate the components of the gradient in DC and X
4434 C
4435 cgrad      do k=i,j-1
4436 cgrad        do l=1,3
4437 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4438 cgrad        enddo
4439 cgrad      enddo
4440       return
4441       end
4442 C--------------------------------------------------------------------------
4443       subroutine ebond(estr)
4444 c
4445 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4446 c
4447       implicit real*8 (a-h,o-z)
4448       include 'DIMENSIONS'
4449       include 'COMMON.LOCAL'
4450       include 'COMMON.GEO'
4451       include 'COMMON.INTERACT'
4452       include 'COMMON.DERIV'
4453       include 'COMMON.VAR'
4454       include 'COMMON.CHAIN'
4455       include 'COMMON.IOUNITS'
4456       include 'COMMON.NAMES'
4457       include 'COMMON.FFIELD'
4458       include 'COMMON.CONTROL'
4459       include 'COMMON.SETUP'
4460       double precision u(3),ud(3)
4461       estr=0.0d0
4462       do i=ibondp_start,ibondp_end
4463         diff = vbld(i)-vbldp0
4464 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4465         estr=estr+diff*diff
4466         do j=1,3
4467           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4468         enddo
4469 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4470       enddo
4471       estr=0.5d0*AKP*estr
4472 c
4473 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4474 c
4475       do i=ibond_start,ibond_end
4476         iti=itype(i)
4477         if (iti.ne.10) then
4478           nbi=nbondterm(iti)
4479           if (nbi.eq.1) then
4480             diff=vbld(i+nres)-vbldsc0(1,iti)
4481 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4482 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4483             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4484             do j=1,3
4485               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4486             enddo
4487           else
4488             do j=1,nbi
4489               diff=vbld(i+nres)-vbldsc0(j,iti)
4490               ud(j)=aksc(j,iti)*diff
4491               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4492             enddo
4493             uprod=u(1)
4494             do j=2,nbi
4495               uprod=uprod*u(j)
4496             enddo
4497             usum=0.0d0
4498             usumsqder=0.0d0
4499             do j=1,nbi
4500               uprod1=1.0d0
4501               uprod2=1.0d0
4502               do k=1,nbi
4503                 if (k.ne.j) then
4504                   uprod1=uprod1*u(k)
4505                   uprod2=uprod2*u(k)*u(k)
4506                 endif
4507               enddo
4508               usum=usum+uprod1
4509               usumsqder=usumsqder+ud(j)*uprod2
4510             enddo
4511             estr=estr+uprod/usum
4512             do j=1,3
4513              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4514             enddo
4515           endif
4516         endif
4517       enddo
4518       return
4519       end
4520 #ifdef CRYST_THETA
4521 C--------------------------------------------------------------------------
4522       subroutine ebend(etheta)
4523 C
4524 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4525 C angles gamma and its derivatives in consecutive thetas and gammas.
4526 C
4527       implicit real*8 (a-h,o-z)
4528       include 'DIMENSIONS'
4529       include 'COMMON.LOCAL'
4530       include 'COMMON.GEO'
4531       include 'COMMON.INTERACT'
4532       include 'COMMON.DERIV'
4533       include 'COMMON.VAR'
4534       include 'COMMON.CHAIN'
4535       include 'COMMON.IOUNITS'
4536       include 'COMMON.NAMES'
4537       include 'COMMON.FFIELD'
4538       include 'COMMON.CONTROL'
4539       common /calcthet/ term1,term2,termm,diffak,ratak,
4540      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4541      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4542       double precision y(2),z(2)
4543       delta=0.02d0*pi
4544 c      time11=dexp(-2*time)
4545 c      time12=1.0d0
4546       etheta=0.0D0
4547 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4548       do i=ithet_start,ithet_end
4549 C Zero the energy function and its derivative at 0 or pi.
4550         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4551         it=itype(i-1)
4552         if (i.gt.3) then
4553 #ifdef OSF
4554           phii=phi(i)
4555           if (phii.ne.phii) phii=150.0
4556 #else
4557           phii=phi(i)
4558 #endif
4559           y(1)=dcos(phii)
4560           y(2)=dsin(phii)
4561         else
4562           y(1)=0.0D0
4563           y(2)=0.0D0
4564         endif
4565         if (i.lt.nres) then
4566 #ifdef OSF
4567           phii1=phi(i+1)
4568           if (phii1.ne.phii1) phii1=150.0
4569           phii1=pinorm(phii1)
4570           z(1)=cos(phii1)
4571 #else
4572           phii1=phi(i+1)
4573           z(1)=dcos(phii1)
4574 #endif
4575           z(2)=dsin(phii1)
4576         else
4577           z(1)=0.0D0
4578           z(2)=0.0D0
4579         endif
4580 C Calculate the "mean" value of theta from the part of the distribution
4581 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4582 C In following comments this theta will be referred to as t_c.
4583         thet_pred_mean=0.0d0
4584         do k=1,2
4585           athetk=athet(k,it)
4586           bthetk=bthet(k,it)
4587           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4588         enddo
4589         dthett=thet_pred_mean*ssd
4590         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4591 C Derivatives of the "mean" values in gamma1 and gamma2.
4592         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
4593         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
4594         if (theta(i).gt.pi-delta) then
4595           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4596      &         E_tc0)
4597           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4598           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4599           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4600      &        E_theta)
4601           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4602      &        E_tc)
4603         else if (theta(i).lt.delta) then
4604           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4605           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4606           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4607      &        E_theta)
4608           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4609           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4610      &        E_tc)
4611         else
4612           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4613      &        E_theta,E_tc)
4614         endif
4615         etheta=etheta+ethetai
4616         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4617      &      'ebend',i,ethetai
4618         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4619         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4620         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4621       enddo
4622 C Ufff.... We've done all this!!!
4623       return
4624       end
4625 C---------------------------------------------------------------------------
4626       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4627      &     E_tc)
4628       implicit real*8 (a-h,o-z)
4629       include 'DIMENSIONS'
4630       include 'COMMON.LOCAL'
4631       include 'COMMON.IOUNITS'
4632       common /calcthet/ term1,term2,termm,diffak,ratak,
4633      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4634      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4635 C Calculate the contributions to both Gaussian lobes.
4636 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4637 C The "polynomial part" of the "standard deviation" of this part of
4638 C the distribution.
4639         sig=polthet(3,it)
4640         do j=2,0,-1
4641           sig=sig*thet_pred_mean+polthet(j,it)
4642         enddo
4643 C Derivative of the "interior part" of the "standard deviation of the"
4644 C gamma-dependent Gaussian lobe in t_c.
4645         sigtc=3*polthet(3,it)
4646         do j=2,1,-1
4647           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4648         enddo
4649         sigtc=sig*sigtc
4650 C Set the parameters of both Gaussian lobes of the distribution.
4651 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4652         fac=sig*sig+sigc0(it)
4653         sigcsq=fac+fac
4654         sigc=1.0D0/sigcsq
4655 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4656         sigsqtc=-4.0D0*sigcsq*sigtc
4657 c       print *,i,sig,sigtc,sigsqtc
4658 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4659         sigtc=-sigtc/(fac*fac)
4660 C Following variable is sigma(t_c)**(-2)
4661         sigcsq=sigcsq*sigcsq
4662         sig0i=sig0(it)
4663         sig0inv=1.0D0/sig0i**2
4664         delthec=thetai-thet_pred_mean
4665         delthe0=thetai-theta0i
4666         term1=-0.5D0*sigcsq*delthec*delthec
4667         term2=-0.5D0*sig0inv*delthe0*delthe0
4668 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4669 C NaNs in taking the logarithm. We extract the largest exponent which is added
4670 C to the energy (this being the log of the distribution) at the end of energy
4671 C term evaluation for this virtual-bond angle.
4672         if (term1.gt.term2) then
4673           termm=term1
4674           term2=dexp(term2-termm)
4675           term1=1.0d0
4676         else
4677           termm=term2
4678           term1=dexp(term1-termm)
4679           term2=1.0d0
4680         endif
4681 C The ratio between the gamma-independent and gamma-dependent lobes of
4682 C the distribution is a Gaussian function of thet_pred_mean too.
4683         diffak=gthet(2,it)-thet_pred_mean
4684         ratak=diffak/gthet(3,it)**2
4685         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4686 C Let's differentiate it in thet_pred_mean NOW.
4687         aktc=ak*ratak
4688 C Now put together the distribution terms to make complete distribution.
4689         termexp=term1+ak*term2
4690         termpre=sigc+ak*sig0i
4691 C Contribution of the bending energy from this theta is just the -log of
4692 C the sum of the contributions from the two lobes and the pre-exponential
4693 C factor. Simple enough, isn't it?
4694         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4695 C NOW the derivatives!!!
4696 C 6/6/97 Take into account the deformation.
4697         E_theta=(delthec*sigcsq*term1
4698      &       +ak*delthe0*sig0inv*term2)/termexp
4699         E_tc=((sigtc+aktc*sig0i)/termpre
4700      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4701      &       aktc*term2)/termexp)
4702       return
4703       end
4704 c-----------------------------------------------------------------------------
4705       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4706       implicit real*8 (a-h,o-z)
4707       include 'DIMENSIONS'
4708       include 'COMMON.LOCAL'
4709       include 'COMMON.IOUNITS'
4710       common /calcthet/ term1,term2,termm,diffak,ratak,
4711      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4712      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4713       delthec=thetai-thet_pred_mean
4714       delthe0=thetai-theta0i
4715 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4716       t3 = thetai-thet_pred_mean
4717       t6 = t3**2
4718       t9 = term1
4719       t12 = t3*sigcsq
4720       t14 = t12+t6*sigsqtc
4721       t16 = 1.0d0
4722       t21 = thetai-theta0i
4723       t23 = t21**2
4724       t26 = term2
4725       t27 = t21*t26
4726       t32 = termexp
4727       t40 = t32**2
4728       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4729      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4730      & *(-t12*t9-ak*sig0inv*t27)
4731       return
4732       end
4733 #else
4734 C--------------------------------------------------------------------------
4735       subroutine ebend(etheta)
4736 C
4737 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4738 C angles gamma and its derivatives in consecutive thetas and gammas.
4739 C ab initio-derived potentials from
4740 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4741 C
4742       implicit real*8 (a-h,o-z)
4743       include 'DIMENSIONS'
4744       include 'COMMON.LOCAL'
4745       include 'COMMON.GEO'
4746       include 'COMMON.INTERACT'
4747       include 'COMMON.DERIV'
4748       include 'COMMON.VAR'
4749       include 'COMMON.CHAIN'
4750       include 'COMMON.IOUNITS'
4751       include 'COMMON.NAMES'
4752       include 'COMMON.FFIELD'
4753       include 'COMMON.CONTROL'
4754       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4755      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4756      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4757      & sinph1ph2(maxdouble,maxdouble)
4758       logical lprn /.false./, lprn1 /.false./
4759       etheta=0.0D0
4760       do i=ithet_start,ithet_end
4761         dethetai=0.0d0
4762         dephii=0.0d0
4763         dephii1=0.0d0
4764         theti2=0.5d0*theta(i)
4765         ityp2=ithetyp(itype(i-1))
4766         do k=1,nntheterm
4767           coskt(k)=dcos(k*theti2)
4768           sinkt(k)=dsin(k*theti2)
4769         enddo
4770         if (i.gt.3) then
4771 #ifdef OSF
4772           phii=phi(i)
4773           if (phii.ne.phii) phii=150.0
4774 #else
4775           phii=phi(i)
4776 #endif
4777           ityp1=ithetyp(itype(i-2))
4778           do k=1,nsingle
4779             cosph1(k)=dcos(k*phii)
4780             sinph1(k)=dsin(k*phii)
4781           enddo
4782         else
4783           phii=0.0d0
4784           ityp1=nthetyp+1
4785           do k=1,nsingle
4786             cosph1(k)=0.0d0
4787             sinph1(k)=0.0d0
4788           enddo
4789         endif
4790         if (i.lt.nres) then
4791 #ifdef OSF
4792           phii1=phi(i+1)
4793           if (phii1.ne.phii1) phii1=150.0
4794           phii1=pinorm(phii1)
4795 #else
4796           phii1=phi(i+1)
4797 #endif
4798           ityp3=ithetyp(itype(i))
4799           do k=1,nsingle
4800             cosph2(k)=dcos(k*phii1)
4801             sinph2(k)=dsin(k*phii1)
4802           enddo
4803         else
4804           phii1=0.0d0
4805           ityp3=nthetyp+1
4806           do k=1,nsingle
4807             cosph2(k)=0.0d0
4808             sinph2(k)=0.0d0
4809           enddo
4810         endif
4811         ethetai=aa0thet(ityp1,ityp2,ityp3)
4812         do k=1,ndouble
4813           do l=1,k-1
4814             ccl=cosph1(l)*cosph2(k-l)
4815             ssl=sinph1(l)*sinph2(k-l)
4816             scl=sinph1(l)*cosph2(k-l)
4817             csl=cosph1(l)*sinph2(k-l)
4818             cosph1ph2(l,k)=ccl-ssl
4819             cosph1ph2(k,l)=ccl+ssl
4820             sinph1ph2(l,k)=scl+csl
4821             sinph1ph2(k,l)=scl-csl
4822           enddo
4823         enddo
4824         if (lprn) then
4825         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4826      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4827         write (iout,*) "coskt and sinkt"
4828         do k=1,nntheterm
4829           write (iout,*) k,coskt(k),sinkt(k)
4830         enddo
4831         endif
4832         do k=1,ntheterm
4833           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4834           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4835      &      *coskt(k)
4836           if (lprn)
4837      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4838      &     " ethetai",ethetai
4839         enddo
4840         if (lprn) then
4841         write (iout,*) "cosph and sinph"
4842         do k=1,nsingle
4843           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4844         enddo
4845         write (iout,*) "cosph1ph2 and sinph2ph2"
4846         do k=2,ndouble
4847           do l=1,k-1
4848             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4849      &         sinph1ph2(l,k),sinph1ph2(k,l)
4850           enddo
4851         enddo
4852         write(iout,*) "ethetai",ethetai
4853         endif
4854         do m=1,ntheterm2
4855           do k=1,nsingle
4856             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4857      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4858      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4859      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4860             ethetai=ethetai+sinkt(m)*aux
4861             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4862             dephii=dephii+k*sinkt(m)*(
4863      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4864      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4865             dephii1=dephii1+k*sinkt(m)*(
4866      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4867      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4868             if (lprn)
4869      &      write (iout,*) "m",m," k",k," bbthet",
4870      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4871      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4872      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4873      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4874           enddo
4875         enddo
4876         if (lprn)
4877      &  write(iout,*) "ethetai",ethetai
4878         do m=1,ntheterm3
4879           do k=2,ndouble
4880             do l=1,k-1
4881               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4882      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4883      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4884      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4885               ethetai=ethetai+sinkt(m)*aux
4886               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4887               dephii=dephii+l*sinkt(m)*(
4888      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4889      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4890      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4891      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4892               dephii1=dephii1+(k-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               if (lprn) then
4898               write (iout,*) "m",m," k",k," l",l," ffthet",
4899      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
4900      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
4901      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
4902      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4903               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4904      &            cosph1ph2(k,l)*sinkt(m),
4905      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4906               endif
4907             enddo
4908           enddo
4909         enddo
4910 10      continue
4911         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4912      &   i,theta(i)*rad2deg,phii*rad2deg,
4913      &   phii1*rad2deg,ethetai
4914         etheta=etheta+ethetai
4915         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4916         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4917         gloc(nphi+i-2,icg)=wang*dethetai
4918       enddo
4919       return
4920       end
4921 #endif
4922 #ifdef CRYST_SC
4923 c-----------------------------------------------------------------------------
4924       subroutine esc(escloc)
4925 C Calculate the local energy of a side chain and its derivatives in the
4926 C corresponding virtual-bond valence angles THETA and the spherical angles
4927 C ALPHA and OMEGA.
4928       implicit real*8 (a-h,o-z)
4929       include 'DIMENSIONS'
4930       include 'COMMON.GEO'
4931       include 'COMMON.LOCAL'
4932       include 'COMMON.VAR'
4933       include 'COMMON.INTERACT'
4934       include 'COMMON.DERIV'
4935       include 'COMMON.CHAIN'
4936       include 'COMMON.IOUNITS'
4937       include 'COMMON.NAMES'
4938       include 'COMMON.FFIELD'
4939       include 'COMMON.CONTROL'
4940       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4941      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4942       common /sccalc/ time11,time12,time112,theti,it,nlobit
4943       delta=0.02d0*pi
4944       escloc=0.0D0
4945 c     write (iout,'(a)') 'ESC'
4946       do i=loc_start,loc_end
4947         it=itype(i)
4948         if (it.eq.10) goto 1
4949         nlobit=nlob(it)
4950 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4951 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4952         theti=theta(i+1)-pipol
4953         x(1)=dtan(theti)
4954         x(2)=alph(i)
4955         x(3)=omeg(i)
4956
4957         if (x(2).gt.pi-delta) then
4958           xtemp(1)=x(1)
4959           xtemp(2)=pi-delta
4960           xtemp(3)=x(3)
4961           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4962           xtemp(2)=pi
4963           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4964           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4965      &        escloci,dersc(2))
4966           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4967      &        ddersc0(1),dersc(1))
4968           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4969      &        ddersc0(3),dersc(3))
4970           xtemp(2)=pi-delta
4971           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4972           xtemp(2)=pi
4973           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4974           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4975      &            dersc0(2),esclocbi,dersc02)
4976           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4977      &            dersc12,dersc01)
4978           call splinthet(x(2),0.5d0*delta,ss,ssd)
4979           dersc0(1)=dersc01
4980           dersc0(2)=dersc02
4981           dersc0(3)=0.0d0
4982           do k=1,3
4983             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4984           enddo
4985           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4986 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4987 c    &             esclocbi,ss,ssd
4988           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4989 c         escloci=esclocbi
4990 c         write (iout,*) escloci
4991         else if (x(2).lt.delta) then
4992           xtemp(1)=x(1)
4993           xtemp(2)=delta
4994           xtemp(3)=x(3)
4995           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4996           xtemp(2)=0.0d0
4997           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4998           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4999      &        escloci,dersc(2))
5000           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5001      &        ddersc0(1),dersc(1))
5002           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5003      &        ddersc0(3),dersc(3))
5004           xtemp(2)=delta
5005           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5006           xtemp(2)=0.0d0
5007           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5008           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5009      &            dersc0(2),esclocbi,dersc02)
5010           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5011      &            dersc12,dersc01)
5012           dersc0(1)=dersc01
5013           dersc0(2)=dersc02
5014           dersc0(3)=0.0d0
5015           call splinthet(x(2),0.5d0*delta,ss,ssd)
5016           do k=1,3
5017             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5018           enddo
5019           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5020 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5021 c    &             esclocbi,ss,ssd
5022           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5023 c         write (iout,*) escloci
5024         else
5025           call enesc(x,escloci,dersc,ddummy,.false.)
5026         endif
5027
5028         escloc=escloc+escloci
5029         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5030      &     'escloc',i,escloci
5031 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5032
5033         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5034      &   wscloc*dersc(1)
5035         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5036         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5037     1   continue
5038       enddo
5039       return
5040       end
5041 C---------------------------------------------------------------------------
5042       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5043       implicit real*8 (a-h,o-z)
5044       include 'DIMENSIONS'
5045       include 'COMMON.GEO'
5046       include 'COMMON.LOCAL'
5047       include 'COMMON.IOUNITS'
5048       common /sccalc/ time11,time12,time112,theti,it,nlobit
5049       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5050       double precision contr(maxlob,-1:1)
5051       logical mixed
5052 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5053         escloc_i=0.0D0
5054         do j=1,3
5055           dersc(j)=0.0D0
5056           if (mixed) ddersc(j)=0.0d0
5057         enddo
5058         x3=x(3)
5059
5060 C Because of periodicity of the dependence of the SC energy in omega we have
5061 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5062 C To avoid underflows, first compute & store the exponents.
5063
5064         do iii=-1,1
5065
5066           x(3)=x3+iii*dwapi
5067
5068           do j=1,nlobit
5069             do k=1,3
5070               z(k)=x(k)-censc(k,j,it)
5071             enddo
5072             do k=1,3
5073               Axk=0.0D0
5074               do l=1,3
5075                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5076               enddo
5077               Ax(k,j,iii)=Axk
5078             enddo
5079             expfac=0.0D0
5080             do k=1,3
5081               expfac=expfac+Ax(k,j,iii)*z(k)
5082             enddo
5083             contr(j,iii)=expfac
5084           enddo ! j
5085
5086         enddo ! iii
5087
5088         x(3)=x3
5089 C As in the case of ebend, we want to avoid underflows in exponentiation and
5090 C subsequent NaNs and INFs in energy calculation.
5091 C Find the largest exponent
5092         emin=contr(1,-1)
5093         do iii=-1,1
5094           do j=1,nlobit
5095             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5096           enddo
5097         enddo
5098         emin=0.5D0*emin
5099 cd      print *,'it=',it,' emin=',emin
5100
5101 C Compute the contribution to SC energy and derivatives
5102         do iii=-1,1
5103
5104           do j=1,nlobit
5105 #ifdef OSF
5106             adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin
5107             if(adexp.ne.adexp) adexp=1.0
5108             expfac=dexp(adexp)
5109 #else
5110             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
5111 #endif
5112 cd          print *,'j=',j,' expfac=',expfac
5113             escloc_i=escloc_i+expfac
5114             do k=1,3
5115               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5116             enddo
5117             if (mixed) then
5118               do k=1,3,2
5119                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5120      &            +gaussc(k,2,j,it))*expfac
5121               enddo
5122             endif
5123           enddo
5124
5125         enddo ! iii
5126
5127         dersc(1)=dersc(1)/cos(theti)**2
5128         ddersc(1)=ddersc(1)/cos(theti)**2
5129         ddersc(3)=ddersc(3)
5130
5131         escloci=-(dlog(escloc_i)-emin)
5132         do j=1,3
5133           dersc(j)=dersc(j)/escloc_i
5134         enddo
5135         if (mixed) then
5136           do j=1,3,2
5137             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5138           enddo
5139         endif
5140       return
5141       end
5142 C------------------------------------------------------------------------------
5143       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5144       implicit real*8 (a-h,o-z)
5145       include 'DIMENSIONS'
5146       include 'COMMON.GEO'
5147       include 'COMMON.LOCAL'
5148       include 'COMMON.IOUNITS'
5149       common /sccalc/ time11,time12,time112,theti,it,nlobit
5150       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5151       double precision contr(maxlob)
5152       logical mixed
5153
5154       escloc_i=0.0D0
5155
5156       do j=1,3
5157         dersc(j)=0.0D0
5158       enddo
5159
5160       do j=1,nlobit
5161         do k=1,2
5162           z(k)=x(k)-censc(k,j,it)
5163         enddo
5164         z(3)=dwapi
5165         do k=1,3
5166           Axk=0.0D0
5167           do l=1,3
5168             Axk=Axk+gaussc(l,k,j,it)*z(l)
5169           enddo
5170           Ax(k,j)=Axk
5171         enddo
5172         expfac=0.0D0
5173         do k=1,3
5174           expfac=expfac+Ax(k,j)*z(k)
5175         enddo
5176         contr(j)=expfac
5177       enddo ! j
5178
5179 C As in the case of ebend, we want to avoid underflows in exponentiation and
5180 C subsequent NaNs and INFs in energy calculation.
5181 C Find the largest exponent
5182       emin=contr(1)
5183       do j=1,nlobit
5184         if (emin.gt.contr(j)) emin=contr(j)
5185       enddo
5186       emin=0.5D0*emin
5187
5188 C Compute the contribution to SC energy and derivatives
5189
5190       dersc12=0.0d0
5191       do j=1,nlobit
5192         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
5193         escloc_i=escloc_i+expfac
5194         do k=1,2
5195           dersc(k)=dersc(k)+Ax(k,j)*expfac
5196         enddo
5197         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5198      &            +gaussc(1,2,j,it))*expfac
5199         dersc(3)=0.0d0
5200       enddo
5201
5202       dersc(1)=dersc(1)/cos(theti)**2
5203       dersc12=dersc12/cos(theti)**2
5204       escloci=-(dlog(escloc_i)-emin)
5205       do j=1,2
5206         dersc(j)=dersc(j)/escloc_i
5207       enddo
5208       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5209       return
5210       end
5211 #else
5212 c----------------------------------------------------------------------------------
5213       subroutine esc(escloc)
5214 C Calculate the local energy of a side chain and its derivatives in the
5215 C corresponding virtual-bond valence angles THETA and the spherical angles
5216 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5217 C added by Urszula Kozlowska. 07/11/2007
5218 C
5219       implicit real*8 (a-h,o-z)
5220       include 'DIMENSIONS'
5221       include 'COMMON.GEO'
5222       include 'COMMON.LOCAL'
5223       include 'COMMON.VAR'
5224       include 'COMMON.SCROT'
5225       include 'COMMON.INTERACT'
5226       include 'COMMON.DERIV'
5227       include 'COMMON.CHAIN'
5228       include 'COMMON.IOUNITS'
5229       include 'COMMON.NAMES'
5230       include 'COMMON.FFIELD'
5231       include 'COMMON.CONTROL'
5232       include 'COMMON.VECTORS'
5233       double precision x_prime(3),y_prime(3),z_prime(3)
5234      &    , sumene,dsc_i,dp2_i,x(65),
5235      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5236      &    de_dxx,de_dyy,de_dzz,de_dt
5237       double precision s1_t,s1_6_t,s2_t,s2_6_t
5238       double precision
5239      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5240      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5241      & dt_dCi(3),dt_dCi1(3)
5242       common /sccalc/ time11,time12,time112,theti,it,nlobit
5243       delta=0.02d0*pi
5244       escloc=0.0D0
5245       do i=loc_start,loc_end
5246         costtab(i+1) =dcos(theta(i+1))
5247         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5248         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5249         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5250         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5251         cosfac=dsqrt(cosfac2)
5252         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5253         sinfac=dsqrt(sinfac2)
5254         it=itype(i)
5255         if (it.eq.10) goto 1
5256 c
5257 C  Compute the axes of tghe local cartesian coordinates system; store in
5258 c   x_prime, y_prime and z_prime
5259 c
5260         do j=1,3
5261           x_prime(j) = 0.00
5262           y_prime(j) = 0.00
5263           z_prime(j) = 0.00
5264         enddo
5265 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5266 C     &   dc_norm(3,i+nres)
5267         do j = 1,3
5268           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5269           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5270         enddo
5271         do j = 1,3
5272           z_prime(j) = -uz(j,i-1)
5273         enddo
5274 c       write (2,*) "i",i
5275 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5276 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5277 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5278 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5279 c      & " xy",scalar(x_prime(1),y_prime(1)),
5280 c      & " xz",scalar(x_prime(1),z_prime(1)),
5281 c      & " yy",scalar(y_prime(1),y_prime(1)),
5282 c      & " yz",scalar(y_prime(1),z_prime(1)),
5283 c      & " zz",scalar(z_prime(1),z_prime(1))
5284 c
5285 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5286 C to local coordinate system. Store in xx, yy, zz.
5287 c
5288         xx=0.0d0
5289         yy=0.0d0
5290         zz=0.0d0
5291         do j = 1,3
5292           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5293           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5294           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5295         enddo
5296
5297         xxtab(i)=xx
5298         yytab(i)=yy
5299         zztab(i)=zz
5300 C
5301 C Compute the energy of the ith side cbain
5302 C
5303 c        write (2,*) "xx",xx," yy",yy," zz",zz
5304         it=itype(i)
5305         do j = 1,65
5306           x(j) = sc_parmin(j,it)
5307         enddo
5308 #ifdef CHECK_COORD
5309 Cc diagnostics - remove later
5310         xx1 = dcos(alph(2))
5311         yy1 = dsin(alph(2))*dcos(omeg(2))
5312         zz1 = -dsin(alph(2))*dsin(omeg(2))
5313         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5314      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5315      &    xx1,yy1,zz1
5316 C,"  --- ", xx_w,yy_w,zz_w
5317 c end diagnostics
5318 #endif
5319         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5320      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5321      &   + x(10)*yy*zz
5322         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5323      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5324      & + x(20)*yy*zz
5325         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5326      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5327      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5328      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5329      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5330      &  +x(40)*xx*yy*zz
5331         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5332      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5333      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5334      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5335      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5336      &  +x(60)*xx*yy*zz
5337         dsc_i   = 0.743d0+x(61)
5338         dp2_i   = 1.9d0+x(62)
5339         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5340      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5341         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5342      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5343         s1=(1+x(63))/(0.1d0 + dscp1)
5344         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5345         s2=(1+x(65))/(0.1d0 + dscp2)
5346         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5347         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5348      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5349 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5350 c     &   sumene4,
5351 c     &   dscp1,dscp2,sumene
5352 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5353         escloc = escloc + sumene
5354 c        write (2,*) "i",i," escloc",sumene,escloc
5355 #ifdef DEBUG
5356 C
5357 C This section to check the numerical derivatives of the energy of ith side
5358 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5359 C #define DEBUG in the code to turn it on.
5360 C
5361         write (2,*) "sumene               =",sumene
5362         aincr=1.0d-7
5363         xxsave=xx
5364         xx=xx+aincr
5365         write (2,*) xx,yy,zz
5366         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5367         de_dxx_num=(sumenep-sumene)/aincr
5368         xx=xxsave
5369         write (2,*) "xx+ sumene from enesc=",sumenep
5370         yysave=yy
5371         yy=yy+aincr
5372         write (2,*) xx,yy,zz
5373         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5374         de_dyy_num=(sumenep-sumene)/aincr
5375         yy=yysave
5376         write (2,*) "yy+ sumene from enesc=",sumenep
5377         zzsave=zz
5378         zz=zz+aincr
5379         write (2,*) xx,yy,zz
5380         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5381         de_dzz_num=(sumenep-sumene)/aincr
5382         zz=zzsave
5383         write (2,*) "zz+ sumene from enesc=",sumenep
5384         costsave=cost2tab(i+1)
5385         sintsave=sint2tab(i+1)
5386         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5387         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5388         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5389         de_dt_num=(sumenep-sumene)/aincr
5390         write (2,*) " t+ sumene from enesc=",sumenep
5391         cost2tab(i+1)=costsave
5392         sint2tab(i+1)=sintsave
5393 C End of diagnostics section.
5394 #endif
5395 C
5396 C Compute the gradient of esc
5397 C
5398         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5399         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5400         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5401         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5402         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5403         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5404         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5405         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5406         pom1=(sumene3*sint2tab(i+1)+sumene1)
5407      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5408         pom2=(sumene4*cost2tab(i+1)+sumene2)
5409      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5410         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5411         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5412      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5413      &  +x(40)*yy*zz
5414         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5415         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5416      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5417      &  +x(60)*yy*zz
5418         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5419      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5420      &        +(pom1+pom2)*pom_dx
5421 #ifdef DEBUG
5422         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5423 #endif
5424 C
5425         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5426         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5427      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5428      &  +x(40)*xx*zz
5429         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5430         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5431      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5432      &  +x(59)*zz**2 +x(60)*xx*zz
5433         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5434      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5435      &        +(pom1-pom2)*pom_dy
5436 #ifdef DEBUG
5437         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5438 #endif
5439 C
5440         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5441      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5442      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5443      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5444      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5445      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5446      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5447      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5448 #ifdef DEBUG
5449         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5450 #endif
5451 C
5452         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5453      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5454      &  +pom1*pom_dt1+pom2*pom_dt2
5455 #ifdef DEBUG
5456         write(2,*), "de_dt = ", de_dt,de_dt_num
5457 #endif
5458 c
5459 C
5460        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5461        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5462        cosfac2xx=cosfac2*xx
5463        sinfac2yy=sinfac2*yy
5464        do k = 1,3
5465          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5466      &      vbld_inv(i+1)
5467          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5468      &      vbld_inv(i)
5469          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5470          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5471 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5472 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5473 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5474 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5475          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5476          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5477          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5478          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5479          dZZ_Ci1(k)=0.0d0
5480          dZZ_Ci(k)=0.0d0
5481          do j=1,3
5482            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5483            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5484          enddo
5485
5486          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5487          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5488          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5489 c
5490          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5491          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5492        enddo
5493
5494        do k=1,3
5495          dXX_Ctab(k,i)=dXX_Ci(k)
5496          dXX_C1tab(k,i)=dXX_Ci1(k)
5497          dYY_Ctab(k,i)=dYY_Ci(k)
5498          dYY_C1tab(k,i)=dYY_Ci1(k)
5499          dZZ_Ctab(k,i)=dZZ_Ci(k)
5500          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5501          dXX_XYZtab(k,i)=dXX_XYZ(k)
5502          dYY_XYZtab(k,i)=dYY_XYZ(k)
5503          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5504        enddo
5505
5506        do k = 1,3
5507 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5508 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5509 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5510 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5511 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5512 c     &    dt_dci(k)
5513 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5514 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5515          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5516      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5517          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5518      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5519          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5520      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5521        enddo
5522 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5523 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5524
5525 C to check gradient call subroutine check_grad
5526
5527     1 continue
5528       enddo
5529       return
5530       end
5531 c------------------------------------------------------------------------------
5532       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5533       implicit none
5534       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5535      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5536       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5537      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5538      &   + x(10)*yy*zz
5539       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5540      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5541      & + x(20)*yy*zz
5542       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5543      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5544      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5545      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5546      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5547      &  +x(40)*xx*yy*zz
5548       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5549      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5550      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5551      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5552      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5553      &  +x(60)*xx*yy*zz
5554       dsc_i   = 0.743d0+x(61)
5555       dp2_i   = 1.9d0+x(62)
5556       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5557      &          *(xx*cost2+yy*sint2))
5558       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5559      &          *(xx*cost2-yy*sint2))
5560       s1=(1+x(63))/(0.1d0 + dscp1)
5561       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5562       s2=(1+x(65))/(0.1d0 + dscp2)
5563       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5564       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5565      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5566       enesc=sumene
5567       return
5568       end
5569 #endif
5570 c------------------------------------------------------------------------------
5571       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5572 C
5573 C This procedure calculates two-body contact function g(rij) and its derivative:
5574 C
5575 C           eps0ij                                     !       x < -1
5576 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5577 C            0                                         !       x > 1
5578 C
5579 C where x=(rij-r0ij)/delta
5580 C
5581 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5582 C
5583       implicit none
5584       double precision rij,r0ij,eps0ij,fcont,fprimcont
5585       double precision x,x2,x4,delta
5586 c     delta=0.02D0*r0ij
5587 c      delta=0.2D0*r0ij
5588       x=(rij-r0ij)/delta
5589       if (x.lt.-1.0D0) then
5590         fcont=eps0ij
5591         fprimcont=0.0D0
5592       else if (x.le.1.0D0) then
5593         x2=x*x
5594         x4=x2*x2
5595         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5596         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5597       else
5598         fcont=0.0D0
5599         fprimcont=0.0D0
5600       endif
5601       return
5602       end
5603 c------------------------------------------------------------------------------
5604       subroutine splinthet(theti,delta,ss,ssder)
5605       implicit real*8 (a-h,o-z)
5606       include 'DIMENSIONS'
5607       include 'COMMON.VAR'
5608       include 'COMMON.GEO'
5609       thetup=pi-delta
5610       thetlow=delta
5611       if (theti.gt.pipol) then
5612         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5613       else
5614         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5615         ssder=-ssder
5616       endif
5617       return
5618       end
5619 c------------------------------------------------------------------------------
5620       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5621       implicit none
5622       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5623       double precision ksi,ksi2,ksi3,a1,a2,a3
5624       a1=fprim0*delta/(f1-f0)
5625       a2=3.0d0-2.0d0*a1
5626       a3=a1-2.0d0
5627       ksi=(x-x0)/delta
5628       ksi2=ksi*ksi
5629       ksi3=ksi2*ksi
5630       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5631       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5632       return
5633       end
5634 c------------------------------------------------------------------------------
5635       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5636       implicit none
5637       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5638       double precision ksi,ksi2,ksi3,a1,a2,a3
5639       ksi=(x-x0)/delta
5640       ksi2=ksi*ksi
5641       ksi3=ksi2*ksi
5642       a1=fprim0x*delta
5643       a2=3*(f1x-f0x)-2*fprim0x*delta
5644       a3=fprim0x*delta-2*(f1x-f0x)
5645       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5646       return
5647       end
5648 C-----------------------------------------------------------------------------
5649 #ifdef CRYST_TOR
5650 C-----------------------------------------------------------------------------
5651       subroutine etor(etors,edihcnstr)
5652       implicit real*8 (a-h,o-z)
5653       include 'DIMENSIONS'
5654       include 'COMMON.VAR'
5655       include 'COMMON.GEO'
5656       include 'COMMON.LOCAL'
5657       include 'COMMON.TORSION'
5658       include 'COMMON.INTERACT'
5659       include 'COMMON.DERIV'
5660       include 'COMMON.CHAIN'
5661       include 'COMMON.NAMES'
5662       include 'COMMON.IOUNITS'
5663       include 'COMMON.FFIELD'
5664       include 'COMMON.TORCNSTR'
5665       include 'COMMON.CONTROL'
5666       logical lprn
5667 C Set lprn=.true. for debugging
5668       lprn=.false.
5669 c      lprn=.true.
5670       etors=0.0D0
5671       do i=iphi_start,iphi_end
5672       etors_ii=0.0D0
5673         itori=itortyp(itype(i-2))
5674         itori1=itortyp(itype(i-1))
5675         phii=phi(i)
5676         gloci=0.0D0
5677 C Proline-Proline pair is a special case...
5678         if (itori.eq.3 .and. itori1.eq.3) then
5679           if (phii.gt.-dwapi3) then
5680             cosphi=dcos(3*phii)
5681             fac=1.0D0/(1.0D0-cosphi)
5682             etorsi=v1(1,3,3)*fac
5683             etorsi=etorsi+etorsi
5684             etors=etors+etorsi-v1(1,3,3)
5685             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5686             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5687           endif
5688           do j=1,3
5689             v1ij=v1(j+1,itori,itori1)
5690             v2ij=v2(j+1,itori,itori1)
5691             cosphi=dcos(j*phii)
5692             sinphi=dsin(j*phii)
5693             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5694             if (energy_dec) etors_ii=etors_ii+
5695      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5696             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5697           enddo
5698         else
5699           do j=1,nterm_old
5700             v1ij=v1(j,itori,itori1)
5701             v2ij=v2(j,itori,itori1)
5702             cosphi=dcos(j*phii)
5703             sinphi=dsin(j*phii)
5704             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5705             if (energy_dec) etors_ii=etors_ii+
5706      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5707             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5708           enddo
5709         endif
5710         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5711      &        'etor',i,etors_ii
5712         if (lprn)
5713      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5714      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5715      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5716         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5717         write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5718       enddo
5719 ! 6/20/98 - dihedral angle constraints
5720       edihcnstr=0.0d0
5721       do i=1,ndih_constr
5722         itori=idih_constr(i)
5723         phii=phi(itori)
5724         difi=phii-phi0(i)
5725         if (difi.gt.drange(i)) then
5726           difi=difi-drange(i)
5727           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5728           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5729         else if (difi.lt.-drange(i)) then
5730           difi=difi+drange(i)
5731           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5732           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5733         endif
5734 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5735 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5736       enddo
5737 !      write (iout,*) 'edihcnstr',edihcnstr
5738       return
5739       end
5740 c------------------------------------------------------------------------------
5741       subroutine etor_d(etors_d)
5742       etors_d=0.0d0
5743       return
5744       end
5745 c----------------------------------------------------------------------------
5746 #else
5747       subroutine etor(etors,edihcnstr)
5748       implicit real*8 (a-h,o-z)
5749       include 'DIMENSIONS'
5750       include 'COMMON.VAR'
5751       include 'COMMON.GEO'
5752       include 'COMMON.LOCAL'
5753       include 'COMMON.TORSION'
5754       include 'COMMON.INTERACT'
5755       include 'COMMON.DERIV'
5756       include 'COMMON.CHAIN'
5757       include 'COMMON.NAMES'
5758       include 'COMMON.IOUNITS'
5759       include 'COMMON.FFIELD'
5760       include 'COMMON.TORCNSTR'
5761       include 'COMMON.CONTROL'
5762       logical lprn
5763 C Set lprn=.true. for debugging
5764       lprn=.false.
5765 c     lprn=.true.
5766       etors=0.0D0
5767       do i=iphi_start,iphi_end
5768       etors_ii=0.0D0
5769         itori=itortyp(itype(i-2))
5770         itori1=itortyp(itype(i-1))
5771         phii=phi(i)
5772         gloci=0.0D0
5773 C Regular cosine and sine terms
5774         do j=1,nterm(itori,itori1)
5775           v1ij=v1(j,itori,itori1)
5776           v2ij=v2(j,itori,itori1)
5777           cosphi=dcos(j*phii)
5778           sinphi=dsin(j*phii)
5779           etors=etors+v1ij*cosphi+v2ij*sinphi
5780           if (energy_dec) etors_ii=etors_ii+
5781      &                v1ij*cosphi+v2ij*sinphi
5782           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5783         enddo
5784 C Lorentz terms
5785 C                         v1
5786 C  E = SUM ----------------------------------- - v1
5787 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5788 C
5789         cosphi=dcos(0.5d0*phii)
5790         sinphi=dsin(0.5d0*phii)
5791         do j=1,nlor(itori,itori1)
5792           vl1ij=vlor1(j,itori,itori1)
5793           vl2ij=vlor2(j,itori,itori1)
5794           vl3ij=vlor3(j,itori,itori1)
5795           pom=vl2ij*cosphi+vl3ij*sinphi
5796           pom1=1.0d0/(pom*pom+1.0d0)
5797           etors=etors+vl1ij*pom1
5798           if (energy_dec) etors_ii=etors_ii+
5799      &                vl1ij*pom1
5800           pom=-pom*pom1*pom1
5801           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5802         enddo
5803 C Subtract the constant term
5804         etors=etors-v0(itori,itori1)
5805           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5806      &         'etor',i,etors_ii-v0(itori,itori1)
5807         if (lprn)
5808      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5809      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5810      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5811         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5812 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5813       enddo
5814 ! 6/20/98 - dihedral angle constraints
5815       edihcnstr=0.0d0
5816 c      do i=1,ndih_constr
5817       do i=idihconstr_start,idihconstr_end
5818         itori=idih_constr(i)
5819         phii=phi(itori)
5820         difi=pinorm(phii-phi0(i))
5821         if (difi.gt.drange(i)) then
5822           difi=difi-drange(i)
5823           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5824           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5825         else if (difi.lt.-drange(i)) then
5826           difi=difi+drange(i)
5827           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5828           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5829         else
5830           difi=0.0
5831         endif
5832 c        write (iout,*) "gloci", gloc(i-3,icg)
5833 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5834 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5835 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5836       enddo
5837 cd       write (iout,*) 'edihcnstr',edihcnstr
5838       return
5839       end
5840 c----------------------------------------------------------------------------
5841       subroutine etor_d(etors_d)
5842 C 6/23/01 Compute double torsional energy
5843       implicit real*8 (a-h,o-z)
5844       include 'DIMENSIONS'
5845       include 'COMMON.VAR'
5846       include 'COMMON.GEO'
5847       include 'COMMON.LOCAL'
5848       include 'COMMON.TORSION'
5849       include 'COMMON.INTERACT'
5850       include 'COMMON.DERIV'
5851       include 'COMMON.CHAIN'
5852       include 'COMMON.NAMES'
5853       include 'COMMON.IOUNITS'
5854       include 'COMMON.FFIELD'
5855       include 'COMMON.TORCNSTR'
5856       logical lprn
5857 C Set lprn=.true. for debugging
5858       lprn=.false.
5859 c     lprn=.true.
5860       etors_d=0.0D0
5861       do i=iphid_start,iphid_end
5862         itori=itortyp(itype(i-2))
5863         itori1=itortyp(itype(i-1))
5864         itori2=itortyp(itype(i))
5865         phii=phi(i)
5866         phii1=phi(i+1)
5867         gloci1=0.0D0
5868         gloci2=0.0D0
5869         do j=1,ntermd_1(itori,itori1,itori2)
5870           v1cij=v1c(1,j,itori,itori1,itori2)
5871           v1sij=v1s(1,j,itori,itori1,itori2)
5872           v2cij=v1c(2,j,itori,itori1,itori2)
5873           v2sij=v1s(2,j,itori,itori1,itori2)
5874           cosphi1=dcos(j*phii)
5875           sinphi1=dsin(j*phii)
5876           cosphi2=dcos(j*phii1)
5877           sinphi2=dsin(j*phii1)
5878           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5879      &     v2cij*cosphi2+v2sij*sinphi2
5880           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5881           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5882         enddo
5883         do k=2,ntermd_2(itori,itori1,itori2)
5884           do l=1,k-1
5885             v1cdij = v2c(k,l,itori,itori1,itori2)
5886             v2cdij = v2c(l,k,itori,itori1,itori2)
5887             v1sdij = v2s(k,l,itori,itori1,itori2)
5888             v2sdij = v2s(l,k,itori,itori1,itori2)
5889             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5890             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5891             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5892             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5893             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5894      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5895             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5896      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5897             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5898      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5899           enddo
5900         enddo
5901         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5902         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5903 c        write (iout,*) "gloci", gloc(i-3,icg)
5904       enddo
5905       return
5906       end
5907 #endif
5908 c------------------------------------------------------------------------------
5909       subroutine eback_sc_corr(esccor)
5910 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5911 c        conformational states; temporarily implemented as differences
5912 c        between UNRES torsional potentials (dependent on three types of
5913 c        residues) and the torsional potentials dependent on all 20 types
5914 c        of residues computed from AM1  energy surfaces of terminally-blocked
5915 c        amino-acid residues.
5916       implicit real*8 (a-h,o-z)
5917       include 'DIMENSIONS'
5918       include 'COMMON.VAR'
5919       include 'COMMON.GEO'
5920       include 'COMMON.LOCAL'
5921       include 'COMMON.TORSION'
5922       include 'COMMON.SCCOR'
5923       include 'COMMON.INTERACT'
5924       include 'COMMON.DERIV'
5925       include 'COMMON.CHAIN'
5926       include 'COMMON.NAMES'
5927       include 'COMMON.IOUNITS'
5928       include 'COMMON.FFIELD'
5929       include 'COMMON.CONTROL'
5930       logical lprn
5931 C Set lprn=.true. for debugging
5932       lprn=.false.
5933 c      lprn=.true.
5934 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
5935       esccor=0.0D0
5936       do i=itau_start,itau_end
5937         esccor_ii=0.0D0
5938         isccori=isccortyp(itype(i-2))
5939         isccori1=isccortyp(itype(i-1))
5940         phii=phi(i)
5941 cccc  Added 9 May 2012
5942 cc Tauangle is torsional engle depending on the value of first digit
5943 c(see comment below)
5944 cc Omicron is flat angle depending on the value of first digit
5945 c(see comment below)
5946
5947
5948         do intertyp=1,3 !intertyp
5949 cc Added 09 May 2012 (Adasko)
5950 cc  Intertyp means interaction type of backbone mainchain correlation:
5951 c   1 = SC...Ca...Ca...Ca
5952 c   2 = Ca...Ca...Ca...SC
5953 c   3 = SC...Ca...Ca...SCi
5954         gloci=0.0D0
5955         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5956      &      (itype(i-1).eq.10).or.(itype(i-2).eq.21).or.
5957      &      (itype(i-1).eq.21)))
5958      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5959      &     .or.(itype(i-2).eq.21)))
5960      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5961      &      (itype(i-1).eq.21)))) cycle
5962         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle
5963         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21))
5964      & cycle
5965         do j=1,nterm_sccor(isccori,isccori1)
5966           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5967           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5968           cosphi=dcos(j*tauangle(intertyp,i))
5969           sinphi=dsin(j*tauangle(intertyp,i))
5970           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5971           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5972         enddo
5973         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5974 c        write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
5975 c     &gloc_sc(intertyp,i-3,icg)
5976         if (lprn)
5977      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5978      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5979      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
5980      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
5981         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5982        enddo !intertyp
5983       enddo
5984 c        do i=1,nres
5985 c        write (iout,*) "W@T@F",  gloc_sc(1,i,icg),gloc(i,icg)
5986 c        enddo
5987       return
5988       end
5989 c----------------------------------------------------------------------------
5990       subroutine multibody(ecorr)
5991 C This subroutine calculates multi-body contributions to energy following
5992 C the idea of Skolnick et al. If side chains I and J make a contact and
5993 C at the same time side chains I+1 and J+1 make a contact, an extra
5994 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5995       implicit real*8 (a-h,o-z)
5996       include 'DIMENSIONS'
5997       include 'COMMON.IOUNITS'
5998       include 'COMMON.DERIV'
5999       include 'COMMON.INTERACT'
6000       include 'COMMON.CONTACTS'
6001       double precision gx(3),gx1(3)
6002       logical lprn
6003
6004 C Set lprn=.true. for debugging
6005       lprn=.false.
6006
6007       if (lprn) then
6008         write (iout,'(a)') 'Contact function values:'
6009         do i=nnt,nct-2
6010           write (iout,'(i2,20(1x,i2,f10.5))')
6011      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6012         enddo
6013       endif
6014       ecorr=0.0D0
6015       do i=nnt,nct
6016         do j=1,3
6017           gradcorr(j,i)=0.0D0
6018           gradxorr(j,i)=0.0D0
6019         enddo
6020       enddo
6021       do i=nnt,nct-2
6022
6023         DO ISHIFT = 3,4
6024
6025         i1=i+ishift
6026         num_conti=num_cont(i)
6027         num_conti1=num_cont(i1)
6028         do jj=1,num_conti
6029           j=jcont(jj,i)
6030           do kk=1,num_conti1
6031             j1=jcont(kk,i1)
6032             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6033 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6034 cd   &                   ' ishift=',ishift
6035 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6036 C The system gains extra energy.
6037               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6038             endif   ! j1==j+-ishift
6039           enddo     ! kk
6040         enddo       ! jj
6041
6042         ENDDO ! ISHIFT
6043
6044       enddo         ! i
6045       return
6046       end
6047 c------------------------------------------------------------------------------
6048       double precision function esccorr(i,j,k,l,jj,kk)
6049       implicit real*8 (a-h,o-z)
6050       include 'DIMENSIONS'
6051       include 'COMMON.IOUNITS'
6052       include 'COMMON.DERIV'
6053       include 'COMMON.INTERACT'
6054       include 'COMMON.CONTACTS'
6055       double precision gx(3),gx1(3)
6056       logical lprn
6057       lprn=.false.
6058       eij=facont(jj,i)
6059       ekl=facont(kk,k)
6060 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6061 C Calculate the multi-body contribution to energy.
6062 C Calculate multi-body contributions to the gradient.
6063 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6064 cd   & k,l,(gacont(m,kk,k),m=1,3)
6065       do m=1,3
6066         gx(m) =ekl*gacont(m,jj,i)
6067         gx1(m)=eij*gacont(m,kk,k)
6068         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6069         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6070         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6071         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6072       enddo
6073       do m=i,j-1
6074         do ll=1,3
6075           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6076         enddo
6077       enddo
6078       do m=k,l-1
6079         do ll=1,3
6080           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6081         enddo
6082       enddo
6083       esccorr=-eij*ekl
6084       return
6085       end
6086 c------------------------------------------------------------------------------
6087       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6088 C This subroutine calculates multi-body contributions to hydrogen-bonding
6089       implicit real*8 (a-h,o-z)
6090       include 'DIMENSIONS'
6091       include 'COMMON.IOUNITS'
6092 #ifdef MPI
6093       include "mpif.h"
6094       parameter (max_cont=maxconts)
6095       parameter (max_dim=26)
6096       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6097       double precision zapas(max_dim,maxconts,max_fg_procs),
6098      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6099       common /przechowalnia/ zapas
6100       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6101      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6102 #endif
6103       include 'COMMON.SETUP'
6104       include 'COMMON.FFIELD'
6105       include 'COMMON.DERIV'
6106       include 'COMMON.INTERACT'
6107       include 'COMMON.CONTACTS'
6108       include 'COMMON.CONTROL'
6109       include 'COMMON.LOCAL'
6110       double precision gx(3),gx1(3),time00
6111       logical lprn,ldone
6112
6113 C Set lprn=.true. for debugging
6114       lprn=.false.
6115 #ifdef MPI
6116       n_corr=0
6117       n_corr1=0
6118       if (nfgtasks.le.1) goto 30
6119       if (lprn) then
6120         write (iout,'(a)') 'Contact function values before RECEIVE:'
6121         do i=nnt,nct-2
6122           write (iout,'(2i3,50(1x,i2,f5.2))')
6123      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6124      &    j=1,num_cont_hb(i))
6125         enddo
6126       endif
6127       call flush(iout)
6128       do i=1,ntask_cont_from
6129         ncont_recv(i)=0
6130       enddo
6131       do i=1,ntask_cont_to
6132         ncont_sent(i)=0
6133       enddo
6134 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6135 c     & ntask_cont_to
6136 C Make the list of contacts to send to send to other procesors
6137 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6138 c      call flush(iout)
6139       do i=iturn3_start,iturn3_end
6140 c        write (iout,*) "make contact list turn3",i," num_cont",
6141 c     &    num_cont_hb(i)
6142         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6143       enddo
6144       do i=iturn4_start,iturn4_end
6145 c        write (iout,*) "make contact list turn4",i," num_cont",
6146 c     &   num_cont_hb(i)
6147         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6148       enddo
6149       do ii=1,nat_sent
6150         i=iat_sent(ii)
6151 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6152 c     &    num_cont_hb(i)
6153         do j=1,num_cont_hb(i)
6154         do k=1,4
6155           jjc=jcont_hb(j,i)
6156           iproc=iint_sent_local(k,jjc,ii)
6157 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6158           if (iproc.gt.0) then
6159             ncont_sent(iproc)=ncont_sent(iproc)+1
6160             nn=ncont_sent(iproc)
6161             zapas(1,nn,iproc)=i
6162             zapas(2,nn,iproc)=jjc
6163             zapas(3,nn,iproc)=facont_hb(j,i)
6164             zapas(4,nn,iproc)=ees0p(j,i)
6165             zapas(5,nn,iproc)=ees0m(j,i)
6166             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6167             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6168             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6169             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6170             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6171             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6172             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6173             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6174             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6175             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6176             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6177             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6178             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6179             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6180             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6181             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6182             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6183             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6184             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6185             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6186             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6187           endif
6188         enddo
6189         enddo
6190       enddo
6191       if (lprn) then
6192       write (iout,*)
6193      &  "Numbers of contacts to be sent to other processors",
6194      &  (ncont_sent(i),i=1,ntask_cont_to)
6195       write (iout,*) "Contacts sent"
6196       do ii=1,ntask_cont_to
6197         nn=ncont_sent(ii)
6198         iproc=itask_cont_to(ii)
6199         write (iout,*) nn," contacts to processor",iproc,
6200      &   " of CONT_TO_COMM group"
6201         do i=1,nn
6202           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6203         enddo
6204       enddo
6205       call flush(iout)
6206       endif
6207       CorrelType=477
6208       CorrelID=fg_rank+1
6209       CorrelType1=478
6210       CorrelID1=nfgtasks+fg_rank+1
6211       ireq=0
6212 C Receive the numbers of needed contacts from other processors
6213       do ii=1,ntask_cont_from
6214         iproc=itask_cont_from(ii)
6215         ireq=ireq+1
6216         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6217      &    FG_COMM,req(ireq),IERR)
6218       enddo
6219 c      write (iout,*) "IRECV ended"
6220 c      call flush(iout)
6221 C Send the number of contacts needed by other processors
6222       do ii=1,ntask_cont_to
6223         iproc=itask_cont_to(ii)
6224         ireq=ireq+1
6225         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6226      &    FG_COMM,req(ireq),IERR)
6227       enddo
6228 c      write (iout,*) "ISEND ended"
6229 c      write (iout,*) "number of requests (nn)",ireq
6230       call flush(iout)
6231       if (ireq.gt.0)
6232      &  call MPI_Waitall(ireq,req,status_array,ierr)
6233 c      write (iout,*)
6234 c     &  "Numbers of contacts to be received from other processors",
6235 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6236 c      call flush(iout)
6237 C Receive contacts
6238       ireq=0
6239       do ii=1,ntask_cont_from
6240         iproc=itask_cont_from(ii)
6241         nn=ncont_recv(ii)
6242 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6243 c     &   " of CONT_TO_COMM group"
6244         call flush(iout)
6245         if (nn.gt.0) then
6246           ireq=ireq+1
6247           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6248      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6249 c          write (iout,*) "ireq,req",ireq,req(ireq)
6250         endif
6251       enddo
6252 C Send the contacts to processors that need them
6253       do ii=1,ntask_cont_to
6254         iproc=itask_cont_to(ii)
6255         nn=ncont_sent(ii)
6256 c        write (iout,*) nn," contacts to processor",iproc,
6257 c     &   " of CONT_TO_COMM group"
6258         if (nn.gt.0) then
6259           ireq=ireq+1
6260           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6261      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6262 c          write (iout,*) "ireq,req",ireq,req(ireq)
6263 c          do i=1,nn
6264 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6265 c          enddo
6266         endif
6267       enddo
6268 c      write (iout,*) "number of requests (contacts)",ireq
6269 c      write (iout,*) "req",(req(i),i=1,4)
6270 c      call flush(iout)
6271       if (ireq.gt.0)
6272      & call MPI_Waitall(ireq,req,status_array,ierr)
6273       do iii=1,ntask_cont_from
6274         iproc=itask_cont_from(iii)
6275         nn=ncont_recv(iii)
6276         if (lprn) then
6277         write (iout,*) "Received",nn," contacts from processor",iproc,
6278      &   " of CONT_FROM_COMM group"
6279         call flush(iout)
6280         do i=1,nn
6281           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6282         enddo
6283         call flush(iout)
6284         endif
6285         do i=1,nn
6286           ii=zapas_recv(1,i,iii)
6287 c Flag the received contacts to prevent double-counting
6288           jj=-zapas_recv(2,i,iii)
6289 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6290 c          call flush(iout)
6291           nnn=num_cont_hb(ii)+1
6292           num_cont_hb(ii)=nnn
6293           jcont_hb(nnn,ii)=jj
6294           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6295           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6296           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6297           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6298           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6299           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6300           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6301           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6302           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6303           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6304           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6305           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6306           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6307           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6308           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6309           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6310           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6311           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6312           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6313           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6314           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6315           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6316           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6317           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6318         enddo
6319       enddo
6320       call flush(iout)
6321       if (lprn) then
6322         write (iout,'(a)') 'Contact function values after receive:'
6323         do i=nnt,nct-2
6324           write (iout,'(2i3,50(1x,i3,f5.2))')
6325      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6326      &    j=1,num_cont_hb(i))
6327         enddo
6328         call flush(iout)
6329       endif
6330    30 continue
6331 #endif
6332       if (lprn) then
6333         write (iout,'(a)') 'Contact function values:'
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       endif
6340       ecorr=0.0D0
6341 C Remove the loop below after debugging !!!
6342       do i=nnt,nct
6343         do j=1,3
6344           gradcorr(j,i)=0.0D0
6345           gradxorr(j,i)=0.0D0
6346         enddo
6347       enddo
6348 C Calculate the local-electrostatic correlation terms
6349       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6350         i1=i+1
6351         num_conti=num_cont_hb(i)
6352         num_conti1=num_cont_hb(i+1)
6353         do jj=1,num_conti
6354           j=jcont_hb(jj,i)
6355           jp=iabs(j)
6356           do kk=1,num_conti1
6357             j1=jcont_hb(kk,i1)
6358             jp1=iabs(j1)
6359 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6360 c     &         ' jj=',jj,' kk=',kk
6361             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6362      &          .or. j.lt.0 .and. j1.gt.0) .and.
6363      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6364 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6365 C The system gains extra energy.
6366               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6367               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6368      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6369               n_corr=n_corr+1
6370             else if (j1.eq.j) then
6371 C Contacts I-J and I-(J+1) occur simultaneously.
6372 C The system loses extra energy.
6373 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6374             endif
6375           enddo ! kk
6376           do kk=1,num_conti
6377             j1=jcont_hb(kk,i)
6378 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6379 c    &         ' jj=',jj,' kk=',kk
6380             if (j1.eq.j+1) then
6381 C Contacts I-J and (I+1)-J occur simultaneously.
6382 C The system loses extra energy.
6383 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6384             endif ! j1==j+1
6385           enddo ! kk
6386         enddo ! jj
6387       enddo ! i
6388       return
6389       end
6390 c------------------------------------------------------------------------------
6391       subroutine add_hb_contact(ii,jj,itask)
6392       implicit real*8 (a-h,o-z)
6393       include "DIMENSIONS"
6394       include "COMMON.IOUNITS"
6395       integer max_cont
6396       integer max_dim
6397       parameter (max_cont=maxconts)
6398       parameter (max_dim=26)
6399       include "COMMON.CONTACTS"
6400       double precision zapas(max_dim,maxconts,max_fg_procs),
6401      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6402       common /przechowalnia/ zapas
6403       integer i,j,ii,jj,iproc,itask(4),nn
6404 c      write (iout,*) "itask",itask
6405       do i=1,2
6406         iproc=itask(i)
6407         if (iproc.gt.0) then
6408           do j=1,num_cont_hb(ii)
6409             jjc=jcont_hb(j,ii)
6410 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6411             if (jjc.eq.jj) then
6412               ncont_sent(iproc)=ncont_sent(iproc)+1
6413               nn=ncont_sent(iproc)
6414               zapas(1,nn,iproc)=ii
6415               zapas(2,nn,iproc)=jjc
6416               zapas(3,nn,iproc)=facont_hb(j,ii)
6417               zapas(4,nn,iproc)=ees0p(j,ii)
6418               zapas(5,nn,iproc)=ees0m(j,ii)
6419               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6420               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6421               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6422               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6423               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6424               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6425               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6426               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6427               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6428               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6429               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6430               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6431               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6432               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6433               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6434               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6435               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6436               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6437               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6438               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6439               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6440               exit
6441             endif
6442           enddo
6443         endif
6444       enddo
6445       return
6446       end
6447 c------------------------------------------------------------------------------
6448       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6449      &  n_corr1)
6450 C This subroutine calculates multi-body contributions to hydrogen-bonding
6451       implicit real*8 (a-h,o-z)
6452       include 'DIMENSIONS'
6453       include 'COMMON.IOUNITS'
6454 #ifdef MPI
6455       include "mpif.h"
6456       parameter (max_cont=maxconts)
6457       parameter (max_dim=70)
6458       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6459       double precision zapas(max_dim,maxconts,max_fg_procs),
6460      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6461       common /przechowalnia/ zapas
6462       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6463      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6464 #endif
6465       include 'COMMON.SETUP'
6466       include 'COMMON.FFIELD'
6467       include 'COMMON.DERIV'
6468       include 'COMMON.LOCAL'
6469       include 'COMMON.INTERACT'
6470       include 'COMMON.CONTACTS'
6471       include 'COMMON.CHAIN'
6472       include 'COMMON.CONTROL'
6473       double precision gx(3),gx1(3)
6474       integer num_cont_hb_old(maxres)
6475       logical lprn,ldone
6476       double precision eello4,eello5,eelo6,eello_turn6
6477       external eello4,eello5,eello6,eello_turn6
6478 C Set lprn=.true. for debugging
6479       lprn=.false.
6480       eturn6=0.0d0
6481 #ifdef MPI
6482       do i=1,nres
6483         num_cont_hb_old(i)=num_cont_hb(i)
6484       enddo
6485       n_corr=0
6486       n_corr1=0
6487       if (nfgtasks.le.1) goto 30
6488       if (lprn) then
6489         write (iout,'(a)') 'Contact function values before RECEIVE:'
6490         do i=nnt,nct-2
6491           write (iout,'(2i3,50(1x,i2,f5.2))')
6492      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6493      &    j=1,num_cont_hb(i))
6494         enddo
6495       endif
6496       call flush(iout)
6497       do i=1,ntask_cont_from
6498         ncont_recv(i)=0
6499       enddo
6500       do i=1,ntask_cont_to
6501         ncont_sent(i)=0
6502       enddo
6503 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6504 c     & ntask_cont_to
6505 C Make the list of contacts to send to send to other procesors
6506       do i=iturn3_start,iturn3_end
6507 c        write (iout,*) "make contact list turn3",i," num_cont",
6508 c     &    num_cont_hb(i)
6509         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6510       enddo
6511       do i=iturn4_start,iturn4_end
6512 c        write (iout,*) "make contact list turn4",i," num_cont",
6513 c     &   num_cont_hb(i)
6514         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6515       enddo
6516       do ii=1,nat_sent
6517         i=iat_sent(ii)
6518 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6519 c     &    num_cont_hb(i)
6520         do j=1,num_cont_hb(i)
6521         do k=1,4
6522           jjc=jcont_hb(j,i)
6523           iproc=iint_sent_local(k,jjc,ii)
6524 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6525           if (iproc.ne.0) then
6526             ncont_sent(iproc)=ncont_sent(iproc)+1
6527             nn=ncont_sent(iproc)
6528             zapas(1,nn,iproc)=i
6529             zapas(2,nn,iproc)=jjc
6530             zapas(3,nn,iproc)=d_cont(j,i)
6531             ind=3
6532             do kk=1,3
6533               ind=ind+1
6534               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6535             enddo
6536             do kk=1,2
6537               do ll=1,2
6538                 ind=ind+1
6539                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6540               enddo
6541             enddo
6542             do jj=1,5
6543               do kk=1,3
6544                 do ll=1,2
6545                   do mm=1,2
6546                     ind=ind+1
6547                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6548                   enddo
6549                 enddo
6550               enddo
6551             enddo
6552           endif
6553         enddo
6554         enddo
6555       enddo
6556       if (lprn) then
6557       write (iout,*)
6558      &  "Numbers of contacts to be sent to other processors",
6559      &  (ncont_sent(i),i=1,ntask_cont_to)
6560       write (iout,*) "Contacts sent"
6561       do ii=1,ntask_cont_to
6562         nn=ncont_sent(ii)
6563         iproc=itask_cont_to(ii)
6564         write (iout,*) nn," contacts to processor",iproc,
6565      &   " of CONT_TO_COMM group"
6566         do i=1,nn
6567           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6568         enddo
6569       enddo
6570       call flush(iout)
6571       endif
6572       CorrelType=477
6573       CorrelID=fg_rank+1
6574       CorrelType1=478
6575       CorrelID1=nfgtasks+fg_rank+1
6576       ireq=0
6577 C Receive the numbers of needed contacts from other processors
6578       do ii=1,ntask_cont_from
6579         iproc=itask_cont_from(ii)
6580         ireq=ireq+1
6581         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6582      &    FG_COMM,req(ireq),IERR)
6583       enddo
6584 c      write (iout,*) "IRECV ended"
6585 c      call flush(iout)
6586 C Send the number of contacts needed by other processors
6587       do ii=1,ntask_cont_to
6588         iproc=itask_cont_to(ii)
6589         ireq=ireq+1
6590         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6591      &    FG_COMM,req(ireq),IERR)
6592       enddo
6593 c      write (iout,*) "ISEND ended"
6594 c      write (iout,*) "number of requests (nn)",ireq
6595       call flush(iout)
6596       if (ireq.gt.0)
6597      &  call MPI_Waitall(ireq,req,status_array,ierr)
6598 c      write (iout,*)
6599 c     &  "Numbers of contacts to be received from other processors",
6600 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6601 c      call flush(iout)
6602 C Receive contacts
6603       ireq=0
6604       do ii=1,ntask_cont_from
6605         iproc=itask_cont_from(ii)
6606         nn=ncont_recv(ii)
6607 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6608 c     &   " of CONT_TO_COMM group"
6609         call flush(iout)
6610         if (nn.gt.0) then
6611           ireq=ireq+1
6612           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6613      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6614 c          write (iout,*) "ireq,req",ireq,req(ireq)
6615         endif
6616       enddo
6617 C Send the contacts to processors that need them
6618       do ii=1,ntask_cont_to
6619         iproc=itask_cont_to(ii)
6620         nn=ncont_sent(ii)
6621 c        write (iout,*) nn," contacts to processor",iproc,
6622 c     &   " of CONT_TO_COMM group"
6623         if (nn.gt.0) then
6624           ireq=ireq+1
6625           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6626      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6627 c          write (iout,*) "ireq,req",ireq,req(ireq)
6628 c          do i=1,nn
6629 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6630 c          enddo
6631         endif
6632       enddo
6633 c      write (iout,*) "number of requests (contacts)",ireq
6634 c      write (iout,*) "req",(req(i),i=1,4)
6635 c      call flush(iout)
6636       if (ireq.gt.0)
6637      & call MPI_Waitall(ireq,req,status_array,ierr)
6638       do iii=1,ntask_cont_from
6639         iproc=itask_cont_from(iii)
6640         nn=ncont_recv(iii)
6641         if (lprn) then
6642         write (iout,*) "Received",nn," contacts from processor",iproc,
6643      &   " of CONT_FROM_COMM group"
6644         call flush(iout)
6645         do i=1,nn
6646           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6647         enddo
6648         call flush(iout)
6649         endif
6650         do i=1,nn
6651           ii=zapas_recv(1,i,iii)
6652 c Flag the received contacts to prevent double-counting
6653           jj=-zapas_recv(2,i,iii)
6654 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6655 c          call flush(iout)
6656           nnn=num_cont_hb(ii)+1
6657           num_cont_hb(ii)=nnn
6658           jcont_hb(nnn,ii)=jj
6659           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6660           ind=3
6661           do kk=1,3
6662             ind=ind+1
6663             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6664           enddo
6665           do kk=1,2
6666             do ll=1,2
6667               ind=ind+1
6668               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6669             enddo
6670           enddo
6671           do jj=1,5
6672             do kk=1,3
6673               do ll=1,2
6674                 do mm=1,2
6675                   ind=ind+1
6676                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6677                 enddo
6678               enddo
6679             enddo
6680           enddo
6681         enddo
6682       enddo
6683       call flush(iout)
6684       if (lprn) then
6685         write (iout,'(a)') 'Contact function values after receive:'
6686         do i=nnt,nct-2
6687           write (iout,'(2i3,50(1x,i3,5f6.3))')
6688      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6689      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6690         enddo
6691         call flush(iout)
6692       endif
6693    30 continue
6694 #endif
6695       if (lprn) then
6696         write (iout,'(a)') 'Contact function values:'
6697         do i=nnt,nct-2
6698           write (iout,'(2i3,50(1x,i2,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       endif
6703       ecorr=0.0D0
6704       ecorr5=0.0d0
6705       ecorr6=0.0d0
6706 C Remove the loop below after debugging !!!
6707       do i=nnt,nct
6708         do j=1,3
6709           gradcorr(j,i)=0.0D0
6710           gradxorr(j,i)=0.0D0
6711         enddo
6712       enddo
6713 C Calculate the dipole-dipole interaction energies
6714       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6715       do i=iatel_s,iatel_e+1
6716         num_conti=num_cont_hb(i)
6717         do jj=1,num_conti
6718           j=jcont_hb(jj,i)
6719 #ifdef MOMENT
6720           call dipole(i,j,jj)
6721 #endif
6722         enddo
6723       enddo
6724       endif
6725 C Calculate the local-electrostatic correlation terms
6726 c                write (iout,*) "gradcorr5 in eello5 before loop"
6727 c                do iii=1,nres
6728 c                  write (iout,'(i5,3f10.5)')
6729 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6730 c                enddo
6731       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6732 c        write (iout,*) "corr loop i",i
6733         i1=i+1
6734         num_conti=num_cont_hb(i)
6735         num_conti1=num_cont_hb(i+1)
6736         do jj=1,num_conti
6737           j=jcont_hb(jj,i)
6738           jp=iabs(j)
6739           do kk=1,num_conti1
6740             j1=jcont_hb(kk,i1)
6741             jp1=iabs(j1)
6742 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6743 c     &         ' jj=',jj,' kk=',kk
6744 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6745             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6746      &          .or. j.lt.0 .and. j1.gt.0) .and.
6747      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6748 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6749 C The system gains extra energy.
6750               n_corr=n_corr+1
6751               sqd1=dsqrt(d_cont(jj,i))
6752               sqd2=dsqrt(d_cont(kk,i1))
6753               sred_geom = sqd1*sqd2
6754               IF (sred_geom.lt.cutoff_corr) THEN
6755                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6756      &            ekont,fprimcont)
6757 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6758 cd     &         ' jj=',jj,' kk=',kk
6759                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6760                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6761                 do l=1,3
6762                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6763                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6764                 enddo
6765                 n_corr1=n_corr1+1
6766 cd               write (iout,*) 'sred_geom=',sred_geom,
6767 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6768 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6769 cd               write (iout,*) "g_contij",g_contij
6770 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6771 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6772                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6773                 if (wcorr4.gt.0.0d0)
6774      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6775                   if (energy_dec.and.wcorr4.gt.0.0d0)
6776      1                 write (iout,'(a6,4i5,0pf7.3)')
6777      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6778 c                write (iout,*) "gradcorr5 before eello5"
6779 c                do iii=1,nres
6780 c                  write (iout,'(i5,3f10.5)')
6781 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6782 c                enddo
6783                 if (wcorr5.gt.0.0d0)
6784      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6785 c                write (iout,*) "gradcorr5 after eello5"
6786 c                do iii=1,nres
6787 c                  write (iout,'(i5,3f10.5)')
6788 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6789 c                enddo
6790                   if (energy_dec.and.wcorr5.gt.0.0d0)
6791      1                 write (iout,'(a6,4i5,0pf7.3)')
6792      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6793 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6794 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6795                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6796      &               .or. wturn6.eq.0.0d0))then
6797 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6798                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6799                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6800      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6801 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6802 cd     &            'ecorr6=',ecorr6
6803 cd                write (iout,'(4e15.5)') sred_geom,
6804 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6805 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6806 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6807                 else if (wturn6.gt.0.0d0
6808      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6809 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6810                   eturn6=eturn6+eello_turn6(i,jj,kk)
6811                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6812      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6813 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6814                 endif
6815               ENDIF
6816 1111          continue
6817             endif
6818           enddo ! kk
6819         enddo ! jj
6820       enddo ! i
6821       do i=1,nres
6822         num_cont_hb(i)=num_cont_hb_old(i)
6823       enddo
6824 c                write (iout,*) "gradcorr5 in eello5"
6825 c                do iii=1,nres
6826 c                  write (iout,'(i5,3f10.5)')
6827 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6828 c                enddo
6829       return
6830       end
6831 c------------------------------------------------------------------------------
6832       subroutine add_hb_contact_eello(ii,jj,itask)
6833       implicit real*8 (a-h,o-z)
6834       include "DIMENSIONS"
6835       include "COMMON.IOUNITS"
6836       integer max_cont
6837       integer max_dim
6838       parameter (max_cont=maxconts)
6839       parameter (max_dim=70)
6840       include "COMMON.CONTACTS"
6841       double precision zapas(max_dim,maxconts,max_fg_procs),
6842      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6843       common /przechowalnia/ zapas
6844       integer i,j,ii,jj,iproc,itask(4),nn
6845 c      write (iout,*) "itask",itask
6846       do i=1,2
6847         iproc=itask(i)
6848         if (iproc.gt.0) then
6849           do j=1,num_cont_hb(ii)
6850             jjc=jcont_hb(j,ii)
6851 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6852             if (jjc.eq.jj) then
6853               ncont_sent(iproc)=ncont_sent(iproc)+1
6854               nn=ncont_sent(iproc)
6855               zapas(1,nn,iproc)=ii
6856               zapas(2,nn,iproc)=jjc
6857               zapas(3,nn,iproc)=d_cont(j,ii)
6858               ind=3
6859               do kk=1,3
6860                 ind=ind+1
6861                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6862               enddo
6863               do kk=1,2
6864                 do ll=1,2
6865                   ind=ind+1
6866                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6867                 enddo
6868               enddo
6869               do jj=1,5
6870                 do kk=1,3
6871                   do ll=1,2
6872                     do mm=1,2
6873                       ind=ind+1
6874                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6875                     enddo
6876                   enddo
6877                 enddo
6878               enddo
6879               exit
6880             endif
6881           enddo
6882         endif
6883       enddo
6884       return
6885       end
6886 c------------------------------------------------------------------------------
6887       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6888       implicit real*8 (a-h,o-z)
6889       include 'DIMENSIONS'
6890       include 'COMMON.IOUNITS'
6891       include 'COMMON.DERIV'
6892       include 'COMMON.INTERACT'
6893       include 'COMMON.CONTACTS'
6894       double precision gx(3),gx1(3)
6895       logical lprn
6896       lprn=.false.
6897       eij=facont_hb(jj,i)
6898       ekl=facont_hb(kk,k)
6899       ees0pij=ees0p(jj,i)
6900       ees0pkl=ees0p(kk,k)
6901       ees0mij=ees0m(jj,i)
6902       ees0mkl=ees0m(kk,k)
6903       ekont=eij*ekl
6904       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6905 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6906 C Following 4 lines for diagnostics.
6907 cd    ees0pkl=0.0D0
6908 cd    ees0pij=1.0D0
6909 cd    ees0mkl=0.0D0
6910 cd    ees0mij=1.0D0
6911 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6912 c     & 'Contacts ',i,j,
6913 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6914 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6915 c     & 'gradcorr_long'
6916 C Calculate the multi-body contribution to energy.
6917 c      ecorr=ecorr+ekont*ees
6918 C Calculate multi-body contributions to the gradient.
6919       coeffpees0pij=coeffp*ees0pij
6920       coeffmees0mij=coeffm*ees0mij
6921       coeffpees0pkl=coeffp*ees0pkl
6922       coeffmees0mkl=coeffm*ees0mkl
6923       do ll=1,3
6924 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6925         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6926      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6927      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6928         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6929      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6930      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6931 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6932         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6933      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6934      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6935         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6936      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6937      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6938         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6939      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6940      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6941         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6942         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6943         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6944      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6945      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6946         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6947         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6948 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6949       enddo
6950 c      write (iout,*)
6951 cgrad      do m=i+1,j-1
6952 cgrad        do ll=1,3
6953 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6954 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6955 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6956 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6957 cgrad        enddo
6958 cgrad      enddo
6959 cgrad      do m=k+1,l-1
6960 cgrad        do ll=1,3
6961 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6962 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6963 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6964 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6965 cgrad        enddo
6966 cgrad      enddo
6967 c      write (iout,*) "ehbcorr",ekont*ees
6968       ehbcorr=ekont*ees
6969       return
6970       end
6971 #ifdef MOMENT
6972 C---------------------------------------------------------------------------
6973       subroutine dipole(i,j,jj)
6974       implicit real*8 (a-h,o-z)
6975       include 'DIMENSIONS'
6976       include 'COMMON.IOUNITS'
6977       include 'COMMON.CHAIN'
6978       include 'COMMON.FFIELD'
6979       include 'COMMON.DERIV'
6980       include 'COMMON.INTERACT'
6981       include 'COMMON.CONTACTS'
6982       include 'COMMON.TORSION'
6983       include 'COMMON.VAR'
6984       include 'COMMON.GEO'
6985       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6986      &  auxmat(2,2)
6987       iti1 = itortyp(itype(i+1))
6988       if (j.lt.nres-1) then
6989         itj1 = itortyp(itype(j+1))
6990       else
6991         itj1=ntortyp+1
6992       endif
6993       do iii=1,2
6994         dipi(iii,1)=Ub2(iii,i)
6995         dipderi(iii)=Ub2der(iii,i)
6996         dipi(iii,2)=b1(iii,iti1)
6997         dipj(iii,1)=Ub2(iii,j)
6998         dipderj(iii)=Ub2der(iii,j)
6999         dipj(iii,2)=b1(iii,itj1)
7000       enddo
7001       kkk=0
7002       do iii=1,2
7003         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7004         do jjj=1,2
7005           kkk=kkk+1
7006           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7007         enddo
7008       enddo
7009       do kkk=1,5
7010         do lll=1,3
7011           mmm=0
7012           do iii=1,2
7013             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7014      &        auxvec(1))
7015             do jjj=1,2
7016               mmm=mmm+1
7017               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7018             enddo
7019           enddo
7020         enddo
7021       enddo
7022       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7023       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7024       do iii=1,2
7025         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7026       enddo
7027       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7028       do iii=1,2
7029         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7030       enddo
7031       return
7032       end
7033 #endif
7034 C---------------------------------------------------------------------------
7035       subroutine calc_eello(i,j,k,l,jj,kk)
7036 C
7037 C This subroutine computes matrices and vectors needed to calculate
7038 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7039 C
7040       implicit real*8 (a-h,o-z)
7041       include 'DIMENSIONS'
7042       include 'COMMON.IOUNITS'
7043       include 'COMMON.CHAIN'
7044       include 'COMMON.DERIV'
7045       include 'COMMON.INTERACT'
7046       include 'COMMON.CONTACTS'
7047       include 'COMMON.TORSION'
7048       include 'COMMON.VAR'
7049       include 'COMMON.GEO'
7050       include 'COMMON.FFIELD'
7051       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7052      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7053       logical lprn
7054       common /kutas/ lprn
7055 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7056 cd     & ' jj=',jj,' kk=',kk
7057 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7058 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7059 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7060       do iii=1,2
7061         do jjj=1,2
7062           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7063           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7064         enddo
7065       enddo
7066       call transpose2(aa1(1,1),aa1t(1,1))
7067       call transpose2(aa2(1,1),aa2t(1,1))
7068       do kkk=1,5
7069         do lll=1,3
7070           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7071      &      aa1tder(1,1,lll,kkk))
7072           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7073      &      aa2tder(1,1,lll,kkk))
7074         enddo
7075       enddo
7076       if (l.eq.j+1) then
7077 C parallel orientation of the two CA-CA-CA frames.
7078         if (i.gt.1) then
7079           iti=itortyp(itype(i))
7080         else
7081           iti=ntortyp+1
7082         endif
7083         itk1=itortyp(itype(k+1))
7084         itj=itortyp(itype(j))
7085         if (l.lt.nres-1) then
7086           itl1=itortyp(itype(l+1))
7087         else
7088           itl1=ntortyp+1
7089         endif
7090 C A1 kernel(j+1) A2T
7091 cd        do iii=1,2
7092 cd          write (iout,'(3f10.5,5x,3f10.5)')
7093 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7094 cd        enddo
7095         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7096      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7097      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7098 C Following matrices are needed only for 6-th order cumulants
7099         IF (wcorr6.gt.0.0d0) THEN
7100         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7101      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7102      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7103         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7104      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7105      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7106      &   ADtEAderx(1,1,1,1,1,1))
7107         lprn=.false.
7108         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7109      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7110      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7111      &   ADtEA1derx(1,1,1,1,1,1))
7112         ENDIF
7113 C End 6-th order cumulants
7114 cd        lprn=.false.
7115 cd        if (lprn) then
7116 cd        write (2,*) 'In calc_eello6'
7117 cd        do iii=1,2
7118 cd          write (2,*) 'iii=',iii
7119 cd          do kkk=1,5
7120 cd            write (2,*) 'kkk=',kkk
7121 cd            do jjj=1,2
7122 cd              write (2,'(3(2f10.5),5x)')
7123 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7124 cd            enddo
7125 cd          enddo
7126 cd        enddo
7127 cd        endif
7128         call transpose2(EUgder(1,1,k),auxmat(1,1))
7129         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7130         call transpose2(EUg(1,1,k),auxmat(1,1))
7131         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7132         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7133         do iii=1,2
7134           do kkk=1,5
7135             do lll=1,3
7136               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7137      &          EAEAderx(1,1,lll,kkk,iii,1))
7138             enddo
7139           enddo
7140         enddo
7141 C A1T kernel(i+1) A2
7142         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7143      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7144      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7145 C Following matrices are needed only for 6-th order cumulants
7146         IF (wcorr6.gt.0.0d0) THEN
7147         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7148      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7149      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7150         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7151      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7152      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7153      &   ADtEAderx(1,1,1,1,1,2))
7154         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7155      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7156      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7157      &   ADtEA1derx(1,1,1,1,1,2))
7158         ENDIF
7159 C End 6-th order cumulants
7160         call transpose2(EUgder(1,1,l),auxmat(1,1))
7161         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7162         call transpose2(EUg(1,1,l),auxmat(1,1))
7163         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7164         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7165         do iii=1,2
7166           do kkk=1,5
7167             do lll=1,3
7168               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7169      &          EAEAderx(1,1,lll,kkk,iii,2))
7170             enddo
7171           enddo
7172         enddo
7173 C AEAb1 and AEAb2
7174 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7175 C They are needed only when the fifth- or the sixth-order cumulants are
7176 C indluded.
7177         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7178         call transpose2(AEA(1,1,1),auxmat(1,1))
7179         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7180         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7181         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7182         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7183         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7184         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7185         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7186         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7187         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7188         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7189         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7190         call transpose2(AEA(1,1,2),auxmat(1,1))
7191         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7192         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7193         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7194         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7195         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7196         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7197         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7198         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7199         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7200         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7201         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7202 C Calculate the Cartesian derivatives of the vectors.
7203         do iii=1,2
7204           do kkk=1,5
7205             do lll=1,3
7206               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7207               call matvec2(auxmat(1,1),b1(1,iti),
7208      &          AEAb1derx(1,lll,kkk,iii,1,1))
7209               call matvec2(auxmat(1,1),Ub2(1,i),
7210      &          AEAb2derx(1,lll,kkk,iii,1,1))
7211               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7212      &          AEAb1derx(1,lll,kkk,iii,2,1))
7213               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7214      &          AEAb2derx(1,lll,kkk,iii,2,1))
7215               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7216               call matvec2(auxmat(1,1),b1(1,itj),
7217      &          AEAb1derx(1,lll,kkk,iii,1,2))
7218               call matvec2(auxmat(1,1),Ub2(1,j),
7219      &          AEAb2derx(1,lll,kkk,iii,1,2))
7220               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7221      &          AEAb1derx(1,lll,kkk,iii,2,2))
7222               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7223      &          AEAb2derx(1,lll,kkk,iii,2,2))
7224             enddo
7225           enddo
7226         enddo
7227         ENDIF
7228 C End vectors
7229       else
7230 C Antiparallel orientation of the two CA-CA-CA frames.
7231         if (i.gt.1) then
7232           iti=itortyp(itype(i))
7233         else
7234           iti=ntortyp+1
7235         endif
7236         itk1=itortyp(itype(k+1))
7237         itl=itortyp(itype(l))
7238         itj=itortyp(itype(j))
7239         if (j.lt.nres-1) then
7240           itj1=itortyp(itype(j+1))
7241         else
7242           itj1=ntortyp+1
7243         endif
7244 C A2 kernel(j-1)T A1T
7245         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7246      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7247      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7248 C Following matrices are needed only for 6-th order cumulants
7249         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7250      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7251         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7252      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7253      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7254         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7255      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7256      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7257      &   ADtEAderx(1,1,1,1,1,1))
7258         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7259      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7260      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7261      &   ADtEA1derx(1,1,1,1,1,1))
7262         ENDIF
7263 C End 6-th order cumulants
7264         call transpose2(EUgder(1,1,k),auxmat(1,1))
7265         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7266         call transpose2(EUg(1,1,k),auxmat(1,1))
7267         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7268         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7269         do iii=1,2
7270           do kkk=1,5
7271             do lll=1,3
7272               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7273      &          EAEAderx(1,1,lll,kkk,iii,1))
7274             enddo
7275           enddo
7276         enddo
7277 C A2T kernel(i+1)T A1
7278         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7279      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7280      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7281 C Following matrices are needed only for 6-th order cumulants
7282         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7283      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7284         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7285      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7286      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7287         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7288      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7289      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7290      &   ADtEAderx(1,1,1,1,1,2))
7291         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7292      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7293      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7294      &   ADtEA1derx(1,1,1,1,1,2))
7295         ENDIF
7296 C End 6-th order cumulants
7297         call transpose2(EUgder(1,1,j),auxmat(1,1))
7298         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7299         call transpose2(EUg(1,1,j),auxmat(1,1))
7300         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7301         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7302         do iii=1,2
7303           do kkk=1,5
7304             do lll=1,3
7305               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7306      &          EAEAderx(1,1,lll,kkk,iii,2))
7307             enddo
7308           enddo
7309         enddo
7310 C AEAb1 and AEAb2
7311 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7312 C They are needed only when the fifth- or the sixth-order cumulants are
7313 C indluded.
7314         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7315      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7316         call transpose2(AEA(1,1,1),auxmat(1,1))
7317         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7318         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7319         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7320         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7321         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7322         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7323         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7324         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7325         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7326         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7327         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7328         call transpose2(AEA(1,1,2),auxmat(1,1))
7329         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7330         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7331         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7332         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7333         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7334         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7335         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7336         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7337         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7338         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7339         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7340 C Calculate the Cartesian derivatives of the vectors.
7341         do iii=1,2
7342           do kkk=1,5
7343             do lll=1,3
7344               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7345               call matvec2(auxmat(1,1),b1(1,iti),
7346      &          AEAb1derx(1,lll,kkk,iii,1,1))
7347               call matvec2(auxmat(1,1),Ub2(1,i),
7348      &          AEAb2derx(1,lll,kkk,iii,1,1))
7349               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7350      &          AEAb1derx(1,lll,kkk,iii,2,1))
7351               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7352      &          AEAb2derx(1,lll,kkk,iii,2,1))
7353               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7354               call matvec2(auxmat(1,1),b1(1,itl),
7355      &          AEAb1derx(1,lll,kkk,iii,1,2))
7356               call matvec2(auxmat(1,1),Ub2(1,l),
7357      &          AEAb2derx(1,lll,kkk,iii,1,2))
7358               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7359      &          AEAb1derx(1,lll,kkk,iii,2,2))
7360               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7361      &          AEAb2derx(1,lll,kkk,iii,2,2))
7362             enddo
7363           enddo
7364         enddo
7365         ENDIF
7366 C End vectors
7367       endif
7368       return
7369       end
7370 C---------------------------------------------------------------------------
7371       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7372      &  KK,KKderg,AKA,AKAderg,AKAderx)
7373       implicit none
7374       integer nderg
7375       logical transp
7376       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7377      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7378      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7379       integer iii,kkk,lll
7380       integer jjj,mmm
7381       logical lprn
7382       common /kutas/ lprn
7383       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7384       do iii=1,nderg
7385         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7386      &    AKAderg(1,1,iii))
7387       enddo
7388 cd      if (lprn) write (2,*) 'In kernel'
7389       do kkk=1,5
7390 cd        if (lprn) write (2,*) 'kkk=',kkk
7391         do lll=1,3
7392           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7393      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7394 cd          if (lprn) then
7395 cd            write (2,*) 'lll=',lll
7396 cd            write (2,*) 'iii=1'
7397 cd            do jjj=1,2
7398 cd              write (2,'(3(2f10.5),5x)')
7399 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7400 cd            enddo
7401 cd          endif
7402           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7403      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7404 cd          if (lprn) then
7405 cd            write (2,*) 'lll=',lll
7406 cd            write (2,*) 'iii=2'
7407 cd            do jjj=1,2
7408 cd              write (2,'(3(2f10.5),5x)')
7409 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7410 cd            enddo
7411 cd          endif
7412         enddo
7413       enddo
7414       return
7415       end
7416 C---------------------------------------------------------------------------
7417       double precision function eello4(i,j,k,l,jj,kk)
7418       implicit real*8 (a-h,o-z)
7419       include 'DIMENSIONS'
7420       include 'COMMON.IOUNITS'
7421       include 'COMMON.CHAIN'
7422       include 'COMMON.DERIV'
7423       include 'COMMON.INTERACT'
7424       include 'COMMON.CONTACTS'
7425       include 'COMMON.TORSION'
7426       include 'COMMON.VAR'
7427       include 'COMMON.GEO'
7428       double precision pizda(2,2),ggg1(3),ggg2(3)
7429 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7430 cd        eello4=0.0d0
7431 cd        return
7432 cd      endif
7433 cd      print *,'eello4:',i,j,k,l,jj,kk
7434 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7435 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7436 cold      eij=facont_hb(jj,i)
7437 cold      ekl=facont_hb(kk,k)
7438 cold      ekont=eij*ekl
7439       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7440 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7441       gcorr_loc(k-1)=gcorr_loc(k-1)
7442      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7443       if (l.eq.j+1) then
7444         gcorr_loc(l-1)=gcorr_loc(l-1)
7445      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7446       else
7447         gcorr_loc(j-1)=gcorr_loc(j-1)
7448      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7449       endif
7450       do iii=1,2
7451         do kkk=1,5
7452           do lll=1,3
7453             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7454      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7455 cd            derx(lll,kkk,iii)=0.0d0
7456           enddo
7457         enddo
7458       enddo
7459 cd      gcorr_loc(l-1)=0.0d0
7460 cd      gcorr_loc(j-1)=0.0d0
7461 cd      gcorr_loc(k-1)=0.0d0
7462 cd      eel4=1.0d0
7463 cd      write (iout,*)'Contacts have occurred for peptide groups',
7464 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7465 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7466       if (j.lt.nres-1) then
7467         j1=j+1
7468         j2=j-1
7469       else
7470         j1=j-1
7471         j2=j-2
7472       endif
7473       if (l.lt.nres-1) then
7474         l1=l+1
7475         l2=l-1
7476       else
7477         l1=l-1
7478         l2=l-2
7479       endif
7480       do ll=1,3
7481 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7482 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7483         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7484         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7485 cgrad        ghalf=0.5d0*ggg1(ll)
7486         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7487         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7488         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7489         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7490         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7491         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7492 cgrad        ghalf=0.5d0*ggg2(ll)
7493         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7494         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7495         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7496         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7497         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7498         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7499       enddo
7500 cgrad      do m=i+1,j-1
7501 cgrad        do ll=1,3
7502 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7503 cgrad        enddo
7504 cgrad      enddo
7505 cgrad      do m=k+1,l-1
7506 cgrad        do ll=1,3
7507 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7508 cgrad        enddo
7509 cgrad      enddo
7510 cgrad      do m=i+2,j2
7511 cgrad        do ll=1,3
7512 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7513 cgrad        enddo
7514 cgrad      enddo
7515 cgrad      do m=k+2,l2
7516 cgrad        do ll=1,3
7517 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7518 cgrad        enddo
7519 cgrad      enddo
7520 cd      do iii=1,nres-3
7521 cd        write (2,*) iii,gcorr_loc(iii)
7522 cd      enddo
7523       eello4=ekont*eel4
7524 cd      write (2,*) 'ekont',ekont
7525 cd      write (iout,*) 'eello4',ekont*eel4
7526       return
7527       end
7528 C---------------------------------------------------------------------------
7529       double precision function eello5(i,j,k,l,jj,kk)
7530       implicit real*8 (a-h,o-z)
7531       include 'DIMENSIONS'
7532       include 'COMMON.IOUNITS'
7533       include 'COMMON.CHAIN'
7534       include 'COMMON.DERIV'
7535       include 'COMMON.INTERACT'
7536       include 'COMMON.CONTACTS'
7537       include 'COMMON.TORSION'
7538       include 'COMMON.VAR'
7539       include 'COMMON.GEO'
7540       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7541       double precision ggg1(3),ggg2(3)
7542 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7543 C                                                                              C
7544 C                            Parallel chains                                   C
7545 C                                                                              C
7546 C          o             o                   o             o                   C
7547 C         /l\           / \             \   / \           / \   /              C
7548 C        /   \         /   \             \ /   \         /   \ /               C
7549 C       j| o |l1       | o |              o| o |         | o |o                C
7550 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7551 C      \i/   \         /   \ /             /   \         /   \                 C
7552 C       o    k1             o                                                  C
7553 C         (I)          (II)                (III)          (IV)                 C
7554 C                                                                              C
7555 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7556 C                                                                              C
7557 C                            Antiparallel chains                               C
7558 C                                                                              C
7559 C          o             o                   o             o                   C
7560 C         /j\           / \             \   / \           / \   /              C
7561 C        /   \         /   \             \ /   \         /   \ /               C
7562 C      j1| o |l        | o |              o| o |         | o |o                C
7563 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7564 C      \i/   \         /   \ /             /   \         /   \                 C
7565 C       o     k1            o                                                  C
7566 C         (I)          (II)                (III)          (IV)                 C
7567 C                                                                              C
7568 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7569 C                                                                              C
7570 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7571 C                                                                              C
7572 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7573 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7574 cd        eello5=0.0d0
7575 cd        return
7576 cd      endif
7577 cd      write (iout,*)
7578 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7579 cd     &   ' and',k,l
7580       itk=itortyp(itype(k))
7581       itl=itortyp(itype(l))
7582       itj=itortyp(itype(j))
7583       eello5_1=0.0d0
7584       eello5_2=0.0d0
7585       eello5_3=0.0d0
7586       eello5_4=0.0d0
7587 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7588 cd     &   eel5_3_num,eel5_4_num)
7589       do iii=1,2
7590         do kkk=1,5
7591           do lll=1,3
7592             derx(lll,kkk,iii)=0.0d0
7593           enddo
7594         enddo
7595       enddo
7596 cd      eij=facont_hb(jj,i)
7597 cd      ekl=facont_hb(kk,k)
7598 cd      ekont=eij*ekl
7599 cd      write (iout,*)'Contacts have occurred for peptide groups',
7600 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7601 cd      goto 1111
7602 C Contribution from the graph I.
7603 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7604 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7605       call transpose2(EUg(1,1,k),auxmat(1,1))
7606       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7607       vv(1)=pizda(1,1)-pizda(2,2)
7608       vv(2)=pizda(1,2)+pizda(2,1)
7609       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7610      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7611 C Explicit gradient in virtual-dihedral angles.
7612       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7613      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7614      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7615       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7616       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7617       vv(1)=pizda(1,1)-pizda(2,2)
7618       vv(2)=pizda(1,2)+pizda(2,1)
7619       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7620      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7621      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7622       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7623       vv(1)=pizda(1,1)-pizda(2,2)
7624       vv(2)=pizda(1,2)+pizda(2,1)
7625       if (l.eq.j+1) then
7626         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7627      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7628      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7629       else
7630         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7631      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7632      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7633       endif
7634 C Cartesian gradient
7635       do iii=1,2
7636         do kkk=1,5
7637           do lll=1,3
7638             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7639      &        pizda(1,1))
7640             vv(1)=pizda(1,1)-pizda(2,2)
7641             vv(2)=pizda(1,2)+pizda(2,1)
7642             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7643      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7644      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7645           enddo
7646         enddo
7647       enddo
7648 c      goto 1112
7649 c1111  continue
7650 C Contribution from graph II
7651       call transpose2(EE(1,1,itk),auxmat(1,1))
7652       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7653       vv(1)=pizda(1,1)+pizda(2,2)
7654       vv(2)=pizda(2,1)-pizda(1,2)
7655       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7656      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7657 C Explicit gradient in virtual-dihedral angles.
7658       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7659      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7660       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7661       vv(1)=pizda(1,1)+pizda(2,2)
7662       vv(2)=pizda(2,1)-pizda(1,2)
7663       if (l.eq.j+1) then
7664         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7665      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7666      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7667       else
7668         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7669      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7670      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7671       endif
7672 C Cartesian gradient
7673       do iii=1,2
7674         do kkk=1,5
7675           do lll=1,3
7676             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7677      &        pizda(1,1))
7678             vv(1)=pizda(1,1)+pizda(2,2)
7679             vv(2)=pizda(2,1)-pizda(1,2)
7680             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7681      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7682      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7683           enddo
7684         enddo
7685       enddo
7686 cd      goto 1112
7687 cd1111  continue
7688       if (l.eq.j+1) then
7689 cd        goto 1110
7690 C Parallel orientation
7691 C Contribution from graph III
7692         call transpose2(EUg(1,1,l),auxmat(1,1))
7693         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7694         vv(1)=pizda(1,1)-pizda(2,2)
7695         vv(2)=pizda(1,2)+pizda(2,1)
7696         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7697      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7698 C Explicit gradient in virtual-dihedral angles.
7699         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7700      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7701      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7702         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7703         vv(1)=pizda(1,1)-pizda(2,2)
7704         vv(2)=pizda(1,2)+pizda(2,1)
7705         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7706      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7707      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7708         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7709         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7710         vv(1)=pizda(1,1)-pizda(2,2)
7711         vv(2)=pizda(1,2)+pizda(2,1)
7712         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7713      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7714      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7715 C Cartesian gradient
7716         do iii=1,2
7717           do kkk=1,5
7718             do lll=1,3
7719               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7720      &          pizda(1,1))
7721               vv(1)=pizda(1,1)-pizda(2,2)
7722               vv(2)=pizda(1,2)+pizda(2,1)
7723               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7724      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7725      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7726             enddo
7727           enddo
7728         enddo
7729 cd        goto 1112
7730 C Contribution from graph IV
7731 cd1110    continue
7732         call transpose2(EE(1,1,itl),auxmat(1,1))
7733         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7734         vv(1)=pizda(1,1)+pizda(2,2)
7735         vv(2)=pizda(2,1)-pizda(1,2)
7736         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7737      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7738 C Explicit gradient in virtual-dihedral angles.
7739         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7740      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7741         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7742         vv(1)=pizda(1,1)+pizda(2,2)
7743         vv(2)=pizda(2,1)-pizda(1,2)
7744         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7745      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7746      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7747 C Cartesian gradient
7748         do iii=1,2
7749           do kkk=1,5
7750             do lll=1,3
7751               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7752      &          pizda(1,1))
7753               vv(1)=pizda(1,1)+pizda(2,2)
7754               vv(2)=pizda(2,1)-pizda(1,2)
7755               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7756      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7757      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7758             enddo
7759           enddo
7760         enddo
7761       else
7762 C Antiparallel orientation
7763 C Contribution from graph III
7764 c        goto 1110
7765         call transpose2(EUg(1,1,j),auxmat(1,1))
7766         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7767         vv(1)=pizda(1,1)-pizda(2,2)
7768         vv(2)=pizda(1,2)+pizda(2,1)
7769         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7770      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7771 C Explicit gradient in virtual-dihedral angles.
7772         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7773      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7774      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7775         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7776         vv(1)=pizda(1,1)-pizda(2,2)
7777         vv(2)=pizda(1,2)+pizda(2,1)
7778         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7779      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7780      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7781         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7782         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7783         vv(1)=pizda(1,1)-pizda(2,2)
7784         vv(2)=pizda(1,2)+pizda(2,1)
7785         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7786      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7787      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7788 C Cartesian gradient
7789         do iii=1,2
7790           do kkk=1,5
7791             do lll=1,3
7792               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7793      &          pizda(1,1))
7794               vv(1)=pizda(1,1)-pizda(2,2)
7795               vv(2)=pizda(1,2)+pizda(2,1)
7796               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7797      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7798      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7799             enddo
7800           enddo
7801         enddo
7802 cd        goto 1112
7803 C Contribution from graph IV
7804 1110    continue
7805         call transpose2(EE(1,1,itj),auxmat(1,1))
7806         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7807         vv(1)=pizda(1,1)+pizda(2,2)
7808         vv(2)=pizda(2,1)-pizda(1,2)
7809         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7810      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7811 C Explicit gradient in virtual-dihedral angles.
7812         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7813      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7814         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7815         vv(1)=pizda(1,1)+pizda(2,2)
7816         vv(2)=pizda(2,1)-pizda(1,2)
7817         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7818      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7819      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7820 C Cartesian gradient
7821         do iii=1,2
7822           do kkk=1,5
7823             do lll=1,3
7824               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7825      &          pizda(1,1))
7826               vv(1)=pizda(1,1)+pizda(2,2)
7827               vv(2)=pizda(2,1)-pizda(1,2)
7828               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7829      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7830      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7831             enddo
7832           enddo
7833         enddo
7834       endif
7835 1112  continue
7836       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7837 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7838 cd        write (2,*) 'ijkl',i,j,k,l
7839 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7840 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7841 cd      endif
7842 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7843 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7844 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7845 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7846       if (j.lt.nres-1) then
7847         j1=j+1
7848         j2=j-1
7849       else
7850         j1=j-1
7851         j2=j-2
7852       endif
7853       if (l.lt.nres-1) then
7854         l1=l+1
7855         l2=l-1
7856       else
7857         l1=l-1
7858         l2=l-2
7859       endif
7860 cd      eij=1.0d0
7861 cd      ekl=1.0d0
7862 cd      ekont=1.0d0
7863 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7864 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7865 C        summed up outside the subrouine as for the other subroutines
7866 C        handling long-range interactions. The old code is commented out
7867 C        with "cgrad" to keep track of changes.
7868       do ll=1,3
7869 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7870 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7871         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7872         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7873 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7874 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7875 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7876 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7877 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7878 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7879 c     &   gradcorr5ij,
7880 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7881 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7882 cgrad        ghalf=0.5d0*ggg1(ll)
7883 cd        ghalf=0.0d0
7884         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7885         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7886         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7887         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7888         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7889         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7890 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7891 cgrad        ghalf=0.5d0*ggg2(ll)
7892 cd        ghalf=0.0d0
7893         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7894         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7895         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7896         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7897         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7898         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7899       enddo
7900 cd      goto 1112
7901 cgrad      do m=i+1,j-1
7902 cgrad        do ll=1,3
7903 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7904 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7905 cgrad        enddo
7906 cgrad      enddo
7907 cgrad      do m=k+1,l-1
7908 cgrad        do ll=1,3
7909 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7910 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7911 cgrad        enddo
7912 cgrad      enddo
7913 c1112  continue
7914 cgrad      do m=i+2,j2
7915 cgrad        do ll=1,3
7916 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7917 cgrad        enddo
7918 cgrad      enddo
7919 cgrad      do m=k+2,l2
7920 cgrad        do ll=1,3
7921 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7922 cgrad        enddo
7923 cgrad      enddo
7924 cd      do iii=1,nres-3
7925 cd        write (2,*) iii,g_corr5_loc(iii)
7926 cd      enddo
7927       eello5=ekont*eel5
7928 cd      write (2,*) 'ekont',ekont
7929 cd      write (iout,*) 'eello5',ekont*eel5
7930       return
7931       end
7932 c--------------------------------------------------------------------------
7933       double precision function eello6(i,j,k,l,jj,kk)
7934       implicit real*8 (a-h,o-z)
7935       include 'DIMENSIONS'
7936       include 'COMMON.IOUNITS'
7937       include 'COMMON.CHAIN'
7938       include 'COMMON.DERIV'
7939       include 'COMMON.INTERACT'
7940       include 'COMMON.CONTACTS'
7941       include 'COMMON.TORSION'
7942       include 'COMMON.VAR'
7943       include 'COMMON.GEO'
7944       include 'COMMON.FFIELD'
7945       double precision ggg1(3),ggg2(3)
7946 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7947 cd        eello6=0.0d0
7948 cd        return
7949 cd      endif
7950 cd      write (iout,*)
7951 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7952 cd     &   ' and',k,l
7953       eello6_1=0.0d0
7954       eello6_2=0.0d0
7955       eello6_3=0.0d0
7956       eello6_4=0.0d0
7957       eello6_5=0.0d0
7958       eello6_6=0.0d0
7959 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7960 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7961       do iii=1,2
7962         do kkk=1,5
7963           do lll=1,3
7964             derx(lll,kkk,iii)=0.0d0
7965           enddo
7966         enddo
7967       enddo
7968 cd      eij=facont_hb(jj,i)
7969 cd      ekl=facont_hb(kk,k)
7970 cd      ekont=eij*ekl
7971 cd      eij=1.0d0
7972 cd      ekl=1.0d0
7973 cd      ekont=1.0d0
7974       if (l.eq.j+1) then
7975         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7976         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7977         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7978         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7979         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7980         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7981       else
7982         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7983         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7984         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7985         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7986         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7987           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7988         else
7989           eello6_5=0.0d0
7990         endif
7991         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7992       endif
7993 C If turn contributions are considered, they will be handled separately.
7994       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7995 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
7996 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
7997 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
7998 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
7999 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8000 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8001 cd      goto 1112
8002       if (j.lt.nres-1) then
8003         j1=j+1
8004         j2=j-1
8005       else
8006         j1=j-1
8007         j2=j-2
8008       endif
8009       if (l.lt.nres-1) then
8010         l1=l+1
8011         l2=l-1
8012       else
8013         l1=l-1
8014         l2=l-2
8015       endif
8016       do ll=1,3
8017 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8018 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8019 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8020 cgrad        ghalf=0.5d0*ggg1(ll)
8021 cd        ghalf=0.0d0
8022         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8023         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8024         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8025         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8026         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8027         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8028         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8029         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8030 cgrad        ghalf=0.5d0*ggg2(ll)
8031 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8032 cd        ghalf=0.0d0
8033         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8034         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8035         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8036         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8037         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8038         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8039       enddo
8040 cd      goto 1112
8041 cgrad      do m=i+1,j-1
8042 cgrad        do ll=1,3
8043 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8044 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8045 cgrad        enddo
8046 cgrad      enddo
8047 cgrad      do m=k+1,l-1
8048 cgrad        do ll=1,3
8049 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8050 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8051 cgrad        enddo
8052 cgrad      enddo
8053 cgrad1112  continue
8054 cgrad      do m=i+2,j2
8055 cgrad        do ll=1,3
8056 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8057 cgrad        enddo
8058 cgrad      enddo
8059 cgrad      do m=k+2,l2
8060 cgrad        do ll=1,3
8061 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8062 cgrad        enddo
8063 cgrad      enddo
8064 cd      do iii=1,nres-3
8065 cd        write (2,*) iii,g_corr6_loc(iii)
8066 cd      enddo
8067       eello6=ekont*eel6
8068 cd      write (2,*) 'ekont',ekont
8069 cd      write (iout,*) 'eello6',ekont*eel6
8070       return
8071       end
8072 c--------------------------------------------------------------------------
8073       double precision function eello6_graph1(i,j,k,l,imat,swap)
8074       implicit real*8 (a-h,o-z)
8075       include 'DIMENSIONS'
8076       include 'COMMON.IOUNITS'
8077       include 'COMMON.CHAIN'
8078       include 'COMMON.DERIV'
8079       include 'COMMON.INTERACT'
8080       include 'COMMON.CONTACTS'
8081       include 'COMMON.TORSION'
8082       include 'COMMON.VAR'
8083       include 'COMMON.GEO'
8084       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8085       logical swap
8086       logical lprn
8087       common /kutas/ lprn
8088 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8089 C
8090 C      Parallel       Antiparallel
8091 C
8092 C          o             o
8093 C         /l\           /j\
8094 C        /   \         /   \
8095 C       /| o |         | o |\
8096 C     \ j|/k\|  /   \  |/k\|l /
8097 C      \ /   \ /     \ /   \ /
8098 C       o     o       o     o
8099 C       i             i
8100 C
8101 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8102       itk=itortyp(itype(k))
8103       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8104       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8105       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8106       call transpose2(EUgC(1,1,k),auxmat(1,1))
8107       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8108       vv1(1)=pizda1(1,1)-pizda1(2,2)
8109       vv1(2)=pizda1(1,2)+pizda1(2,1)
8110       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8111       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8112       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8113       s5=scalar2(vv(1),Dtobr2(1,i))
8114 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8115       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8116       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8117      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8118      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8119      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8120      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8121      & +scalar2(vv(1),Dtobr2der(1,i)))
8122       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8123       vv1(1)=pizda1(1,1)-pizda1(2,2)
8124       vv1(2)=pizda1(1,2)+pizda1(2,1)
8125       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8126       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8127       if (l.eq.j+1) then
8128         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8129      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8130      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8131      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8132      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8133       else
8134         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8135      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8136      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8137      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8138      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8139       endif
8140       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8141       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8142       vv1(1)=pizda1(1,1)-pizda1(2,2)
8143       vv1(2)=pizda1(1,2)+pizda1(2,1)
8144       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8145      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8146      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8147      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8148       do iii=1,2
8149         if (swap) then
8150           ind=3-iii
8151         else
8152           ind=iii
8153         endif
8154         do kkk=1,5
8155           do lll=1,3
8156             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8157             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8158             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8159             call transpose2(EUgC(1,1,k),auxmat(1,1))
8160             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8161      &        pizda1(1,1))
8162             vv1(1)=pizda1(1,1)-pizda1(2,2)
8163             vv1(2)=pizda1(1,2)+pizda1(2,1)
8164             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8165             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8166      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8167             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8168      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8169             s5=scalar2(vv(1),Dtobr2(1,i))
8170             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8171           enddo
8172         enddo
8173       enddo
8174       return
8175       end
8176 c----------------------------------------------------------------------------
8177       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8178       implicit real*8 (a-h,o-z)
8179       include 'DIMENSIONS'
8180       include 'COMMON.IOUNITS'
8181       include 'COMMON.CHAIN'
8182       include 'COMMON.DERIV'
8183       include 'COMMON.INTERACT'
8184       include 'COMMON.CONTACTS'
8185       include 'COMMON.TORSION'
8186       include 'COMMON.VAR'
8187       include 'COMMON.GEO'
8188       logical swap
8189       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8190      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8191       logical lprn
8192       common /kutas/ lprn
8193 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8194 C                                                                              C
8195 C      Parallel       Antiparallel                                             C
8196 C                                                                              C
8197 C          o             o                                                     C
8198 C     \   /l\           /j\   /                                                C
8199 C      \ /   \         /   \ /                                                 C
8200 C       o| o |         | o |o                                                  C
8201 C     \ j|/k\|      \  |/k\|l                                                  C
8202 C      \ /   \       \ /   \                                                   C
8203 C       o             o                                                        C
8204 C       i             i                                                        C
8205 C                                                                              C
8206 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8207 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8208 C AL 7/4/01 s1 would occur in the sixth-order moment,
8209 C           but not in a cluster cumulant
8210 #ifdef MOMENT
8211       s1=dip(1,jj,i)*dip(1,kk,k)
8212 #endif
8213       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8214       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8215       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8216       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8217       call transpose2(EUg(1,1,k),auxmat(1,1))
8218       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8219       vv(1)=pizda(1,1)-pizda(2,2)
8220       vv(2)=pizda(1,2)+pizda(2,1)
8221       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8222 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8223 #ifdef MOMENT
8224       eello6_graph2=-(s1+s2+s3+s4)
8225 #else
8226       eello6_graph2=-(s2+s3+s4)
8227 #endif
8228 c      eello6_graph2=-s3
8229 C Derivatives in gamma(i-1)
8230       if (i.gt.1) then
8231 #ifdef MOMENT
8232         s1=dipderg(1,jj,i)*dip(1,kk,k)
8233 #endif
8234         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8235         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8236         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8237         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8238 #ifdef MOMENT
8239         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8240 #else
8241         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8242 #endif
8243 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8244       endif
8245 C Derivatives in gamma(k-1)
8246 #ifdef MOMENT
8247       s1=dip(1,jj,i)*dipderg(1,kk,k)
8248 #endif
8249       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8250       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8251       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8252       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8253       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8254       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8255       vv(1)=pizda(1,1)-pizda(2,2)
8256       vv(2)=pizda(1,2)+pizda(2,1)
8257       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8258 #ifdef MOMENT
8259       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8260 #else
8261       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8262 #endif
8263 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8264 C Derivatives in gamma(j-1) or gamma(l-1)
8265       if (j.gt.1) then
8266 #ifdef MOMENT
8267         s1=dipderg(3,jj,i)*dip(1,kk,k)
8268 #endif
8269         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8270         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8271         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8272         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8273         vv(1)=pizda(1,1)-pizda(2,2)
8274         vv(2)=pizda(1,2)+pizda(2,1)
8275         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8276 #ifdef MOMENT
8277         if (swap) then
8278           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8279         else
8280           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8281         endif
8282 #endif
8283         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8284 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8285       endif
8286 C Derivatives in gamma(l-1) or gamma(j-1)
8287       if (l.gt.1) then
8288 #ifdef MOMENT
8289         s1=dip(1,jj,i)*dipderg(3,kk,k)
8290 #endif
8291         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8292         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8293         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8294         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8295         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8296         vv(1)=pizda(1,1)-pizda(2,2)
8297         vv(2)=pizda(1,2)+pizda(2,1)
8298         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8299 #ifdef MOMENT
8300         if (swap) then
8301           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8302         else
8303           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8304         endif
8305 #endif
8306         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8307 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8308       endif
8309 C Cartesian derivatives.
8310       if (lprn) then
8311         write (2,*) 'In eello6_graph2'
8312         do iii=1,2
8313           write (2,*) 'iii=',iii
8314           do kkk=1,5
8315             write (2,*) 'kkk=',kkk
8316             do jjj=1,2
8317               write (2,'(3(2f10.5),5x)')
8318      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8319             enddo
8320           enddo
8321         enddo
8322       endif
8323       do iii=1,2
8324         do kkk=1,5
8325           do lll=1,3
8326 #ifdef MOMENT
8327             if (iii.eq.1) then
8328               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8329             else
8330               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8331             endif
8332 #endif
8333             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8334      &        auxvec(1))
8335             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8336             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8337      &        auxvec(1))
8338             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8339             call transpose2(EUg(1,1,k),auxmat(1,1))
8340             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8341      &        pizda(1,1))
8342             vv(1)=pizda(1,1)-pizda(2,2)
8343             vv(2)=pizda(1,2)+pizda(2,1)
8344             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8345 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8346 #ifdef MOMENT
8347             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8348 #else
8349             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8350 #endif
8351             if (swap) then
8352               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8353             else
8354               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8355             endif
8356           enddo
8357         enddo
8358       enddo
8359       return
8360       end
8361 c----------------------------------------------------------------------------
8362       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8363       implicit real*8 (a-h,o-z)
8364       include 'DIMENSIONS'
8365       include 'COMMON.IOUNITS'
8366       include 'COMMON.CHAIN'
8367       include 'COMMON.DERIV'
8368       include 'COMMON.INTERACT'
8369       include 'COMMON.CONTACTS'
8370       include 'COMMON.TORSION'
8371       include 'COMMON.VAR'
8372       include 'COMMON.GEO'
8373       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8374       logical swap
8375 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8376 C                                                                              C
8377 C      Parallel       Antiparallel                                             C
8378 C                                                                              C
8379 C          o             o                                                     C
8380 C         /l\   /   \   /j\                                                    C
8381 C        /   \ /     \ /   \                                                   C
8382 C       /| o |o       o| o |\                                                  C
8383 C       j|/k\|  /      |/k\|l /                                                C
8384 C        /   \ /       /   \ /                                                 C
8385 C       /     o       /     o                                                  C
8386 C       i             i                                                        C
8387 C                                                                              C
8388 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8389 C
8390 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8391 C           energy moment and not to the cluster cumulant.
8392       iti=itortyp(itype(i))
8393       if (j.lt.nres-1) then
8394         itj1=itortyp(itype(j+1))
8395       else
8396         itj1=ntortyp+1
8397       endif
8398       itk=itortyp(itype(k))
8399       itk1=itortyp(itype(k+1))
8400       if (l.lt.nres-1) then
8401         itl1=itortyp(itype(l+1))
8402       else
8403         itl1=ntortyp+1
8404       endif
8405 #ifdef MOMENT
8406       s1=dip(4,jj,i)*dip(4,kk,k)
8407 #endif
8408       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8409       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8410       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8411       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8412       call transpose2(EE(1,1,itk),auxmat(1,1))
8413       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8414       vv(1)=pizda(1,1)+pizda(2,2)
8415       vv(2)=pizda(2,1)-pizda(1,2)
8416       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8417 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8418 cd     & "sum",-(s2+s3+s4)
8419 #ifdef MOMENT
8420       eello6_graph3=-(s1+s2+s3+s4)
8421 #else
8422       eello6_graph3=-(s2+s3+s4)
8423 #endif
8424 c      eello6_graph3=-s4
8425 C Derivatives in gamma(k-1)
8426       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8427       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8428       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8429       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8430 C Derivatives in gamma(l-1)
8431       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8432       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8433       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8434       vv(1)=pizda(1,1)+pizda(2,2)
8435       vv(2)=pizda(2,1)-pizda(1,2)
8436       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8437       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8438 C Cartesian derivatives.
8439       do iii=1,2
8440         do kkk=1,5
8441           do lll=1,3
8442 #ifdef MOMENT
8443             if (iii.eq.1) then
8444               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8445             else
8446               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8447             endif
8448 #endif
8449             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8450      &        auxvec(1))
8451             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8452             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8453      &        auxvec(1))
8454             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8455             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8456      &        pizda(1,1))
8457             vv(1)=pizda(1,1)+pizda(2,2)
8458             vv(2)=pizda(2,1)-pizda(1,2)
8459             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8460 #ifdef MOMENT
8461             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8462 #else
8463             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8464 #endif
8465             if (swap) then
8466               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8467             else
8468               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8469             endif
8470 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8471           enddo
8472         enddo
8473       enddo
8474       return
8475       end
8476 c----------------------------------------------------------------------------
8477       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8478       implicit real*8 (a-h,o-z)
8479       include 'DIMENSIONS'
8480       include 'COMMON.IOUNITS'
8481       include 'COMMON.CHAIN'
8482       include 'COMMON.DERIV'
8483       include 'COMMON.INTERACT'
8484       include 'COMMON.CONTACTS'
8485       include 'COMMON.TORSION'
8486       include 'COMMON.VAR'
8487       include 'COMMON.GEO'
8488       include 'COMMON.FFIELD'
8489       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8490      & auxvec1(2),auxmat1(2,2)
8491       logical swap
8492 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8493 C                                                                              C
8494 C      Parallel       Antiparallel                                             C
8495 C                                                                              C
8496 C          o             o                                                     C
8497 C         /l\   /   \   /j\                                                    C
8498 C        /   \ /     \ /   \                                                   C
8499 C       /| o |o       o| o |\                                                  C
8500 C     \ j|/k\|      \  |/k\|l                                                  C
8501 C      \ /   \       \ /   \                                                   C
8502 C       o     \       o     \                                                  C
8503 C       i             i                                                        C
8504 C                                                                              C
8505 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8506 C
8507 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8508 C           energy moment and not to the cluster cumulant.
8509 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8510       iti=itortyp(itype(i))
8511       itj=itortyp(itype(j))
8512       if (j.lt.nres-1) then
8513         itj1=itortyp(itype(j+1))
8514       else
8515         itj1=ntortyp+1
8516       endif
8517       itk=itortyp(itype(k))
8518       if (k.lt.nres-1) then
8519         itk1=itortyp(itype(k+1))
8520       else
8521         itk1=ntortyp+1
8522       endif
8523       itl=itortyp(itype(l))
8524       if (l.lt.nres-1) then
8525         itl1=itortyp(itype(l+1))
8526       else
8527         itl1=ntortyp+1
8528       endif
8529 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8530 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8531 cd     & ' itl',itl,' itl1',itl1
8532 #ifdef MOMENT
8533       if (imat.eq.1) then
8534         s1=dip(3,jj,i)*dip(3,kk,k)
8535       else
8536         s1=dip(2,jj,j)*dip(2,kk,l)
8537       endif
8538 #endif
8539       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8540       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8541       if (j.eq.l+1) then
8542         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8543         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8544       else
8545         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8546         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8547       endif
8548       call transpose2(EUg(1,1,k),auxmat(1,1))
8549       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8550       vv(1)=pizda(1,1)-pizda(2,2)
8551       vv(2)=pizda(2,1)+pizda(1,2)
8552       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8553 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8554 #ifdef MOMENT
8555       eello6_graph4=-(s1+s2+s3+s4)
8556 #else
8557       eello6_graph4=-(s2+s3+s4)
8558 #endif
8559 C Derivatives in gamma(i-1)
8560       if (i.gt.1) then
8561 #ifdef MOMENT
8562         if (imat.eq.1) then
8563           s1=dipderg(2,jj,i)*dip(3,kk,k)
8564         else
8565           s1=dipderg(4,jj,j)*dip(2,kk,l)
8566         endif
8567 #endif
8568         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8569         if (j.eq.l+1) then
8570           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8571           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8572         else
8573           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8574           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8575         endif
8576         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8577         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8578 cd          write (2,*) 'turn6 derivatives'
8579 #ifdef MOMENT
8580           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8581 #else
8582           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8583 #endif
8584         else
8585 #ifdef MOMENT
8586           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8587 #else
8588           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8589 #endif
8590         endif
8591       endif
8592 C Derivatives in gamma(k-1)
8593 #ifdef MOMENT
8594       if (imat.eq.1) then
8595         s1=dip(3,jj,i)*dipderg(2,kk,k)
8596       else
8597         s1=dip(2,jj,j)*dipderg(4,kk,l)
8598       endif
8599 #endif
8600       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8601       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8602       if (j.eq.l+1) then
8603         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8604         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8605       else
8606         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8607         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8608       endif
8609       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8610       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8611       vv(1)=pizda(1,1)-pizda(2,2)
8612       vv(2)=pizda(2,1)+pizda(1,2)
8613       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8614       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8615 #ifdef MOMENT
8616         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8617 #else
8618         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8619 #endif
8620       else
8621 #ifdef MOMENT
8622         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8623 #else
8624         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8625 #endif
8626       endif
8627 C Derivatives in gamma(j-1) or gamma(l-1)
8628       if (l.eq.j+1 .and. l.gt.1) then
8629         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8630         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8631         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8632         vv(1)=pizda(1,1)-pizda(2,2)
8633         vv(2)=pizda(2,1)+pizda(1,2)
8634         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8635         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8636       else if (j.gt.1) then
8637         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8638         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8639         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8640         vv(1)=pizda(1,1)-pizda(2,2)
8641         vv(2)=pizda(2,1)+pizda(1,2)
8642         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8643         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8644           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8645         else
8646           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8647         endif
8648       endif
8649 C Cartesian derivatives.
8650       do iii=1,2
8651         do kkk=1,5
8652           do lll=1,3
8653 #ifdef MOMENT
8654             if (iii.eq.1) then
8655               if (imat.eq.1) then
8656                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8657               else
8658                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8659               endif
8660             else
8661               if (imat.eq.1) then
8662                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8663               else
8664                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8665               endif
8666             endif
8667 #endif
8668             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8669      &        auxvec(1))
8670             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8671             if (j.eq.l+1) then
8672               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8673      &          b1(1,itj1),auxvec(1))
8674               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8675             else
8676               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8677      &          b1(1,itl1),auxvec(1))
8678               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8679             endif
8680             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8681      &        pizda(1,1))
8682             vv(1)=pizda(1,1)-pizda(2,2)
8683             vv(2)=pizda(2,1)+pizda(1,2)
8684             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8685             if (swap) then
8686               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8687 #ifdef MOMENT
8688                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8689      &             -(s1+s2+s4)
8690 #else
8691                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8692      &             -(s2+s4)
8693 #endif
8694                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8695               else
8696 #ifdef MOMENT
8697                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8698 #else
8699                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8700 #endif
8701                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8702               endif
8703             else
8704 #ifdef MOMENT
8705               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8706 #else
8707               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8708 #endif
8709               if (l.eq.j+1) then
8710                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8711               else
8712                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8713               endif
8714             endif
8715           enddo
8716         enddo
8717       enddo
8718       return
8719       end
8720 c----------------------------------------------------------------------------
8721       double precision function eello_turn6(i,jj,kk)
8722       implicit real*8 (a-h,o-z)
8723       include 'DIMENSIONS'
8724       include 'COMMON.IOUNITS'
8725       include 'COMMON.CHAIN'
8726       include 'COMMON.DERIV'
8727       include 'COMMON.INTERACT'
8728       include 'COMMON.CONTACTS'
8729       include 'COMMON.TORSION'
8730       include 'COMMON.VAR'
8731       include 'COMMON.GEO'
8732       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8733      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8734      &  ggg1(3),ggg2(3)
8735       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8736      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8737 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8738 C           the respective energy moment and not to the cluster cumulant.
8739       s1=0.0d0
8740       s8=0.0d0
8741       s13=0.0d0
8742 c
8743       eello_turn6=0.0d0
8744       j=i+4
8745       k=i+1
8746       l=i+3
8747       iti=itortyp(itype(i))
8748       itk=itortyp(itype(k))
8749       itk1=itortyp(itype(k+1))
8750       itl=itortyp(itype(l))
8751       itj=itortyp(itype(j))
8752 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8753 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8754 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8755 cd        eello6=0.0d0
8756 cd        return
8757 cd      endif
8758 cd      write (iout,*)
8759 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8760 cd     &   ' and',k,l
8761 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8762       do iii=1,2
8763         do kkk=1,5
8764           do lll=1,3
8765             derx_turn(lll,kkk,iii)=0.0d0
8766           enddo
8767         enddo
8768       enddo
8769 cd      eij=1.0d0
8770 cd      ekl=1.0d0
8771 cd      ekont=1.0d0
8772       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8773 cd      eello6_5=0.0d0
8774 cd      write (2,*) 'eello6_5',eello6_5
8775 #ifdef MOMENT
8776       call transpose2(AEA(1,1,1),auxmat(1,1))
8777       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8778       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8779       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8780 #endif
8781       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8782       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8783       s2 = scalar2(b1(1,itk),vtemp1(1))
8784 #ifdef MOMENT
8785       call transpose2(AEA(1,1,2),atemp(1,1))
8786       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8787       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8788       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8789 #endif
8790       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8791       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8792       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8793 #ifdef MOMENT
8794       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8795       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8796       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8797       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8798       ss13 = scalar2(b1(1,itk),vtemp4(1))
8799       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8800 #endif
8801 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8802 c      s1=0.0d0
8803 c      s2=0.0d0
8804 c      s8=0.0d0
8805 c      s12=0.0d0
8806 c      s13=0.0d0
8807       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8808 C Derivatives in gamma(i+2)
8809       s1d =0.0d0
8810       s8d =0.0d0
8811 #ifdef MOMENT
8812       call transpose2(AEA(1,1,1),auxmatd(1,1))
8813       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8814       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8815       call transpose2(AEAderg(1,1,2),atempd(1,1))
8816       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8817       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8818 #endif
8819       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8820       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8821       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8822 c      s1d=0.0d0
8823 c      s2d=0.0d0
8824 c      s8d=0.0d0
8825 c      s12d=0.0d0
8826 c      s13d=0.0d0
8827       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8828 C Derivatives in gamma(i+3)
8829 #ifdef MOMENT
8830       call transpose2(AEA(1,1,1),auxmatd(1,1))
8831       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8832       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8833       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8834 #endif
8835       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8836       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8837       s2d = scalar2(b1(1,itk),vtemp1d(1))
8838 #ifdef MOMENT
8839       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8840       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8841 #endif
8842       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8843 #ifdef MOMENT
8844       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8845       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8846       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8847 #endif
8848 c      s1d=0.0d0
8849 c      s2d=0.0d0
8850 c      s8d=0.0d0
8851 c      s12d=0.0d0
8852 c      s13d=0.0d0
8853 #ifdef MOMENT
8854       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8855      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8856 #else
8857       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8858      &               -0.5d0*ekont*(s2d+s12d)
8859 #endif
8860 C Derivatives in gamma(i+4)
8861       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8862       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8863       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8864 #ifdef MOMENT
8865       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8866       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8867       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8868 #endif
8869 c      s1d=0.0d0
8870 c      s2d=0.0d0
8871 c      s8d=0.0d0
8872 C      s12d=0.0d0
8873 c      s13d=0.0d0
8874 #ifdef MOMENT
8875       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8876 #else
8877       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8878 #endif
8879 C Derivatives in gamma(i+5)
8880 #ifdef MOMENT
8881       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8882       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8883       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8884 #endif
8885       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8886       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8887       s2d = scalar2(b1(1,itk),vtemp1d(1))
8888 #ifdef MOMENT
8889       call transpose2(AEA(1,1,2),atempd(1,1))
8890       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8891       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8892 #endif
8893       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8894       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8895 #ifdef MOMENT
8896       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8897       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8898       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8899 #endif
8900 c      s1d=0.0d0
8901 c      s2d=0.0d0
8902 c      s8d=0.0d0
8903 c      s12d=0.0d0
8904 c      s13d=0.0d0
8905 #ifdef MOMENT
8906       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8907      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8908 #else
8909       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8910      &               -0.5d0*ekont*(s2d+s12d)
8911 #endif
8912 C Cartesian derivatives
8913       do iii=1,2
8914         do kkk=1,5
8915           do lll=1,3
8916 #ifdef MOMENT
8917             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8918             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8919             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8920 #endif
8921             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8922             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8923      &          vtemp1d(1))
8924             s2d = scalar2(b1(1,itk),vtemp1d(1))
8925 #ifdef MOMENT
8926             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8927             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8928             s8d = -(atempd(1,1)+atempd(2,2))*
8929      &           scalar2(cc(1,1,itl),vtemp2(1))
8930 #endif
8931             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8932      &           auxmatd(1,1))
8933             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8934             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8935 c      s1d=0.0d0
8936 c      s2d=0.0d0
8937 c      s8d=0.0d0
8938 c      s12d=0.0d0
8939 c      s13d=0.0d0
8940 #ifdef MOMENT
8941             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8942      &        - 0.5d0*(s1d+s2d)
8943 #else
8944             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8945      &        - 0.5d0*s2d
8946 #endif
8947 #ifdef MOMENT
8948             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8949      &        - 0.5d0*(s8d+s12d)
8950 #else
8951             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8952      &        - 0.5d0*s12d
8953 #endif
8954           enddo
8955         enddo
8956       enddo
8957 #ifdef MOMENT
8958       do kkk=1,5
8959         do lll=1,3
8960           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8961      &      achuj_tempd(1,1))
8962           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8963           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8964           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8965           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8966           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8967      &      vtemp4d(1))
8968           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8969           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8970           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8971         enddo
8972       enddo
8973 #endif
8974 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8975 cd     &  16*eel_turn6_num
8976 cd      goto 1112
8977       if (j.lt.nres-1) then
8978         j1=j+1
8979         j2=j-1
8980       else
8981         j1=j-1
8982         j2=j-2
8983       endif
8984       if (l.lt.nres-1) then
8985         l1=l+1
8986         l2=l-1
8987       else
8988         l1=l-1
8989         l2=l-2
8990       endif
8991       do ll=1,3
8992 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
8993 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
8994 cgrad        ghalf=0.5d0*ggg1(ll)
8995 cd        ghalf=0.0d0
8996         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
8997         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
8998         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
8999      &    +ekont*derx_turn(ll,2,1)
9000         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9001         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9002      &    +ekont*derx_turn(ll,4,1)
9003         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9004         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9005         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9006 cgrad        ghalf=0.5d0*ggg2(ll)
9007 cd        ghalf=0.0d0
9008         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9009      &    +ekont*derx_turn(ll,2,2)
9010         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9011         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9012      &    +ekont*derx_turn(ll,4,2)
9013         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9014         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9015         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9016       enddo
9017 cd      goto 1112
9018 cgrad      do m=i+1,j-1
9019 cgrad        do ll=1,3
9020 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9021 cgrad        enddo
9022 cgrad      enddo
9023 cgrad      do m=k+1,l-1
9024 cgrad        do ll=1,3
9025 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9026 cgrad        enddo
9027 cgrad      enddo
9028 cgrad1112  continue
9029 cgrad      do m=i+2,j2
9030 cgrad        do ll=1,3
9031 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9032 cgrad        enddo
9033 cgrad      enddo
9034 cgrad      do m=k+2,l2
9035 cgrad        do ll=1,3
9036 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9037 cgrad        enddo
9038 cgrad      enddo
9039 cd      do iii=1,nres-3
9040 cd        write (2,*) iii,g_corr6_loc(iii)
9041 cd      enddo
9042       eello_turn6=ekont*eel_turn6
9043 cd      write (2,*) 'ekont',ekont
9044 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9045       return
9046       end
9047
9048 C-----------------------------------------------------------------------------
9049       double precision function scalar(u,v)
9050 !DIR$ INLINEALWAYS scalar
9051 #ifndef OSF
9052 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9053 #endif
9054       implicit none
9055       double precision u(3),v(3)
9056 cd      double precision sc
9057 cd      integer i
9058 cd      sc=0.0d0
9059 cd      do i=1,3
9060 cd        sc=sc+u(i)*v(i)
9061 cd      enddo
9062 cd      scalar=sc
9063
9064       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9065       return
9066       end
9067 crc-------------------------------------------------
9068       SUBROUTINE MATVEC2(A1,V1,V2)
9069 !DIR$ INLINEALWAYS MATVEC2
9070 #ifndef OSF
9071 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9072 #endif
9073       implicit real*8 (a-h,o-z)
9074       include 'DIMENSIONS'
9075       DIMENSION A1(2,2),V1(2),V2(2)
9076 c      DO 1 I=1,2
9077 c        VI=0.0
9078 c        DO 3 K=1,2
9079 c    3     VI=VI+A1(I,K)*V1(K)
9080 c        Vaux(I)=VI
9081 c    1 CONTINUE
9082
9083       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9084       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9085
9086       v2(1)=vaux1
9087       v2(2)=vaux2
9088       END
9089 C---------------------------------------
9090       SUBROUTINE MATMAT2(A1,A2,A3)
9091 #ifndef OSF
9092 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9093 #endif
9094       implicit real*8 (a-h,o-z)
9095       include 'DIMENSIONS'
9096       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9097 c      DIMENSION AI3(2,2)
9098 c        DO  J=1,2
9099 c          A3IJ=0.0
9100 c          DO K=1,2
9101 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9102 c          enddo
9103 c          A3(I,J)=A3IJ
9104 c       enddo
9105 c      enddo
9106
9107       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9108       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9109       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9110       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9111
9112       A3(1,1)=AI3_11
9113       A3(2,1)=AI3_21
9114       A3(1,2)=AI3_12
9115       A3(2,2)=AI3_22
9116       END
9117
9118 c-------------------------------------------------------------------------
9119       double precision function scalar2(u,v)
9120 !DIR$ INLINEALWAYS scalar2
9121       implicit none
9122       double precision u(2),v(2)
9123       double precision sc
9124       integer i
9125       scalar2=u(1)*v(1)+u(2)*v(2)
9126       return
9127       end
9128
9129 C-----------------------------------------------------------------------------
9130
9131       subroutine transpose2(a,at)
9132 !DIR$ INLINEALWAYS transpose2
9133 #ifndef OSF
9134 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9135 #endif
9136       implicit none
9137       double precision a(2,2),at(2,2)
9138       at(1,1)=a(1,1)
9139       at(1,2)=a(2,1)
9140       at(2,1)=a(1,2)
9141       at(2,2)=a(2,2)
9142       return
9143       end
9144 c--------------------------------------------------------------------------
9145       subroutine transpose(n,a,at)
9146       implicit none
9147       integer n,i,j
9148       double precision a(n,n),at(n,n)
9149       do i=1,n
9150         do j=1,n
9151           at(j,i)=a(i,j)
9152         enddo
9153       enddo
9154       return
9155       end
9156 C---------------------------------------------------------------------------
9157       subroutine prodmat3(a1,a2,kk,transp,prod)
9158 !DIR$ INLINEALWAYS prodmat3
9159 #ifndef OSF
9160 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9161 #endif
9162       implicit none
9163       integer i,j
9164       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9165       logical transp
9166 crc      double precision auxmat(2,2),prod_(2,2)
9167
9168       if (transp) then
9169 crc        call transpose2(kk(1,1),auxmat(1,1))
9170 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9171 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9172
9173            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9174      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9175            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9176      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9177            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9178      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9179            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9180      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9181
9182       else
9183 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9184 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9185
9186            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9187      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9188            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9189      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9190            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9191      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9192            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9193      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9194
9195       endif
9196 c      call transpose2(a2(1,1),a2t(1,1))
9197
9198 crc      print *,transp
9199 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9200 crc      print *,((prod(i,j),i=1,2),j=1,2)
9201
9202       return
9203       end
9204