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 cmc
 135 cmc Sep-06: egb takes care of dynamic ss bonds too
 136 cmc
 137       if (dyn_ss) call dyn_set_nss
 138
 139 c      print *,"Processor",myrank," computed USCSC"
 140 #ifdef TIMING
 141 #ifdef MPI
 142       time01=MPI_Wtime()
 143 #else
 144       time00=tcpu()
 145 #endif
 146 #endif
 147       call vec_and_deriv
 148 #ifdef TIMING
 149 #ifdef MPI
 150       time_vec=time_vec+MPI_Wtime()-time01
 151 #else
 152       time_vec=time_vec+tcpu()-time01
 153 #endif
 154 #endif
 155 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 156       if (ipot.lt.6) then
 157 #ifdef SPLITELE
 158          if (welec.gt.0d0.or.wvdwpp.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 #else
 163          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 164      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 165      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 166      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 167 #endif
 168             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 169          else
 170             ees=0.0d0
 171             evdw1=0.0d0
 172             eel_loc=0.0d0
 173             eello_turn3=0.0d0
 174             eello_turn4=0.0d0
 175          endif
 176       else
 177 c        write (iout,*) "Soft-spheer ELEC potential"
 178         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 179      &   eello_turn4)
 180       endif
 181 c      print *,"Processor",myrank," computed UELEC"
 182 C
 183 C Calculate excluded-volume interaction energy between peptide groups
 184 C and side chains.
 185 C
 186       if (ipot.lt.6) then
 187        if(wscp.gt.0d0) then
 188         call escp(evdw2,evdw2_14)
 189        else
 190         evdw2=0
 191         evdw2_14=0
 192        endif
 193       else
 194 c        write (iout,*) "Soft-sphere SCP potential"
 195         call escp_soft_sphere(evdw2,evdw2_14)
 196       endif
 197 c
 198 c Calculate the bond-stretching energy
 199 c
 200       call ebond(estr)
 201 C
 202 C Calculate the disulfide-bridge and other energy and the contributions
 203 C from other distance constraints.
 204 cd    print *,'Calling EHPB'
 205       call edis(ehpb)
 206 cd    print *,'EHPB exitted succesfully.'
 207 C
 208 C Calculate the virtual-bond-angle energy.
 209 C
 210       if (wang.gt.0d0) then
 211         call ebend(ebe)
 212       else
 213         ebe=0
 214       endif
 215 c      print *,"Processor",myrank," computed UB"
 216 C
 217 C Calculate the SC local energy.
 218 C
 219       call esc(escloc)
 220 c      print *,"Processor",myrank," computed USC"
 221 C
 222 C Calculate the virtual-bond torsional energy.
 223 C
 224 cd    print *,'nterm=',nterm
 225       if (wtor.gt.0) then
 226        call etor(etors,edihcnstr)
 227       else
 228        etors=0
 229        edihcnstr=0
 230       endif
 231 c      print *,"Processor",myrank," computed Utor"
 232 C
 233 C 6/23/01 Calculate double-torsional energy
 234 C
 235       if (wtor_d.gt.0) then
 236        call etor_d(etors_d)
 237       else
 238        etors_d=0
 239       endif
 240 c      print *,"Processor",myrank," computed Utord"
 241 C
 242 C 21/5/07 Calculate local sicdechain correlation energy
 243 C
 244       if (wsccor.gt.0.0d0) then
 245         call eback_sc_corr(esccor)
 246       else
 247         esccor=0.0d0
 248       endif
 249 c      print *,"Processor",myrank," computed Usccorr"
 250 C
 251 C 12/1/95 Multi-body terms
 252 C
 253       n_corr=0
 254       n_corr1=0
 255       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 256      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 257          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 258 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 259 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 260       else
 261          ecorr=0.0d0
 262          ecorr5=0.0d0
 263          ecorr6=0.0d0
 264          eturn6=0.0d0
 265       endif
 266       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 267          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 268 cd         write (iout,*) "multibody_hb ecorr",ecorr
 269       endif
 270 c      print *,"Processor",myrank," computed Ucorr"
 271 C
 272 C If performing constraint dynamics, call the constraint energy
 273 C  after the equilibration time
 274       if(usampl.and.totT.gt.eq_time) then
 275          call EconstrQ
 276          call Econstr_back
 277       else
 278          Uconst=0.0d0
 279          Uconst_back=0.0d0
 280       endif
 281 #ifdef TIMING
 282 #ifdef MPI
 283       time_enecalc=time_enecalc+MPI_Wtime()-time00
 284 #else
 285       time_enecalc=time_enecalc+tcpu()-time00
 286 #endif
 287 #endif
 288 c      print *,"Processor",myrank," computed Uconstr"
 289 #ifdef TIMING
 290 #ifdef MPI
 291       time00=MPI_Wtime()
 292 #else
 293       time00=tcpu()
 294 #endif
 295 #endif
 296 c
 297 C Sum the energies
 298 C
 299       energia(1)=evdw
 300 #ifdef SCP14
 301       energia(2)=evdw2-evdw2_14
 302       energia(18)=evdw2_14
 303 #else
 304       energia(2)=evdw2
 305       energia(18)=0.0d0
 306 #endif
 307 #ifdef SPLITELE
 308       energia(3)=ees
 309       energia(16)=evdw1
 310 #else
 311       energia(3)=ees+evdw1
 312       energia(16)=0.0d0
 313 #endif
 314       energia(4)=ecorr
 315       energia(5)=ecorr5
 316       energia(6)=ecorr6
 317       energia(7)=eel_loc
 318       energia(8)=eello_turn3
 319       energia(9)=eello_turn4
 320       energia(10)=eturn6
 321       energia(11)=ebe
 322       energia(12)=escloc
 323       energia(13)=etors
 324       energia(14)=etors_d
 325       energia(15)=ehpb
 326       energia(19)=edihcnstr
 327       energia(17)=estr
 328       energia(20)=Uconst+Uconst_back
 329       energia(21)=esccor
 330       energia(22)=evdw_p
 331       energia(23)=evdw_m
 332 c      print *," Processor",myrank," calls SUM_ENERGY"
 333       call sum_energy(energia,.true.)
 334 c      print *," Processor",myrank," left SUM_ENERGY"
 335 #ifdef TIMING
 336 #ifdef MPI
 337       time_sumene=time_sumene+MPI_Wtime()-time00
 338 #else
 339       time_sumene=time_sumene+tcpu()-time00
 340 #endif
 341 #endif
 342       return
 343       end
 344 c-------------------------------------------------------------------------------
 345       subroutine sum_energy(energia,reduce)
 346       implicit real*8 (a-h,o-z)
 347       include 'DIMENSIONS'
 348 #ifndef ISNAN
 349       external proc_proc
 350 #ifdef WINPGI
 351 cMS$ATTRIBUTES C ::  proc_proc
 352 #endif
 353 #endif
 354 #ifdef MPI
 355       include "mpif.h"
 356 #endif
 357       include 'COMMON.SETUP'
 358       include 'COMMON.IOUNITS'
 359       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 360       include 'COMMON.FFIELD'
 361       include 'COMMON.DERIV'
 362       include 'COMMON.INTERACT'
 363       include 'COMMON.SBRIDGE'
 364       include 'COMMON.CHAIN'
 365       include 'COMMON.VAR'
 366       include 'COMMON.CONTROL'
 367       include 'COMMON.TIME1'
 368       logical reduce
 369 #ifdef MPI
 370       if (nfgtasks.gt.1 .and. reduce) then
 371 #ifdef DEBUG
 372         write (iout,*) "energies before REDUCE"
 373         call enerprint(energia)
 374         call flush(iout)
 375 #endif
 376         do i=0,n_ene
 377           enebuff(i)=energia(i)
 378         enddo
 379         time00=MPI_Wtime()
 380         call MPI_Barrier(FG_COMM,IERR)
 381         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 382         time00=MPI_Wtime()
 383         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 384      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 385 #ifdef DEBUG
 386         write (iout,*) "energies after REDUCE"
 387         call enerprint(energia)
 388         call flush(iout)
 389 #endif
 390         time_Reduce=time_Reduce+MPI_Wtime()-time00
 391       endif
 392       if (fg_rank.eq.0) then
 393 #endif
 394 #ifdef TSCSC
 395       evdw=energia(22)+wsct*energia(23)
 396 #else
 397       evdw=energia(1)
 398 #endif
 399 #ifdef SCP14
 400       evdw2=energia(2)+energia(18)
 401       evdw2_14=energia(18)
 402 #else
 403       evdw2=energia(2)
 404 #endif
 405 #ifdef SPLITELE
 406       ees=energia(3)
 407       evdw1=energia(16)
 408 #else
 409       ees=energia(3)
 410       evdw1=0.0d0
 411 #endif
 412       ecorr=energia(4)
 413       ecorr5=energia(5)
 414       ecorr6=energia(6)
 415       eel_loc=energia(7)
 416       eello_turn3=energia(8)
 417       eello_turn4=energia(9)
 418       eturn6=energia(10)
 419       ebe=energia(11)
 420       escloc=energia(12)
 421       etors=energia(13)
 422       etors_d=energia(14)
 423       ehpb=energia(15)
 424       edihcnstr=energia(19)
 425       estr=energia(17)
 426       Uconst=energia(20)
 427       esccor=energia(21)
 428 #ifdef SPLITELE
 429       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 430      & +wang*ebe+wtor*etors+wscloc*escloc
 431      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 432      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 433      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 434      & +wbond*estr+Uconst+wsccor*esccor
 435 #else
 436       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 437      & +wang*ebe+wtor*etors+wscloc*escloc
 438      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 439      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 440      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 441      & +wbond*estr+Uconst+wsccor*esccor
 442 #endif
 443       energia(0)=etot
 444 c detecting NaNQ
 445 #ifdef ISNAN
 446 #ifdef AIX
 447       if (isnan(etot).ne.0) energia(0)=1.0d+99
 448 #else
 449       if (isnan(etot)) energia(0)=1.0d+99
 450 #endif
 451 #else
 452       i=0
 453 #ifdef WINPGI
 454       idumm=proc_proc(etot,i)
 455 #else
 456       call proc_proc(etot,i)
 457 #endif
 458       if(i.eq.1)energia(0)=1.0d+99
 459 #endif
 460 #ifdef MPI
 461       endif
 462 #endif
 463       return
 464       end
 465 c-------------------------------------------------------------------------------
 466       subroutine sum_gradient
 467       implicit real*8 (a-h,o-z)
 468       include 'DIMENSIONS'
 469 #ifndef ISNAN
 470       external proc_proc
 471 #ifdef WINPGI
 472 cMS$ATTRIBUTES C ::  proc_proc
 473 #endif
 474 #endif
 475 #ifdef MPI
 476       include 'mpif.h'
 477 #endif
 478       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 479      &  glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres)
 480       include 'COMMON.SETUP'
 481       include 'COMMON.IOUNITS'
 482       include 'COMMON.FFIELD'
 483       include 'COMMON.DERIV'
 484       include 'COMMON.INTERACT'
 485       include 'COMMON.SBRIDGE'
 486       include 'COMMON.CHAIN'
 487       include 'COMMON.VAR'
 488       include 'COMMON.CONTROL'
 489       include 'COMMON.TIME1'
 490       include 'COMMON.MAXGRAD'
 491       include 'COMMON.SCCOR'
 492 #ifdef TIMING
 493 #ifdef MPI
 494       time01=MPI_Wtime()
 495 #else
 496       time01=tcpu()
 497 #endif
 498 #endif
 499 #ifdef DEBUG
 500       write (iout,*) "sum_gradient gvdwc, gvdwx"
 501       do i=1,nres
 502         write (iout,'(i3,3f10.5,5x,3f10.5,5x,3f10.5,5x,3f10.5)')
 503      &   i,(gvdwx(j,i),j=1,3),(gvdwcT(j,i),j=1,3),(gvdwc(j,i),j=1,3),
 504      &   (gvdwcT(j,i),j=1,3)
 505       enddo
 506       call flush(iout)
 507 #endif
 508 #ifdef MPI
 509 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 510         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 511      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 512 #endif
 513 C
 514 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 515 C            in virtual-bond-vector coordinates
 516 C
 517 #ifdef DEBUG
 518 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 519 c      do i=1,nres-1
 520 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 521 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 522 c      enddo
 523 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 524 c      do i=1,nres-1
 525 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 526 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 527 c      enddo
 528       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 529       do i=1,nres
 530         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 531      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 532      &   g_corr5_loc(i)
 533       enddo
 534       call flush(iout)
 535 #endif
 536 #ifdef SPLITELE
 537 #ifdef TSCSC
 538       do i=1,nct
 539         do j=1,3
 540           gradbufc(j,i)=wsc*gvdwc(j,i)+wsc*wscT*gvdwcT(j,i)+
 541      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 542      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 543      &                wel_loc*gel_loc_long(j,i)+
 544      &                wcorr*gradcorr_long(j,i)+
 545      &                wcorr5*gradcorr5_long(j,i)+
 546      &                wcorr6*gradcorr6_long(j,i)+
 547      &                wturn6*gcorr6_turn_long(j,i)+
 548      &                wstrain*ghpbc(j,i)
 549         enddo
 550       enddo
 551 #else
 552       do i=1,nct
 553         do j=1,3
 554           gradbufc(j,i)=wsc*gvdwc(j,i)+
 555      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 556      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 557      &                wel_loc*gel_loc_long(j,i)+
 558      &                wcorr*gradcorr_long(j,i)+
 559      &                wcorr5*gradcorr5_long(j,i)+
 560      &                wcorr6*gradcorr6_long(j,i)+
 561      &                wturn6*gcorr6_turn_long(j,i)+
 562      &                wstrain*ghpbc(j,i)
 563         enddo
 564       enddo
 565 #endif
 566 #else
 567       do i=1,nct
 568         do j=1,3
 569           gradbufc(j,i)=wsc*gvdwc(j,i)+
 570      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 571      &                welec*gelc_long(j,i)+
 572      &                wbond*gradb(j,i)+
 573      &                wel_loc*gel_loc_long(j,i)+
 574      &                wcorr*gradcorr_long(j,i)+
 575      &                wcorr5*gradcorr5_long(j,i)+
 576      &                wcorr6*gradcorr6_long(j,i)+
 577      &                wturn6*gcorr6_turn_long(j,i)+
 578      &                wstrain*ghpbc(j,i)
 579         enddo
 580       enddo
 581 #endif
 582 #ifdef MPI
 583       if (nfgtasks.gt.1) then
 584       time00=MPI_Wtime()
 585 #ifdef DEBUG
 586       write (iout,*) "gradbufc before allreduce"
 587       do i=1,nres
 588         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 589       enddo
 590       call flush(iout)
 591 #endif
 592       do i=1,nres
 593         do j=1,3
 594           gradbufc_sum(j,i)=gradbufc(j,i)
 595         enddo
 596       enddo
 597 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 598 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 599 c      time_reduce=time_reduce+MPI_Wtime()-time00
 600 #ifdef DEBUG
 601 c      write (iout,*) "gradbufc_sum after allreduce"
 602 c      do i=1,nres
 603 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 604 c      enddo
 605 c      call flush(iout)
 606 #endif
 607 #ifdef TIMING
 608 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 609 #endif
 610       do i=nnt,nres
 611         do k=1,3
 612           gradbufc(k,i)=0.0d0
 613         enddo
 614       enddo
 615 #ifdef DEBUG
 616       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 617       write (iout,*) (i," jgrad_start",jgrad_start(i),
 618      &                  " jgrad_end  ",jgrad_end(i),
 619      &                  i=igrad_start,igrad_end)
 620 #endif
 621 c
 622 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 623 c do not parallelize this part.
 624 c
 625 c      do i=igrad_start,igrad_end
 626 c        do j=jgrad_start(i),jgrad_end(i)
 627 c          do k=1,3
 628 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 629 c          enddo
 630 c        enddo
 631 c      enddo
 632       do j=1,3
 633         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 634       enddo
 635       do i=nres-2,nnt,-1
 636         do j=1,3
 637           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 638         enddo
 639       enddo
 640 #ifdef DEBUG
 641       write (iout,*) "gradbufc after summing"
 642       do i=1,nres
 643         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 644       enddo
 645       call flush(iout)
 646 #endif
 647       else
 648 #endif
 649 #ifdef DEBUG
 650       write (iout,*) "gradbufc"
 651       do i=1,nres
 652         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 653       enddo
 654       call flush(iout)
 655 #endif
 656       do i=1,nres
 657         do j=1,3
 658           gradbufc_sum(j,i)=gradbufc(j,i)
 659           gradbufc(j,i)=0.0d0
 660         enddo
 661       enddo
 662       do j=1,3
 663         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 664       enddo
 665       do i=nres-2,nnt,-1
 666         do j=1,3
 667           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 668         enddo
 669       enddo
 670 c      do i=nnt,nres-1
 671 c        do k=1,3
 672 c          gradbufc(k,i)=0.0d0
 673 c        enddo
 674 c        do j=i+1,nres
 675 c          do k=1,3
 676 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 677 c          enddo
 678 c        enddo
 679 c      enddo
 680 #ifdef DEBUG
 681       write (iout,*) "gradbufc after summing"
 682       do i=1,nres
 683         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 684       enddo
 685       call flush(iout)
 686 #endif
 687 #ifdef MPI
 688       endif
 689 #endif
 690       do k=1,3
 691         gradbufc(k,nres)=0.0d0
 692       enddo
 693       do i=1,nct
 694         do j=1,3
 695 #ifdef SPLITELE
 696           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 697      &                wel_loc*gel_loc(j,i)+
 698      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 699      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 700      &                wel_loc*gel_loc_long(j,i)+
 701      &                wcorr*gradcorr_long(j,i)+
 702      &                wcorr5*gradcorr5_long(j,i)+
 703      &                wcorr6*gradcorr6_long(j,i)+
 704      &                wturn6*gcorr6_turn_long(j,i))+
 705      &                wbond*gradb(j,i)+
 706      &                wcorr*gradcorr(j,i)+
 707      &                wturn3*gcorr3_turn(j,i)+
 708      &                wturn4*gcorr4_turn(j,i)+
 709      &                wcorr5*gradcorr5(j,i)+
 710      &                wcorr6*gradcorr6(j,i)+
 711      &                wturn6*gcorr6_turn(j,i)+
 712      &                wsccor*gsccorc(j,i)
 713      &               +wscloc*gscloc(j,i)
 714 #else
 715           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 716      &                wel_loc*gel_loc(j,i)+
 717      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 718      &                welec*gelc_long(j,i)+
 719      &                wel_loc*gel_loc_long(j,i)+
 720      &                wcorr*gcorr_long(j,i)+
 721      &                wcorr5*gradcorr5_long(j,i)+
 722      &                wcorr6*gradcorr6_long(j,i)+
 723      &                wturn6*gcorr6_turn_long(j,i))+
 724      &                wbond*gradb(j,i)+
 725      &                wcorr*gradcorr(j,i)+
 726      &                wturn3*gcorr3_turn(j,i)+
 727      &                wturn4*gcorr4_turn(j,i)+
 728      &                wcorr5*gradcorr5(j,i)+
 729      &                wcorr6*gradcorr6(j,i)+
 730      &                wturn6*gcorr6_turn(j,i)+
 731      &                wsccor*gsccorc(j,i)
 732      &               +wscloc*gscloc(j,i)
 733 #endif
 734 #ifdef TSCSC
 735           gradx(j,i,icg)=wsc*gvdwx(j,i)+wsc*wscT*gvdwxT(j,i)+
 736      &                  wscp*gradx_scp(j,i)+
 737      &                  wbond*gradbx(j,i)+
 738      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 739      &                  wsccor*gsccorx(j,i)
 740      &                 +wscloc*gsclocx(j,i)
 741 #else
 742           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 743      &                  wbond*gradbx(j,i)+
 744      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 745      &                  wsccor*gsccorx(j,i)
 746      &                 +wscloc*gsclocx(j,i)
 747 #endif
 748         enddo
 749       enddo
 750 #ifdef DEBUG
 751       write (iout,*) "gloc before adding corr"
 752       do i=1,4*nres
 753         write (iout,*) i,gloc(i,icg)
 754       enddo
 755 #endif
 756       do i=1,nres-3
 757         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 758      &   +wcorr5*g_corr5_loc(i)
 759      &   +wcorr6*g_corr6_loc(i)
 760      &   +wturn4*gel_loc_turn4(i)
 761      &   +wturn3*gel_loc_turn3(i)
 762      &   +wturn6*gel_loc_turn6(i)
 763      &   +wel_loc*gel_loc_loc(i)
 764       enddo
 765 #ifdef DEBUG
 766       write (iout,*) "gloc after adding corr"
 767       do i=1,4*nres
 768         write (iout,*) i,gloc(i,icg)
 769       enddo
 770 #endif
 771 #ifdef MPI
 772       if (nfgtasks.gt.1) then
 773         do j=1,3
 774           do i=1,nres
 775             gradbufc(j,i)=gradc(j,i,icg)
 776             gradbufx(j,i)=gradx(j,i,icg)
 777           enddo
 778         enddo
 779         do i=1,4*nres
 780           glocbuf(i)=gloc(i,icg)
 781         enddo
 782 #ifdef DEBUG
 783       write (iout,*) "gloc_sc before reduce"
 784       do i=1,nres
 785        do j=1,3
 786         write (iout,*) i,j,gloc_sc(j,i,icg)
 787        enddo
 788       enddo
 789 #endif
 790         do i=1,nres
 791          do j=1,3
 792           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 793          enddo
 794         enddo
 795         time00=MPI_Wtime()
 796         call MPI_Barrier(FG_COMM,IERR)
 797         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 798         time00=MPI_Wtime()
 799         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 800      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 801         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 802      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 803         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 804      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 805         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 806      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 807         time_reduce=time_reduce+MPI_Wtime()-time00
 808 #ifdef DEBUG
 809       write (iout,*) "gloc_sc after reduce"
 810       do i=1,nres
 811        do j=1,3
 812         write (iout,*) i,j,gloc_sc(j,i,icg)
 813        enddo
 814       enddo
 815 #endif
 816 #ifdef DEBUG
 817       write (iout,*) "gloc after reduce"
 818       do i=1,4*nres
 819         write (iout,*) i,gloc(i,icg)
 820       enddo
 821 #endif
 822       endif
 823 #endif
 824       if (gnorm_check) then
 825 c
 826 c Compute the maximum elements of the gradient
 827 c
 828       gvdwc_max=0.0d0
 829       gvdwc_scp_max=0.0d0
 830       gelc_max=0.0d0
 831       gvdwpp_max=0.0d0
 832       gradb_max=0.0d0
 833       ghpbc_max=0.0d0
 834       gradcorr_max=0.0d0
 835       gel_loc_max=0.0d0
 836       gcorr3_turn_max=0.0d0
 837       gcorr4_turn_max=0.0d0
 838       gradcorr5_max=0.0d0
 839       gradcorr6_max=0.0d0
 840       gcorr6_turn_max=0.0d0
 841       gsccorc_max=0.0d0
 842       gscloc_max=0.0d0
 843       gvdwx_max=0.0d0
 844       gradx_scp_max=0.0d0
 845       ghpbx_max=0.0d0
 846       gradxorr_max=0.0d0
 847       gsccorx_max=0.0d0
 848       gsclocx_max=0.0d0
 849       do i=1,nct
 850         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 851         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 852 #ifdef TSCSC
 853         gvdwc_norm=dsqrt(scalar(gvdwcT(1,i),gvdwcT(1,i)))
 854         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 855 #endif
 856         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 857         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 858      &   gvdwc_scp_max=gvdwc_scp_norm
 859         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 860         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 861         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 862         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 863         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 864         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 865         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 866         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 867         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 868         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 869         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 870         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 871         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 872      &    gcorr3_turn(1,i)))
 873         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 874      &    gcorr3_turn_max=gcorr3_turn_norm
 875         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 876      &    gcorr4_turn(1,i)))
 877         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 878      &    gcorr4_turn_max=gcorr4_turn_norm
 879         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 880         if (gradcorr5_norm.gt.gradcorr5_max)
 881      &    gradcorr5_max=gradcorr5_norm
 882         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 883         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 884         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 885      &    gcorr6_turn(1,i)))
 886         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 887      &    gcorr6_turn_max=gcorr6_turn_norm
 888         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 889         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 890         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 891         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 892         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 893         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 894 #ifdef TSCSC
 895         gvdwx_norm=dsqrt(scalar(gvdwxT(1,i),gvdwxT(1,i)))
 896         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 897 #endif
 898         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 899         if (gradx_scp_norm.gt.gradx_scp_max)
 900      &    gradx_scp_max=gradx_scp_norm
 901         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 902         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 903         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 904         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 905         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 906         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 907         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 908         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 909       enddo
 910       if (gradout) then
 911 #ifdef AIX
 912         open(istat,file=statname,position="append")
 913 #else
 914         open(istat,file=statname,access="append")
 915 #endif
 916         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 917      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 918      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 919      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 920      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 921      &     gsccorx_max,gsclocx_max
 922         close(istat)
 923         if (gvdwc_max.gt.1.0d4) then
 924           write (iout,*) "gvdwc gvdwx gradb gradbx"
 925           do i=nnt,nct
 926             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 927      &        gradb(j,i),gradbx(j,i),j=1,3)
 928           enddo
 929           call pdbout(0.0d0,'cipiszcze',iout)
 930           call flush(iout)
 931         endif
 932       endif
 933       endif
 934 #ifdef DEBUG
 935       write (iout,*) "gradc gradx gloc"
 936       do i=1,nres
 937         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 938      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 939       enddo
 940 #endif
 941 #ifdef TIMING
 942 #ifdef MPI
 943       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 944 #else
 945       time_sumgradient=time_sumgradient+tcpu()-time01
 946 #endif
 947 #endif
 948       return
 949       end
 950 c-------------------------------------------------------------------------------
 951       subroutine rescale_weights(t_bath)
 952       implicit real*8 (a-h,o-z)
 953       include 'DIMENSIONS'
 954       include 'COMMON.IOUNITS'
 955       include 'COMMON.FFIELD'
 956       include 'COMMON.SBRIDGE'
 957       double precision kfac /2.4d0/
 958       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 959 c      facT=temp0/t_bath
 960 c      facT=2*temp0/(t_bath+temp0)
 961       if (rescale_mode.eq.0) then
 962         facT=1.0d0
 963         facT2=1.0d0
 964         facT3=1.0d0
 965         facT4=1.0d0
 966         facT5=1.0d0
 967       else if (rescale_mode.eq.1) then
 968         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 969         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 970         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 971         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 972         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 973       else if (rescale_mode.eq.2) then
 974         x=t_bath/temp0
 975         x2=x*x
 976         x3=x2*x
 977         x4=x3*x
 978         x5=x4*x
 979         facT=licznik/dlog(dexp(x)+dexp(-x))
 980         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 981         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 982         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 983         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 984       else
 985         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 986         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 987 #ifdef MPI
 988        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 989 #endif
 990        stop 555
 991       endif
 992       welec=weights(3)*fact
 993       wcorr=weights(4)*fact3
 994       wcorr5=weights(5)*fact4
 995       wcorr6=weights(6)*fact5
 996       wel_loc=weights(7)*fact2
 997       wturn3=weights(8)*fact2
 998       wturn4=weights(9)*fact3
 999       wturn6=weights(10)*fact5
1000       wtor=weights(13)*fact
1001       wtor_d=weights(14)*fact2
1002       wsccor=weights(21)*fact
1003 #ifdef TSCSC
1004 c      wsct=t_bath/temp0
1005       wsct=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
1006 #endif
1007       return
1008       end
1009 C------------------------------------------------------------------------
1010       subroutine enerprint(energia)
1011       implicit real*8 (a-h,o-z)
1012       include 'DIMENSIONS'
1013       include 'COMMON.IOUNITS'
1014       include 'COMMON.FFIELD'
1015       include 'COMMON.SBRIDGE'
1016       include 'COMMON.MD'
1017       double precision energia(0:n_ene)
1018       etot=energia(0)
1019 #ifdef TSCSC
1020       evdw=energia(22)+wsct*energia(23)
1021 #else
1022       evdw=energia(1)
1023 #endif
1024       evdw2=energia(2)
1025 #ifdef SCP14
1026       evdw2=energia(2)+energia(18)
1027 #else
1028       evdw2=energia(2)
1029 #endif
1030       ees=energia(3)
1031 #ifdef SPLITELE
1032       evdw1=energia(16)
1033 #endif
1034       ecorr=energia(4)
1035       ecorr5=energia(5)
1036       ecorr6=energia(6)
1037       eel_loc=energia(7)
1038       eello_turn3=energia(8)
1039       eello_turn4=energia(9)
1040       eello_turn6=energia(10)
1041       ebe=energia(11)
1042       escloc=energia(12)
1043       etors=energia(13)
1044       etors_d=energia(14)
1045       ehpb=energia(15)
1046       edihcnstr=energia(19)
1047       estr=energia(17)
1048       Uconst=energia(20)
1049       esccor=energia(21)
1050 #ifdef SPLITELE
1051       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1052      &  estr,wbond,ebe,wang,
1053      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1054      &  ecorr,wcorr,
1055      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1056      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
1057      &  edihcnstr,ebr*nss,
1058      &  Uconst,etot
1059    10 format (/'Virtual-chain energies:'//
1060      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
1061      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
1062      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
1063      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pE16.6,' (p-p VDW)'/
1064      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
1065      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
1066      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
1067      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
1068      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
1069      & 'EHPB=  ',1pE16.6,' WEIGHT=',1pE16.6,
1070      & ' (SS bridges & dist. cnstr.)'/
1071      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1072      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1073      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1074      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
1075      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
1076      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
1077      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
1078      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
1079      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1080      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1081      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1082      & 'ETOT=  ',1pE16.6,' (total)')
1083 #else
1084       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1085      &  estr,wbond,ebe,wang,
1086      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1087      &  ecorr,wcorr,
1088      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1089      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1090      &  ebr*nss,Uconst,etot
1091    10 format (/'Virtual-chain energies:'//
1092      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1093      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1094      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1095      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1096      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1097      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1098      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1099      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1100      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1101      & ' (SS bridges & dist. cnstr.)'/
1102      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1103      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1104      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1105      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1106      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1107      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1108      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1109      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1110      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1111      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1112      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1113      & 'ETOT=  ',1pE16.6,' (total)')
1114 #endif
1115       return
1116       end
1117 C-----------------------------------------------------------------------
1118       subroutine elj(evdw,evdw_p,evdw_m)
1119 C
1120 C This subroutine calculates the interaction energy of nonbonded side chains
1121 C assuming the LJ potential of interaction.
1122 C
1123       implicit real*8 (a-h,o-z)
1124       include 'DIMENSIONS'
1125       parameter (accur=1.0d-10)
1126       include 'COMMON.GEO'
1127       include 'COMMON.VAR'
1128       include 'COMMON.LOCAL'
1129       include 'COMMON.CHAIN'
1130       include 'COMMON.DERIV'
1131       include 'COMMON.INTERACT'
1132       include 'COMMON.TORSION'
1133       include 'COMMON.SBRIDGE'
1134       include 'COMMON.NAMES'
1135       include 'COMMON.IOUNITS'
1136       include 'COMMON.CONTACTS'
1137       dimension gg(3)
1138 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1139       evdw=0.0D0
1140       do i=iatsc_s,iatsc_e
1141         itypi=itype(i)
1142         itypi1=itype(i+1)
1143         xi=c(1,nres+i)
1144         yi=c(2,nres+i)
1145         zi=c(3,nres+i)
1146 C Change 12/1/95
1147         num_conti=0
1148 C
1149 C Calculate SC interaction energy.
1150 C
1151         do iint=1,nint_gr(i)
1152 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1153 cd   &                  'iend=',iend(i,iint)
1154           do j=istart(i,iint),iend(i,iint)
1155             itypj=itype(j)
1156             xj=c(1,nres+j)-xi
1157             yj=c(2,nres+j)-yi
1158             zj=c(3,nres+j)-zi
1159 C Change 12/1/95 to calculate four-body interactions
1160             rij=xj*xj+yj*yj+zj*zj
1161             rrij=1.0D0/rij
1162 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1163             eps0ij=eps(itypi,itypj)
1164             fac=rrij**expon2
1165             e1=fac*fac*aa(itypi,itypj)
1166             e2=fac*bb(itypi,itypj)
1167             evdwij=e1+e2
1168 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1169 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1170 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1171 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1172 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1173 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1174 #ifdef TSCSC
1175             if (bb(itypi,itypj).gt.0) then
1176                evdw_p=evdw_p+evdwij
1177             else
1178                evdw_m=evdw_m+evdwij
1179             endif
1180 #else
1181             evdw=evdw+evdwij
1182 #endif
1183 C
1184 C Calculate the components of the gradient in DC and X
1185 C
1186             fac=-rrij*(e1+evdwij)
1187             gg(1)=xj*fac
1188             gg(2)=yj*fac
1189             gg(3)=zj*fac
1190 #ifdef TSCSC
1191             if (bb(itypi,itypj).gt.0.0d0) then
1192               do k=1,3
1193                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1194                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1195                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1196                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1197               enddo
1198             else
1199               do k=1,3
1200                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1201                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1202                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1203                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1204               enddo
1205             endif
1206 #else
1207             do k=1,3
1208               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1209               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1210               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1211               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1212             enddo
1213 #endif
1214 cgrad            do k=i,j-1
1215 cgrad              do l=1,3
1216 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1217 cgrad              enddo
1218 cgrad            enddo
1219 C
1220 C 12/1/95, revised on 5/20/97
1221 C
1222 C Calculate the contact function. The ith column of the array JCONT will
1223 C contain the numbers of atoms that make contacts with the atom I (of numbers
1224 C greater than I). The arrays FACONT and GACONT will contain the values of
1225 C the contact function and its derivative.
1226 C
1227 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1228 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1229 C Uncomment next line, if the correlation interactions are contact function only
1230             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1231               rij=dsqrt(rij)
1232               sigij=sigma(itypi,itypj)
1233               r0ij=rs0(itypi,itypj)
1234 C
1235 C Check whether the SC's are not too far to make a contact.
1236 C
1237               rcut=1.5d0*r0ij
1238               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1239 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1240 C
1241               if (fcont.gt.0.0D0) then
1242 C If the SC-SC distance if close to sigma, apply spline.
1243 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1244 cAdam &             fcont1,fprimcont1)
1245 cAdam           fcont1=1.0d0-fcont1
1246 cAdam           if (fcont1.gt.0.0d0) then
1247 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1248 cAdam             fcont=fcont*fcont1
1249 cAdam           endif
1250 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1251 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1252 cga             do k=1,3
1253 cga               gg(k)=gg(k)*eps0ij
1254 cga             enddo
1255 cga             eps0ij=-evdwij*eps0ij
1256 C Uncomment for AL's type of SC correlation interactions.
1257 cadam           eps0ij=-evdwij
1258                 num_conti=num_conti+1
1259                 jcont(num_conti,i)=j
1260                 facont(num_conti,i)=fcont*eps0ij
1261                 fprimcont=eps0ij*fprimcont/rij
1262                 fcont=expon*fcont
1263 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1264 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1265 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1266 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1267                 gacont(1,num_conti,i)=-fprimcont*xj
1268                 gacont(2,num_conti,i)=-fprimcont*yj
1269                 gacont(3,num_conti,i)=-fprimcont*zj
1270 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1271 cd              write (iout,'(2i3,3f10.5)')
1272 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1273               endif
1274             endif
1275           enddo      ! j
1276         enddo        ! iint
1277 C Change 12/1/95
1278         num_cont(i)=num_conti
1279       enddo          ! i
1280       do i=1,nct
1281         do j=1,3
1282           gvdwc(j,i)=expon*gvdwc(j,i)
1283           gvdwx(j,i)=expon*gvdwx(j,i)
1284         enddo
1285       enddo
1286 C******************************************************************************
1287 C
1288 C                              N O T E !!!
1289 C
1290 C To save time, the factor of EXPON has been extracted from ALL components
1291 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1292 C use!
1293 C
1294 C******************************************************************************
1295       return
1296       end
1297 C-----------------------------------------------------------------------------
1298       subroutine eljk(evdw,evdw_p,evdw_m)
1299 C
1300 C This subroutine calculates the interaction energy of nonbonded side chains
1301 C assuming the LJK potential of interaction.
1302 C
1303       implicit real*8 (a-h,o-z)
1304       include 'DIMENSIONS'
1305       include 'COMMON.GEO'
1306       include 'COMMON.VAR'
1307       include 'COMMON.LOCAL'
1308       include 'COMMON.CHAIN'
1309       include 'COMMON.DERIV'
1310       include 'COMMON.INTERACT'
1311       include 'COMMON.IOUNITS'
1312       include 'COMMON.NAMES'
1313       dimension gg(3)
1314       logical scheck
1315 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1316       evdw=0.0D0
1317       do i=iatsc_s,iatsc_e
1318         itypi=itype(i)
1319         itypi1=itype(i+1)
1320         xi=c(1,nres+i)
1321         yi=c(2,nres+i)
1322         zi=c(3,nres+i)
1323 C
1324 C Calculate SC interaction energy.
1325 C
1326         do iint=1,nint_gr(i)
1327           do j=istart(i,iint),iend(i,iint)
1328             itypj=itype(j)
1329             xj=c(1,nres+j)-xi
1330             yj=c(2,nres+j)-yi
1331             zj=c(3,nres+j)-zi
1332             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1333             fac_augm=rrij**expon
1334             e_augm=augm(itypi,itypj)*fac_augm
1335             r_inv_ij=dsqrt(rrij)
1336             rij=1.0D0/r_inv_ij
1337             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1338             fac=r_shift_inv**expon
1339             e1=fac*fac*aa(itypi,itypj)
1340             e2=fac*bb(itypi,itypj)
1341             evdwij=e_augm+e1+e2
1342 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1343 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1344 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1345 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1346 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1347 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1348 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1349 #ifdef TSCSC
1350             if (bb(itypi,itypj).gt.0) then
1351                evdw_p=evdw_p+evdwij
1352             else
1353                evdw_m=evdw_m+evdwij
1354             endif
1355 #else
1356             evdw=evdw+evdwij
1357 #endif
1358 C
1359 C Calculate the components of the gradient in DC and X
1360 C
1361             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1362             gg(1)=xj*fac
1363             gg(2)=yj*fac
1364             gg(3)=zj*fac
1365 #ifdef TSCSC
1366             if (bb(itypi,itypj).gt.0.0d0) then
1367               do k=1,3
1368                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1369                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1370                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1371                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1372               enddo
1373             else
1374               do k=1,3
1375                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1376                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1377                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1378                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1379               enddo
1380             endif
1381 #else
1382             do k=1,3
1383               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1384               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1385               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1386               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1387             enddo
1388 #endif
1389 cgrad            do k=i,j-1
1390 cgrad              do l=1,3
1391 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1392 cgrad              enddo
1393 cgrad            enddo
1394           enddo      ! j
1395         enddo        ! iint
1396       enddo          ! i
1397       do i=1,nct
1398         do j=1,3
1399           gvdwc(j,i)=expon*gvdwc(j,i)
1400           gvdwx(j,i)=expon*gvdwx(j,i)
1401         enddo
1402       enddo
1403       return
1404       end
1405 C-----------------------------------------------------------------------------
1406       subroutine ebp(evdw,evdw_p,evdw_m)
1407 C
1408 C This subroutine calculates the interaction energy of nonbonded side chains
1409 C assuming the Berne-Pechukas potential of interaction.
1410 C
1411       implicit real*8 (a-h,o-z)
1412       include 'DIMENSIONS'
1413       include 'COMMON.GEO'
1414       include 'COMMON.VAR'
1415       include 'COMMON.LOCAL'
1416       include 'COMMON.CHAIN'
1417       include 'COMMON.DERIV'
1418       include 'COMMON.NAMES'
1419       include 'COMMON.INTERACT'
1420       include 'COMMON.IOUNITS'
1421       include 'COMMON.CALC'
1422       common /srutu/ icall
1423 c     double precision rrsave(maxdim)
1424       logical lprn
1425       evdw=0.0D0
1426 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1427       evdw=0.0D0
1428 c     if (icall.eq.0) then
1429 c       lprn=.true.
1430 c     else
1431         lprn=.false.
1432 c     endif
1433       ind=0
1434       do i=iatsc_s,iatsc_e
1435         itypi=itype(i)
1436         itypi1=itype(i+1)
1437         xi=c(1,nres+i)
1438         yi=c(2,nres+i)
1439         zi=c(3,nres+i)
1440         dxi=dc_norm(1,nres+i)
1441         dyi=dc_norm(2,nres+i)
1442         dzi=dc_norm(3,nres+i)
1443 c        dsci_inv=dsc_inv(itypi)
1444         dsci_inv=vbld_inv(i+nres)
1445 C
1446 C Calculate SC interaction energy.
1447 C
1448         do iint=1,nint_gr(i)
1449           do j=istart(i,iint),iend(i,iint)
1450             ind=ind+1
1451             itypj=itype(j)
1452 c            dscj_inv=dsc_inv(itypj)
1453             dscj_inv=vbld_inv(j+nres)
1454             chi1=chi(itypi,itypj)
1455             chi2=chi(itypj,itypi)
1456             chi12=chi1*chi2
1457             chip1=chip(itypi)
1458             chip2=chip(itypj)
1459             chip12=chip1*chip2
1460             alf1=alp(itypi)
1461             alf2=alp(itypj)
1462             alf12=0.5D0*(alf1+alf2)
1463 C For diagnostics only!!!
1464 c           chi1=0.0D0
1465 c           chi2=0.0D0
1466 c           chi12=0.0D0
1467 c           chip1=0.0D0
1468 c           chip2=0.0D0
1469 c           chip12=0.0D0
1470 c           alf1=0.0D0
1471 c           alf2=0.0D0
1472 c           alf12=0.0D0
1473             xj=c(1,nres+j)-xi
1474             yj=c(2,nres+j)-yi
1475             zj=c(3,nres+j)-zi
1476             dxj=dc_norm(1,nres+j)
1477             dyj=dc_norm(2,nres+j)
1478             dzj=dc_norm(3,nres+j)
1479             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1480 cd          if (icall.eq.0) then
1481 cd            rrsave(ind)=rrij
1482 cd          else
1483 cd            rrij=rrsave(ind)
1484 cd          endif
1485             rij=dsqrt(rrij)
1486 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1487             call sc_angular
1488 C Calculate whole angle-dependent part of epsilon and contributions
1489 C to its derivatives
1490             fac=(rrij*sigsq)**expon2
1491             e1=fac*fac*aa(itypi,itypj)
1492             e2=fac*bb(itypi,itypj)
1493             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1494             eps2der=evdwij*eps3rt
1495             eps3der=evdwij*eps2rt
1496             evdwij=evdwij*eps2rt*eps3rt
1497 #ifdef TSCSC
1498             if (bb(itypi,itypj).gt.0) then
1499                evdw_p=evdw_p+evdwij
1500             else
1501                evdw_m=evdw_m+evdwij
1502             endif
1503 #else
1504             evdw=evdw+evdwij
1505 #endif
1506             if (lprn) then
1507             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1508             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1509 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1510 cd     &        restyp(itypi),i,restyp(itypj),j,
1511 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1512 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1513 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1514 cd     &        evdwij
1515             endif
1516 C Calculate gradient components.
1517             e1=e1*eps1*eps2rt**2*eps3rt**2
1518             fac=-expon*(e1+evdwij)
1519             sigder=fac/sigsq
1520             fac=rrij*fac
1521 C Calculate radial part of the gradient
1522             gg(1)=xj*fac
1523             gg(2)=yj*fac
1524             gg(3)=zj*fac
1525 C Calculate the angular part of the gradient and sum add the contributions
1526 C to the appropriate components of the Cartesian gradient.
1527 #ifdef TSCSC
1528             if (bb(itypi,itypj).gt.0) then
1529                call sc_grad
1530             else
1531                call sc_grad_T
1532             endif
1533 #else
1534             call sc_grad
1535 #endif
1536           enddo      ! j
1537         enddo        ! iint
1538       enddo          ! i
1539 c     stop
1540       return
1541       end
1542 C-----------------------------------------------------------------------------
1543       subroutine egb(evdw,evdw_p,evdw_m)
1544 C
1545 C This subroutine calculates the interaction energy of nonbonded side chains
1546 C assuming the Gay-Berne potential of interaction.
1547 C
1548       implicit real*8 (a-h,o-z)
1549       include 'DIMENSIONS'
1550       include 'COMMON.GEO'
1551       include 'COMMON.VAR'
1552       include 'COMMON.LOCAL'
1553       include 'COMMON.CHAIN'
1554       include 'COMMON.DERIV'
1555       include 'COMMON.NAMES'
1556       include 'COMMON.INTERACT'
1557       include 'COMMON.IOUNITS'
1558       include 'COMMON.CALC'
1559       include 'COMMON.CONTROL'
1560       include 'COMMON.SBRIDGE'
1561       logical lprn
1562       evdw=0.0D0
1563 ccccc      energy_dec=.false.
1564 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1565       evdw=0.0D0
1566       evdw_p=0.0D0
1567       evdw_m=0.0D0
1568       lprn=.false.
1569 c     if (icall.eq.0) lprn=.false.
1570       ind=0
1571       do i=iatsc_s,iatsc_e
1572         itypi=itype(i)
1573         itypi1=itype(i+1)
1574         xi=c(1,nres+i)
1575         yi=c(2,nres+i)
1576         zi=c(3,nres+i)
1577         dxi=dc_norm(1,nres+i)
1578         dyi=dc_norm(2,nres+i)
1579         dzi=dc_norm(3,nres+i)
1580 c        dsci_inv=dsc_inv(itypi)
1581         dsci_inv=vbld_inv(i+nres)
1582 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1583 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1584 C
1585 C Calculate SC interaction energy.
1586 C
1587         do iint=1,nint_gr(i)
1588           do j=istart(i,iint),iend(i,iint)
1589             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1590               call dyn_ssbond_ene(i,j,evdwij)
1591               evdw=evdw+evdwij
1592               write(iout,*) 'dyn_ssbond_ene ',evdwij
1593             ELSE
1594             ind=ind+1
1595             itypj=itype(j)
1596 c            dscj_inv=dsc_inv(itypj)
1597             dscj_inv=vbld_inv(j+nres)
1598 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1599 c     &       1.0d0/vbld(j+nres)
1600 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1601             sig0ij=sigma(itypi,itypj)
1602             chi1=chi(itypi,itypj)
1603             chi2=chi(itypj,itypi)
1604             chi12=chi1*chi2
1605             chip1=chip(itypi)
1606             chip2=chip(itypj)
1607             chip12=chip1*chip2
1608             alf1=alp(itypi)
1609             alf2=alp(itypj)
1610             alf12=0.5D0*(alf1+alf2)
1611 C For diagnostics only!!!
1612 c           chi1=0.0D0
1613 c           chi2=0.0D0
1614 c           chi12=0.0D0
1615 c           chip1=0.0D0
1616 c           chip2=0.0D0
1617 c           chip12=0.0D0
1618 c           alf1=0.0D0
1619 c           alf2=0.0D0
1620 c           alf12=0.0D0
1621             xj=c(1,nres+j)-xi
1622             yj=c(2,nres+j)-yi
1623             zj=c(3,nres+j)-zi
1624             dxj=dc_norm(1,nres+j)
1625             dyj=dc_norm(2,nres+j)
1626             dzj=dc_norm(3,nres+j)
1627 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1628 c            write (iout,*) "j",j," dc_norm",
1629 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1630             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1631             rij=dsqrt(rrij)
1632 C Calculate angle-dependent terms of energy and contributions to their
1633 C derivatives.
1634             call sc_angular
1635             sigsq=1.0D0/sigsq
1636             sig=sig0ij*dsqrt(sigsq)
1637             rij_shift=1.0D0/rij-sig+sig0ij
1638 c for diagnostics; uncomment
1639 c            rij_shift=1.2*sig0ij
1640 C I hate to put IF's in the loops, but here don't have another choice!!!!
1641             if (rij_shift.le.0.0D0) then
1642               evdw=1.0D20
1643 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1644 cd     &        restyp(itypi),i,restyp(itypj),j,
1645 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1646               return
1647             endif
1648             sigder=-sig*sigsq
1649 c---------------------------------------------------------------
1650             rij_shift=1.0D0/rij_shift
1651             fac=rij_shift**expon
1652             e1=fac*fac*aa(itypi,itypj)
1653             e2=fac*bb(itypi,itypj)
1654             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1655             eps2der=evdwij*eps3rt
1656             eps3der=evdwij*eps2rt
1657 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1658 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1659             evdwij=evdwij*eps2rt*eps3rt
1660 #ifdef TSCSC
1661             if (bb(itypi,itypj).gt.0) then
1662                evdw_p=evdw_p+evdwij
1663             else
1664                evdw_m=evdw_m+evdwij
1665             endif
1666 #else
1667             evdw=evdw+evdwij
1668 #endif
1669             if (lprn) then
1670             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1671             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1672             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1673      &        restyp(itypi),i,restyp(itypj),j,
1674      &        epsi,sigm,chi1,chi2,chip1,chip2,
1675      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1676      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1677      &        evdwij
1678             endif
1679
1680             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1681      &                        'evdw',i,j,evdwij
1682
1683 C Calculate gradient components.
1684             e1=e1*eps1*eps2rt**2*eps3rt**2
1685             fac=-expon*(e1+evdwij)*rij_shift
1686             sigder=fac*sigder
1687             fac=rij*fac
1688 c            fac=0.0d0
1689 C Calculate the radial part of the gradient
1690             gg(1)=xj*fac
1691             gg(2)=yj*fac
1692             gg(3)=zj*fac
1693 C Calculate angular part of the gradient.
1694 #ifdef TSCSC
1695             if (bb(itypi,itypj).gt.0) then
1696                call sc_grad
1697             else
1698                call sc_grad_T
1699             endif
1700 #else
1701             call sc_grad
1702 #endif
1703             ENDIF    ! dyn_ss
1704           enddo      ! j
1705         enddo        ! iint
1706       enddo          ! i
1707 c      write (iout,*) "Number of loop steps in EGB:",ind
1708 cccc      energy_dec=.false.
1709       return
1710       end
1711 C-----------------------------------------------------------------------------
1712       subroutine egbv(evdw,evdw_p,evdw_m)
1713 C
1714 C This subroutine calculates the interaction energy of nonbonded side chains
1715 C assuming the Gay-Berne-Vorobjev potential of interaction.
1716 C
1717       implicit real*8 (a-h,o-z)
1718       include 'DIMENSIONS'
1719       include 'COMMON.GEO'
1720       include 'COMMON.VAR'
1721       include 'COMMON.LOCAL'
1722       include 'COMMON.CHAIN'
1723       include 'COMMON.DERIV'
1724       include 'COMMON.NAMES'
1725       include 'COMMON.INTERACT'
1726       include 'COMMON.IOUNITS'
1727       include 'COMMON.CALC'
1728       common /srutu/ icall
1729       logical lprn
1730       evdw=0.0D0
1731 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1732       evdw=0.0D0
1733       lprn=.false.
1734 c     if (icall.eq.0) lprn=.true.
1735       ind=0
1736       do i=iatsc_s,iatsc_e
1737         itypi=itype(i)
1738         itypi1=itype(i+1)
1739         xi=c(1,nres+i)
1740         yi=c(2,nres+i)
1741         zi=c(3,nres+i)
1742         dxi=dc_norm(1,nres+i)
1743         dyi=dc_norm(2,nres+i)
1744         dzi=dc_norm(3,nres+i)
1745 c        dsci_inv=dsc_inv(itypi)
1746         dsci_inv=vbld_inv(i+nres)
1747 C
1748 C Calculate SC interaction energy.
1749 C
1750         do iint=1,nint_gr(i)
1751           do j=istart(i,iint),iend(i,iint)
1752             ind=ind+1
1753             itypj=itype(j)
1754 c            dscj_inv=dsc_inv(itypj)
1755             dscj_inv=vbld_inv(j+nres)
1756             sig0ij=sigma(itypi,itypj)
1757             r0ij=r0(itypi,itypj)
1758             chi1=chi(itypi,itypj)
1759             chi2=chi(itypj,itypi)
1760             chi12=chi1*chi2
1761             chip1=chip(itypi)
1762             chip2=chip(itypj)
1763             chip12=chip1*chip2
1764             alf1=alp(itypi)
1765             alf2=alp(itypj)
1766             alf12=0.5D0*(alf1+alf2)
1767 C For diagnostics only!!!
1768 c           chi1=0.0D0
1769 c           chi2=0.0D0
1770 c           chi12=0.0D0
1771 c           chip1=0.0D0
1772 c           chip2=0.0D0
1773 c           chip12=0.0D0
1774 c           alf1=0.0D0
1775 c           alf2=0.0D0
1776 c           alf12=0.0D0
1777             xj=c(1,nres+j)-xi
1778             yj=c(2,nres+j)-yi
1779             zj=c(3,nres+j)-zi
1780             dxj=dc_norm(1,nres+j)
1781             dyj=dc_norm(2,nres+j)
1782             dzj=dc_norm(3,nres+j)
1783             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1784             rij=dsqrt(rrij)
1785 C Calculate angle-dependent terms of energy and contributions to their
1786 C derivatives.
1787             call sc_angular
1788             sigsq=1.0D0/sigsq
1789             sig=sig0ij*dsqrt(sigsq)
1790             rij_shift=1.0D0/rij-sig+r0ij
1791 C I hate to put IF's in the loops, but here don't have another choice!!!!
1792             if (rij_shift.le.0.0D0) then
1793               evdw=1.0D20
1794               return
1795             endif
1796             sigder=-sig*sigsq
1797 c---------------------------------------------------------------
1798             rij_shift=1.0D0/rij_shift
1799             fac=rij_shift**expon
1800             e1=fac*fac*aa(itypi,itypj)
1801             e2=fac*bb(itypi,itypj)
1802             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1803             eps2der=evdwij*eps3rt
1804             eps3der=evdwij*eps2rt
1805             fac_augm=rrij**expon
1806             e_augm=augm(itypi,itypj)*fac_augm
1807             evdwij=evdwij*eps2rt*eps3rt
1808 #ifdef TSCSC
1809             if (bb(itypi,itypj).gt.0) then
1810                evdw_p=evdw_p+evdwij+e_augm
1811             else
1812                evdw_m=evdw_m+evdwij+e_augm
1813             endif
1814 #else
1815             evdw=evdw+evdwij+e_augm
1816 #endif
1817             if (lprn) then
1818             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1819             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1820             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1821      &        restyp(itypi),i,restyp(itypj),j,
1822      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1823      &        chi1,chi2,chip1,chip2,
1824      &        eps1,eps2rt**2,eps3rt**2,
1825      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1826      &        evdwij+e_augm
1827             endif
1828 C Calculate gradient components.
1829             e1=e1*eps1*eps2rt**2*eps3rt**2
1830             fac=-expon*(e1+evdwij)*rij_shift
1831             sigder=fac*sigder
1832             fac=rij*fac-2*expon*rrij*e_augm
1833 C Calculate the radial part of the gradient
1834             gg(1)=xj*fac
1835             gg(2)=yj*fac
1836             gg(3)=zj*fac
1837 C Calculate angular part of the gradient.
1838 #ifdef TSCSC
1839             if (bb(itypi,itypj).gt.0) then
1840                call sc_grad
1841             else
1842                call sc_grad_T
1843             endif
1844 #else
1845             call sc_grad
1846 #endif
1847           enddo      ! j
1848         enddo        ! iint
1849       enddo          ! i
1850       end
1851 C-----------------------------------------------------------------------------
1852       subroutine sc_angular
1853 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1854 C om12. Called by ebp, egb, and egbv.
1855       implicit none
1856       include 'COMMON.CALC'
1857       include 'COMMON.IOUNITS'
1858       erij(1)=xj*rij
1859       erij(2)=yj*rij
1860       erij(3)=zj*rij
1861       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1862       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1863       om12=dxi*dxj+dyi*dyj+dzi*dzj
1864       chiom12=chi12*om12
1865 C Calculate eps1(om12) and its derivative in om12
1866       faceps1=1.0D0-om12*chiom12
1867       faceps1_inv=1.0D0/faceps1
1868       eps1=dsqrt(faceps1_inv)
1869 C Following variable is eps1*deps1/dom12
1870       eps1_om12=faceps1_inv*chiom12
1871 c diagnostics only
1872 c      faceps1_inv=om12
1873 c      eps1=om12
1874 c      eps1_om12=1.0d0
1875 c      write (iout,*) "om12",om12," eps1",eps1
1876 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1877 C and om12.
1878       om1om2=om1*om2
1879       chiom1=chi1*om1
1880       chiom2=chi2*om2
1881       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1882       sigsq=1.0D0-facsig*faceps1_inv
1883       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1884       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1885       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1886 c diagnostics only
1887 c      sigsq=1.0d0
1888 c      sigsq_om1=0.0d0
1889 c      sigsq_om2=0.0d0
1890 c      sigsq_om12=0.0d0
1891 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1892 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1893 c     &    " eps1",eps1
1894 C Calculate eps2 and its derivatives in om1, om2, and om12.
1895       chipom1=chip1*om1
1896       chipom2=chip2*om2
1897       chipom12=chip12*om12
1898       facp=1.0D0-om12*chipom12
1899       facp_inv=1.0D0/facp
1900       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1901 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1902 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1903 C Following variable is the square root of eps2
1904       eps2rt=1.0D0-facp1*facp_inv
1905 C Following three variables are the derivatives of the square root of eps
1906 C in om1, om2, and om12.
1907       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1908       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1909       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1910 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1911       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1912 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1913 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1914 c     &  " eps2rt_om12",eps2rt_om12
1915 C Calculate whole angle-dependent part of epsilon and contributions
1916 C to its derivatives
1917       return
1918       end
1919
1920 C----------------------------------------------------------------------------
1921       subroutine sc_grad_T
1922       implicit real*8 (a-h,o-z)
1923       include 'DIMENSIONS'
1924       include 'COMMON.CHAIN'
1925       include 'COMMON.DERIV'
1926       include 'COMMON.CALC'
1927       include 'COMMON.IOUNITS'
1928       double precision dcosom1(3),dcosom2(3)
1929       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1930       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1931       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1932      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1933 c diagnostics only
1934 c      eom1=0.0d0
1935 c      eom2=0.0d0
1936 c      eom12=evdwij*eps1_om12
1937 c end diagnostics
1938 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1939 c     &  " sigder",sigder
1940 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1941 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1942       do k=1,3
1943         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1944         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1945       enddo
1946       do k=1,3
1947         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1948       enddo
1949 c      write (iout,*) "gg",(gg(k),k=1,3)
1950       do k=1,3
1951         gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1952      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1953      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1954         gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1955      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1956      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1957 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1958 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1959 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1960 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1961       enddo
1962 C
1963 C Calculate the components of the gradient in DC and X
1964 C
1965 cgrad      do k=i,j-1
1966 cgrad        do l=1,3
1967 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1968 cgrad        enddo
1969 cgrad      enddo
1970       do l=1,3
1971         gvdwcT(l,i)=gvdwcT(l,i)-gg(l)
1972         gvdwcT(l,j)=gvdwcT(l,j)+gg(l)
1973       enddo
1974       return
1975       end
1976
1977 C----------------------------------------------------------------------------
1978       subroutine sc_grad
1979       implicit real*8 (a-h,o-z)
1980       include 'DIMENSIONS'
1981       include 'COMMON.CHAIN'
1982       include 'COMMON.DERIV'
1983       include 'COMMON.CALC'
1984       include 'COMMON.IOUNITS'
1985       double precision dcosom1(3),dcosom2(3)
1986       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1987       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1988       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1989      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1990 c diagnostics only
1991 c      eom1=0.0d0
1992 c      eom2=0.0d0
1993 c      eom12=evdwij*eps1_om12
1994 c end diagnostics
1995 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1996 c     &  " sigder",sigder
1997 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1998 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1999       do k=1,3
2000         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2001         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2002       enddo
2003       do k=1,3
2004         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
2005       enddo
2006 c      write (iout,*) "gg",(gg(k),k=1,3)
2007       do k=1,3
2008         gvdwx(k,i)=gvdwx(k,i)-gg(k)
2009      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2010      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2011         gvdwx(k,j)=gvdwx(k,j)+gg(k)
2012      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2013      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2014 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2015 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2016 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2017 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2018       enddo
2019 C
2020 C Calculate the components of the gradient in DC and X
2021 C
2022 cgrad      do k=i,j-1
2023 cgrad        do l=1,3
2024 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2025 cgrad        enddo
2026 cgrad      enddo
2027       do l=1,3
2028         gvdwc(l,i)=gvdwc(l,i)-gg(l)
2029         gvdwc(l,j)=gvdwc(l,j)+gg(l)
2030       enddo
2031       return
2032       end
2033 C-----------------------------------------------------------------------
2034       subroutine e_softsphere(evdw)
2035 C
2036 C This subroutine calculates the interaction energy of nonbonded side chains
2037 C assuming the LJ potential of interaction.
2038 C
2039       implicit real*8 (a-h,o-z)
2040       include 'DIMENSIONS'
2041       parameter (accur=1.0d-10)
2042       include 'COMMON.GEO'
2043       include 'COMMON.VAR'
2044       include 'COMMON.LOCAL'
2045       include 'COMMON.CHAIN'
2046       include 'COMMON.DERIV'
2047       include 'COMMON.INTERACT'
2048       include 'COMMON.TORSION'
2049       include 'COMMON.SBRIDGE'
2050       include 'COMMON.NAMES'
2051       include 'COMMON.IOUNITS'
2052       include 'COMMON.CONTACTS'
2053       dimension gg(3)
2054 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2055       evdw=0.0D0
2056       do i=iatsc_s,iatsc_e
2057         itypi=itype(i)
2058         itypi1=itype(i+1)
2059         xi=c(1,nres+i)
2060         yi=c(2,nres+i)
2061         zi=c(3,nres+i)
2062 C
2063 C Calculate SC interaction energy.
2064 C
2065         do iint=1,nint_gr(i)
2066 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2067 cd   &                  'iend=',iend(i,iint)
2068           do j=istart(i,iint),iend(i,iint)
2069             itypj=itype(j)
2070             xj=c(1,nres+j)-xi
2071             yj=c(2,nres+j)-yi
2072             zj=c(3,nres+j)-zi
2073             rij=xj*xj+yj*yj+zj*zj
2074 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2075             r0ij=r0(itypi,itypj)
2076             r0ijsq=r0ij*r0ij
2077 c            print *,i,j,r0ij,dsqrt(rij)
2078             if (rij.lt.r0ijsq) then
2079               evdwij=0.25d0*(rij-r0ijsq)**2
2080               fac=rij-r0ijsq
2081             else
2082               evdwij=0.0d0
2083               fac=0.0d0
2084             endif
2085             evdw=evdw+evdwij
2086 C
2087 C Calculate the components of the gradient in DC and X
2088 C
2089             gg(1)=xj*fac
2090             gg(2)=yj*fac
2091             gg(3)=zj*fac
2092             do k=1,3
2093               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2094               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2095               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2096               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2097             enddo
2098 cgrad            do k=i,j-1
2099 cgrad              do l=1,3
2100 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2101 cgrad              enddo
2102 cgrad            enddo
2103           enddo ! j
2104         enddo ! iint
2105       enddo ! i
2106       return
2107       end
2108 C--------------------------------------------------------------------------
2109       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2110      &              eello_turn4)
2111 C
2112 C Soft-sphere potential of p-p interaction
2113 C
2114       implicit real*8 (a-h,o-z)
2115       include 'DIMENSIONS'
2116       include 'COMMON.CONTROL'
2117       include 'COMMON.IOUNITS'
2118       include 'COMMON.GEO'
2119       include 'COMMON.VAR'
2120       include 'COMMON.LOCAL'
2121       include 'COMMON.CHAIN'
2122       include 'COMMON.DERIV'
2123       include 'COMMON.INTERACT'
2124       include 'COMMON.CONTACTS'
2125       include 'COMMON.TORSION'
2126       include 'COMMON.VECTORS'
2127       include 'COMMON.FFIELD'
2128       dimension ggg(3)
2129 cd      write(iout,*) 'In EELEC_soft_sphere'
2130       ees=0.0D0
2131       evdw1=0.0D0
2132       eel_loc=0.0d0
2133       eello_turn3=0.0d0
2134       eello_turn4=0.0d0
2135       ind=0
2136       do i=iatel_s,iatel_e
2137         dxi=dc(1,i)
2138         dyi=dc(2,i)
2139         dzi=dc(3,i)
2140         xmedi=c(1,i)+0.5d0*dxi
2141         ymedi=c(2,i)+0.5d0*dyi
2142         zmedi=c(3,i)+0.5d0*dzi
2143         num_conti=0
2144 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2145         do j=ielstart(i),ielend(i)
2146           ind=ind+1
2147           iteli=itel(i)
2148           itelj=itel(j)
2149           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2150           r0ij=rpp(iteli,itelj)
2151           r0ijsq=r0ij*r0ij
2152           dxj=dc(1,j)
2153           dyj=dc(2,j)
2154           dzj=dc(3,j)
2155           xj=c(1,j)+0.5D0*dxj-xmedi
2156           yj=c(2,j)+0.5D0*dyj-ymedi
2157           zj=c(3,j)+0.5D0*dzj-zmedi
2158           rij=xj*xj+yj*yj+zj*zj
2159           if (rij.lt.r0ijsq) then
2160             evdw1ij=0.25d0*(rij-r0ijsq)**2
2161             fac=rij-r0ijsq
2162           else
2163             evdw1ij=0.0d0
2164             fac=0.0d0
2165           endif
2166           evdw1=evdw1+evdw1ij
2167 C
2168 C Calculate contributions to the Cartesian gradient.
2169 C
2170           ggg(1)=fac*xj
2171           ggg(2)=fac*yj
2172           ggg(3)=fac*zj
2173           do k=1,3
2174             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2175             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2176           enddo
2177 *
2178 * Loop over residues i+1 thru j-1.
2179 *
2180 cgrad          do k=i+1,j-1
2181 cgrad            do l=1,3
2182 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2183 cgrad            enddo
2184 cgrad          enddo
2185         enddo ! j
2186       enddo   ! i
2187 cgrad      do i=nnt,nct-1
2188 cgrad        do k=1,3
2189 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2190 cgrad        enddo
2191 cgrad        do j=i+1,nct-1
2192 cgrad          do k=1,3
2193 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2194 cgrad          enddo
2195 cgrad        enddo
2196 cgrad      enddo
2197       return
2198       end
2199 c------------------------------------------------------------------------------
2200       subroutine vec_and_deriv
2201       implicit real*8 (a-h,o-z)
2202       include 'DIMENSIONS'
2203 #ifdef MPI
2204       include 'mpif.h'
2205 #endif
2206       include 'COMMON.IOUNITS'
2207       include 'COMMON.GEO'
2208       include 'COMMON.VAR'
2209       include 'COMMON.LOCAL'
2210       include 'COMMON.CHAIN'
2211       include 'COMMON.VECTORS'
2212       include 'COMMON.SETUP'
2213       include 'COMMON.TIME1'
2214       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2215 C Compute the local reference systems. For reference system (i), the
2216 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2217 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2218 #ifdef PARVEC
2219       do i=ivec_start,ivec_end
2220 #else
2221       do i=1,nres-1
2222 #endif
2223           if (i.eq.nres-1) then
2224 C Case of the last full residue
2225 C Compute the Z-axis
2226             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2227             costh=dcos(pi-theta(nres))
2228             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2229             do k=1,3
2230               uz(k,i)=fac*uz(k,i)
2231             enddo
2232 C Compute the derivatives of uz
2233             uzder(1,1,1)= 0.0d0
2234             uzder(2,1,1)=-dc_norm(3,i-1)
2235             uzder(3,1,1)= dc_norm(2,i-1)
2236             uzder(1,2,1)= dc_norm(3,i-1)
2237             uzder(2,2,1)= 0.0d0
2238             uzder(3,2,1)=-dc_norm(1,i-1)
2239             uzder(1,3,1)=-dc_norm(2,i-1)
2240             uzder(2,3,1)= dc_norm(1,i-1)
2241             uzder(3,3,1)= 0.0d0
2242             uzder(1,1,2)= 0.0d0
2243             uzder(2,1,2)= dc_norm(3,i)
2244             uzder(3,1,2)=-dc_norm(2,i)
2245             uzder(1,2,2)=-dc_norm(3,i)
2246             uzder(2,2,2)= 0.0d0
2247             uzder(3,2,2)= dc_norm(1,i)
2248             uzder(1,3,2)= dc_norm(2,i)
2249             uzder(2,3,2)=-dc_norm(1,i)
2250             uzder(3,3,2)= 0.0d0
2251 C Compute the Y-axis
2252             facy=fac
2253             do k=1,3
2254               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2255             enddo
2256 C Compute the derivatives of uy
2257             do j=1,3
2258               do k=1,3
2259                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2260      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2261                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2262               enddo
2263               uyder(j,j,1)=uyder(j,j,1)-costh
2264               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2265             enddo
2266             do j=1,2
2267               do k=1,3
2268                 do l=1,3
2269                   uygrad(l,k,j,i)=uyder(l,k,j)
2270                   uzgrad(l,k,j,i)=uzder(l,k,j)
2271                 enddo
2272               enddo
2273             enddo
2274             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2275             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2276             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2277             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2278           else
2279 C Other residues
2280 C Compute the Z-axis
2281             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2282             costh=dcos(pi-theta(i+2))
2283             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2284             do k=1,3
2285               uz(k,i)=fac*uz(k,i)
2286             enddo
2287 C Compute the derivatives of uz
2288             uzder(1,1,1)= 0.0d0
2289             uzder(2,1,1)=-dc_norm(3,i+1)
2290             uzder(3,1,1)= dc_norm(2,i+1)
2291             uzder(1,2,1)= dc_norm(3,i+1)
2292             uzder(2,2,1)= 0.0d0
2293             uzder(3,2,1)=-dc_norm(1,i+1)
2294             uzder(1,3,1)=-dc_norm(2,i+1)
2295             uzder(2,3,1)= dc_norm(1,i+1)
2296             uzder(3,3,1)= 0.0d0
2297             uzder(1,1,2)= 0.0d0
2298             uzder(2,1,2)= dc_norm(3,i)
2299             uzder(3,1,2)=-dc_norm(2,i)
2300             uzder(1,2,2)=-dc_norm(3,i)
2301             uzder(2,2,2)= 0.0d0
2302             uzder(3,2,2)= dc_norm(1,i)
2303             uzder(1,3,2)= dc_norm(2,i)
2304             uzder(2,3,2)=-dc_norm(1,i)
2305             uzder(3,3,2)= 0.0d0
2306 C Compute the Y-axis
2307             facy=fac
2308             do k=1,3
2309               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2310             enddo
2311 C Compute the derivatives of uy
2312             do j=1,3
2313               do k=1,3
2314                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2315      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2316                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2317               enddo
2318               uyder(j,j,1)=uyder(j,j,1)-costh
2319               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2320             enddo
2321             do j=1,2
2322               do k=1,3
2323                 do l=1,3
2324                   uygrad(l,k,j,i)=uyder(l,k,j)
2325                   uzgrad(l,k,j,i)=uzder(l,k,j)
2326                 enddo
2327               enddo
2328             enddo
2329             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2330             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2331             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2332             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2333           endif
2334       enddo
2335       do i=1,nres-1
2336         vbld_inv_temp(1)=vbld_inv(i+1)
2337         if (i.lt.nres-1) then
2338           vbld_inv_temp(2)=vbld_inv(i+2)
2339           else
2340           vbld_inv_temp(2)=vbld_inv(i)
2341           endif
2342         do j=1,2
2343           do k=1,3
2344             do l=1,3
2345               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2346               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2347             enddo
2348           enddo
2349         enddo
2350       enddo
2351 #if defined(PARVEC) && defined(MPI)
2352       if (nfgtasks1.gt.1) then
2353         time00=MPI_Wtime()
2354 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2355 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2356 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2357         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2358      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2359      &   FG_COMM1,IERR)
2360         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2361      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2362      &   FG_COMM1,IERR)
2363         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2364      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2365      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2366         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2367      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2368      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2369         time_gather=time_gather+MPI_Wtime()-time00
2370       endif
2371 c      if (fg_rank.eq.0) then
2372 c        write (iout,*) "Arrays UY and UZ"
2373 c        do i=1,nres-1
2374 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2375 c     &     (uz(k,i),k=1,3)
2376 c        enddo
2377 c      endif
2378 #endif
2379       return
2380       end
2381 C-----------------------------------------------------------------------------
2382       subroutine check_vecgrad
2383       implicit real*8 (a-h,o-z)
2384       include 'DIMENSIONS'
2385       include 'COMMON.IOUNITS'
2386       include 'COMMON.GEO'
2387       include 'COMMON.VAR'
2388       include 'COMMON.LOCAL'
2389       include 'COMMON.CHAIN'
2390       include 'COMMON.VECTORS'
2391       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2392       dimension uyt(3,maxres),uzt(3,maxres)
2393       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2394       double precision delta /1.0d-7/
2395       call vec_and_deriv
2396 cd      do i=1,nres
2397 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2398 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2399 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2400 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2401 cd     &     (dc_norm(if90,i),if90=1,3)
2402 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2403 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2404 cd          write(iout,'(a)')
2405 cd      enddo
2406       do i=1,nres
2407         do j=1,2
2408           do k=1,3
2409             do l=1,3
2410               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2411               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2412             enddo
2413           enddo
2414         enddo
2415       enddo
2416       call vec_and_deriv
2417       do i=1,nres
2418         do j=1,3
2419           uyt(j,i)=uy(j,i)
2420           uzt(j,i)=uz(j,i)
2421         enddo
2422       enddo
2423       do i=1,nres
2424 cd        write (iout,*) 'i=',i
2425         do k=1,3
2426           erij(k)=dc_norm(k,i)
2427         enddo
2428         do j=1,3
2429           do k=1,3
2430             dc_norm(k,i)=erij(k)
2431           enddo
2432           dc_norm(j,i)=dc_norm(j,i)+delta
2433 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2434 c          do k=1,3
2435 c            dc_norm(k,i)=dc_norm(k,i)/fac
2436 c          enddo
2437 c          write (iout,*) (dc_norm(k,i),k=1,3)
2438 c          write (iout,*) (erij(k),k=1,3)
2439           call vec_and_deriv
2440           do k=1,3
2441             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2442             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2443             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2444             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2445           enddo
2446 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2447 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2448 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2449         enddo
2450         do k=1,3
2451           dc_norm(k,i)=erij(k)
2452         enddo
2453 cd        do k=1,3
2454 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2455 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2456 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2457 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2458 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2459 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2460 cd          write (iout,'(a)')
2461 cd        enddo
2462       enddo
2463       return
2464       end
2465 C--------------------------------------------------------------------------
2466       subroutine set_matrices
2467       implicit real*8 (a-h,o-z)
2468       include 'DIMENSIONS'
2469 #ifdef MPI
2470       include "mpif.h"
2471       include "COMMON.SETUP"
2472       integer IERR
2473       integer status(MPI_STATUS_SIZE)
2474 #endif
2475       include 'COMMON.IOUNITS'
2476       include 'COMMON.GEO'
2477       include 'COMMON.VAR'
2478       include 'COMMON.LOCAL'
2479       include 'COMMON.CHAIN'
2480       include 'COMMON.DERIV'
2481       include 'COMMON.INTERACT'
2482       include 'COMMON.CONTACTS'
2483       include 'COMMON.TORSION'
2484       include 'COMMON.VECTORS'
2485       include 'COMMON.FFIELD'
2486       double precision auxvec(2),auxmat(2,2)
2487 C
2488 C Compute the virtual-bond-torsional-angle dependent quantities needed
2489 C to calculate the el-loc multibody terms of various order.
2490 C
2491 #ifdef PARMAT
2492       do i=ivec_start+2,ivec_end+2
2493 #else
2494       do i=3,nres+1
2495 #endif
2496         if (i .lt. nres+1) then
2497           sin1=dsin(phi(i))
2498           cos1=dcos(phi(i))
2499           sintab(i-2)=sin1
2500           costab(i-2)=cos1
2501           obrot(1,i-2)=cos1
2502           obrot(2,i-2)=sin1
2503           sin2=dsin(2*phi(i))
2504           cos2=dcos(2*phi(i))
2505           sintab2(i-2)=sin2
2506           costab2(i-2)=cos2
2507           obrot2(1,i-2)=cos2
2508           obrot2(2,i-2)=sin2
2509           Ug(1,1,i-2)=-cos1
2510           Ug(1,2,i-2)=-sin1
2511           Ug(2,1,i-2)=-sin1
2512           Ug(2,2,i-2)= cos1
2513           Ug2(1,1,i-2)=-cos2
2514           Ug2(1,2,i-2)=-sin2
2515           Ug2(2,1,i-2)=-sin2
2516           Ug2(2,2,i-2)= cos2
2517         else
2518           costab(i-2)=1.0d0
2519           sintab(i-2)=0.0d0
2520           obrot(1,i-2)=1.0d0
2521           obrot(2,i-2)=0.0d0
2522           obrot2(1,i-2)=0.0d0
2523           obrot2(2,i-2)=0.0d0
2524           Ug(1,1,i-2)=1.0d0
2525           Ug(1,2,i-2)=0.0d0
2526           Ug(2,1,i-2)=0.0d0
2527           Ug(2,2,i-2)=1.0d0
2528           Ug2(1,1,i-2)=0.0d0
2529           Ug2(1,2,i-2)=0.0d0
2530           Ug2(2,1,i-2)=0.0d0
2531           Ug2(2,2,i-2)=0.0d0
2532         endif
2533         if (i .gt. 3 .and. i .lt. nres+1) then
2534           obrot_der(1,i-2)=-sin1
2535           obrot_der(2,i-2)= cos1
2536           Ugder(1,1,i-2)= sin1
2537           Ugder(1,2,i-2)=-cos1
2538           Ugder(2,1,i-2)=-cos1
2539           Ugder(2,2,i-2)=-sin1
2540           dwacos2=cos2+cos2
2541           dwasin2=sin2+sin2
2542           obrot2_der(1,i-2)=-dwasin2
2543           obrot2_der(2,i-2)= dwacos2
2544           Ug2der(1,1,i-2)= dwasin2
2545           Ug2der(1,2,i-2)=-dwacos2
2546           Ug2der(2,1,i-2)=-dwacos2
2547           Ug2der(2,2,i-2)=-dwasin2
2548         else
2549           obrot_der(1,i-2)=0.0d0
2550           obrot_der(2,i-2)=0.0d0
2551           Ugder(1,1,i-2)=0.0d0
2552           Ugder(1,2,i-2)=0.0d0
2553           Ugder(2,1,i-2)=0.0d0
2554           Ugder(2,2,i-2)=0.0d0
2555           obrot2_der(1,i-2)=0.0d0
2556           obrot2_der(2,i-2)=0.0d0
2557           Ug2der(1,1,i-2)=0.0d0
2558           Ug2der(1,2,i-2)=0.0d0
2559           Ug2der(2,1,i-2)=0.0d0
2560           Ug2der(2,2,i-2)=0.0d0
2561         endif
2562 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2563         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2564           iti = itortyp(itype(i-2))
2565         else
2566           iti=ntortyp+1
2567         endif
2568 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2569         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2570           iti1 = itortyp(itype(i-1))
2571         else
2572           iti1=ntortyp+1
2573         endif
2574 cd        write (iout,*) '*******i',i,' iti1',iti
2575 cd        write (iout,*) 'b1',b1(:,iti)
2576 cd        write (iout,*) 'b2',b2(:,iti)
2577 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2578 c        if (i .gt. iatel_s+2) then
2579         if (i .gt. nnt+2) then
2580           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2581           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2582           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2583      &    then
2584           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2585           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2586           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2587           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2588           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2589           endif
2590         else
2591           do k=1,2
2592             Ub2(k,i-2)=0.0d0
2593             Ctobr(k,i-2)=0.0d0
2594             Dtobr2(k,i-2)=0.0d0
2595             do l=1,2
2596               EUg(l,k,i-2)=0.0d0
2597               CUg(l,k,i-2)=0.0d0
2598               DUg(l,k,i-2)=0.0d0
2599               DtUg2(l,k,i-2)=0.0d0
2600             enddo
2601           enddo
2602         endif
2603         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2604         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2605         do k=1,2
2606           muder(k,i-2)=Ub2der(k,i-2)
2607         enddo
2608 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2609         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2610           iti1 = itortyp(itype(i-1))
2611         else
2612           iti1=ntortyp+1
2613         endif
2614         do k=1,2
2615           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2616         enddo
2617 cd        write (iout,*) 'mu ',mu(:,i-2)
2618 cd        write (iout,*) 'mu1',mu1(:,i-2)
2619 cd        write (iout,*) 'mu2',mu2(:,i-2)
2620         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2621      &  then
2622         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2623         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2624         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2625         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2626         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2627 C Vectors and matrices dependent on a single virtual-bond dihedral.
2628         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2629         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2630         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2631         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2632         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2633         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2634         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2635         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2636         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2637         endif
2638       enddo
2639 C Matrices dependent on two consecutive virtual-bond dihedrals.
2640 C The order of matrices is from left to right.
2641       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2642      &then
2643 c      do i=max0(ivec_start,2),ivec_end
2644       do i=2,nres-1
2645         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2646         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2647         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2648         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2649         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2650         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2651         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2652         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2653       enddo
2654       endif
2655 #if defined(MPI) && defined(PARMAT)
2656 #ifdef DEBUG
2657 c      if (fg_rank.eq.0) then
2658         write (iout,*) "Arrays UG and UGDER before GATHER"
2659         do i=1,nres-1
2660           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2661      &     ((ug(l,k,i),l=1,2),k=1,2),
2662      &     ((ugder(l,k,i),l=1,2),k=1,2)
2663         enddo
2664         write (iout,*) "Arrays UG2 and UG2DER"
2665         do i=1,nres-1
2666           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2667      &     ((ug2(l,k,i),l=1,2),k=1,2),
2668      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2669         enddo
2670         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2671         do i=1,nres-1
2672           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2673      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2674      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2675         enddo
2676         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2677         do i=1,nres-1
2678           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2679      &     costab(i),sintab(i),costab2(i),sintab2(i)
2680         enddo
2681         write (iout,*) "Array MUDER"
2682         do i=1,nres-1
2683           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2684         enddo
2685 c      endif
2686 #endif
2687       if (nfgtasks.gt.1) then
2688         time00=MPI_Wtime()
2689 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2690 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2691 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2692 #ifdef MATGATHER
2693         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2694      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2695      &   FG_COMM1,IERR)
2696         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2697      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2698      &   FG_COMM1,IERR)
2699         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2700      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2701      &   FG_COMM1,IERR)
2702         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2703      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2704      &   FG_COMM1,IERR)
2705         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2706      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2707      &   FG_COMM1,IERR)
2708         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2709      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2710      &   FG_COMM1,IERR)
2711         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2712      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2713      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2714         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2715      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2716      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2717         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2718      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2719      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2720         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2721      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2722      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2723         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2724      &  then
2725         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2726      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2727      &   FG_COMM1,IERR)
2728         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2729      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2730      &   FG_COMM1,IERR)
2731         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2732      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2733      &   FG_COMM1,IERR)
2734        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2735      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2736      &   FG_COMM1,IERR)
2737         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2738      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2739      &   FG_COMM1,IERR)
2740         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2741      &   ivec_count(fg_rank1),
2742      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2743      &   FG_COMM1,IERR)
2744         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2745      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2746      &   FG_COMM1,IERR)
2747         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2748      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2749      &   FG_COMM1,IERR)
2750         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2751      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2752      &   FG_COMM1,IERR)
2753         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2754      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2755      &   FG_COMM1,IERR)
2756         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2757      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2758      &   FG_COMM1,IERR)
2759         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2760      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2761      &   FG_COMM1,IERR)
2762         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2763      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2764      &   FG_COMM1,IERR)
2765         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2766      &   ivec_count(fg_rank1),
2767      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2768      &   FG_COMM1,IERR)
2769         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2770      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2771      &   FG_COMM1,IERR)
2772        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2773      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2774      &   FG_COMM1,IERR)
2775         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2776      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2777      &   FG_COMM1,IERR)
2778        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2779      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2780      &   FG_COMM1,IERR)
2781         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2782      &   ivec_count(fg_rank1),
2783      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2784      &   FG_COMM1,IERR)
2785         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2786      &   ivec_count(fg_rank1),
2787      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2788      &   FG_COMM1,IERR)
2789         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2790      &   ivec_count(fg_rank1),
2791      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2792      &   MPI_MAT2,FG_COMM1,IERR)
2793         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2794      &   ivec_count(fg_rank1),
2795      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2796      &   MPI_MAT2,FG_COMM1,IERR)
2797         endif
2798 #else
2799 c Passes matrix info through the ring
2800       isend=fg_rank1
2801       irecv=fg_rank1-1
2802       if (irecv.lt.0) irecv=nfgtasks1-1
2803       iprev=irecv
2804       inext=fg_rank1+1
2805       if (inext.ge.nfgtasks1) inext=0
2806       do i=1,nfgtasks1-1
2807 c        write (iout,*) "isend",isend," irecv",irecv
2808 c        call flush(iout)
2809         lensend=lentyp(isend)
2810         lenrecv=lentyp(irecv)
2811 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2812 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2813 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2814 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2815 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2816 c        write (iout,*) "Gather ROTAT1"
2817 c        call flush(iout)
2818 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2819 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2820 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2821 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2822 c        write (iout,*) "Gather ROTAT2"
2823 c        call flush(iout)
2824         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2825      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2826      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2827      &   iprev,4400+irecv,FG_COMM,status,IERR)
2828 c        write (iout,*) "Gather ROTAT_OLD"
2829 c        call flush(iout)
2830         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2831      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2832      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2833      &   iprev,5500+irecv,FG_COMM,status,IERR)
2834 c        write (iout,*) "Gather PRECOMP11"
2835 c        call flush(iout)
2836         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2837      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2838      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2839      &   iprev,6600+irecv,FG_COMM,status,IERR)
2840 c        write (iout,*) "Gather PRECOMP12"
2841 c        call flush(iout)
2842         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2843      &  then
2844         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2845      &   MPI_ROTAT2(lensend),inext,7700+isend,
2846      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2847      &   iprev,7700+irecv,FG_COMM,status,IERR)
2848 c        write (iout,*) "Gather PRECOMP21"
2849 c        call flush(iout)
2850         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2851      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2852      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2853      &   iprev,8800+irecv,FG_COMM,status,IERR)
2854 c        write (iout,*) "Gather PRECOMP22"
2855 c        call flush(iout)
2856         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2857      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2858      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2859      &   MPI_PRECOMP23(lenrecv),
2860      &   iprev,9900+irecv,FG_COMM,status,IERR)
2861 c        write (iout,*) "Gather PRECOMP23"
2862 c        call flush(iout)
2863         endif
2864         isend=irecv
2865         irecv=irecv-1
2866         if (irecv.lt.0) irecv=nfgtasks1-1
2867       enddo
2868 #endif
2869         time_gather=time_gather+MPI_Wtime()-time00
2870       endif
2871 #ifdef DEBUG
2872 c      if (fg_rank.eq.0) then
2873         write (iout,*) "Arrays UG and UGDER"
2874         do i=1,nres-1
2875           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2876      &     ((ug(l,k,i),l=1,2),k=1,2),
2877      &     ((ugder(l,k,i),l=1,2),k=1,2)
2878         enddo
2879         write (iout,*) "Arrays UG2 and UG2DER"
2880         do i=1,nres-1
2881           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2882      &     ((ug2(l,k,i),l=1,2),k=1,2),
2883      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2884         enddo
2885         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2886         do i=1,nres-1
2887           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2888      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2889      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2890         enddo
2891         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2892         do i=1,nres-1
2893           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2894      &     costab(i),sintab(i),costab2(i),sintab2(i)
2895         enddo
2896         write (iout,*) "Array MUDER"
2897         do i=1,nres-1
2898           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2899         enddo
2900 c      endif
2901 #endif
2902 #endif
2903 cd      do i=1,nres
2904 cd        iti = itortyp(itype(i))
2905 cd        write (iout,*) i
2906 cd        do j=1,2
2907 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2908 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2909 cd        enddo
2910 cd      enddo
2911       return
2912       end
2913 C--------------------------------------------------------------------------
2914       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2915 C
2916 C This subroutine calculates the average interaction energy and its gradient
2917 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2918 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2919 C The potential depends both on the distance of peptide-group centers and on
2920 C the orientation of the CA-CA virtual bonds.
2921 C
2922       implicit real*8 (a-h,o-z)
2923 #ifdef MPI
2924       include 'mpif.h'
2925 #endif
2926       include 'DIMENSIONS'
2927       include 'COMMON.CONTROL'
2928       include 'COMMON.SETUP'
2929       include 'COMMON.IOUNITS'
2930       include 'COMMON.GEO'
2931       include 'COMMON.VAR'
2932       include 'COMMON.LOCAL'
2933       include 'COMMON.CHAIN'
2934       include 'COMMON.DERIV'
2935       include 'COMMON.INTERACT'
2936       include 'COMMON.CONTACTS'
2937       include 'COMMON.TORSION'
2938       include 'COMMON.VECTORS'
2939       include 'COMMON.FFIELD'
2940       include 'COMMON.TIME1'
2941       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2942      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2943       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2944      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2945       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2946      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2947      &    num_conti,j1,j2
2948 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2949 #ifdef MOMENT
2950       double precision scal_el /1.0d0/
2951 #else
2952       double precision scal_el /0.5d0/
2953 #endif
2954 C 12/13/98
2955 C 13-go grudnia roku pamietnego...
2956       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2957      &                   0.0d0,1.0d0,0.0d0,
2958      &                   0.0d0,0.0d0,1.0d0/
2959 cd      write(iout,*) 'In EELEC'
2960 cd      do i=1,nloctyp
2961 cd        write(iout,*) 'Type',i
2962 cd        write(iout,*) 'B1',B1(:,i)
2963 cd        write(iout,*) 'B2',B2(:,i)
2964 cd        write(iout,*) 'CC',CC(:,:,i)
2965 cd        write(iout,*) 'DD',DD(:,:,i)
2966 cd        write(iout,*) 'EE',EE(:,:,i)
2967 cd      enddo
2968 cd      call check_vecgrad
2969 cd      stop
2970       if (icheckgrad.eq.1) then
2971         do i=1,nres-1
2972           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2973           do k=1,3
2974             dc_norm(k,i)=dc(k,i)*fac
2975           enddo
2976 c          write (iout,*) 'i',i,' fac',fac
2977         enddo
2978       endif
2979       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2980      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2981      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2982 c        call vec_and_deriv
2983 #ifdef TIMING
2984         time01=MPI_Wtime()
2985 #endif
2986         call set_matrices
2987 #ifdef TIMING
2988         time_mat=time_mat+MPI_Wtime()-time01
2989 #endif
2990       endif
2991 cd      do i=1,nres-1
2992 cd        write (iout,*) 'i=',i
2993 cd        do k=1,3
2994 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2995 cd        enddo
2996 cd        do k=1,3
2997 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2998 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2999 cd        enddo
3000 cd      enddo
3001       t_eelecij=0.0d0
3002       ees=0.0D0
3003       evdw1=0.0D0
3004       eel_loc=0.0d0
3005       eello_turn3=0.0d0
3006       eello_turn4=0.0d0
3007       ind=0
3008       do i=1,nres
3009         num_cont_hb(i)=0
3010       enddo
3011 cd      print '(a)','Enter EELEC'
3012 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3013       do i=1,nres
3014         gel_loc_loc(i)=0.0d0
3015         gcorr_loc(i)=0.0d0
3016       enddo
3017 c
3018 c
3019 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3020 C
3021 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3022 C
3023       do i=iturn3_start,iturn3_end
3024         dxi=dc(1,i)
3025         dyi=dc(2,i)
3026         dzi=dc(3,i)
3027         dx_normi=dc_norm(1,i)
3028         dy_normi=dc_norm(2,i)
3029         dz_normi=dc_norm(3,i)
3030         xmedi=c(1,i)+0.5d0*dxi
3031         ymedi=c(2,i)+0.5d0*dyi
3032         zmedi=c(3,i)+0.5d0*dzi
3033         num_conti=0
3034         call eelecij(i,i+2,ees,evdw1,eel_loc)
3035         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3036         num_cont_hb(i)=num_conti
3037       enddo
3038       do i=iturn4_start,iturn4_end
3039         dxi=dc(1,i)
3040         dyi=dc(2,i)
3041         dzi=dc(3,i)
3042         dx_normi=dc_norm(1,i)
3043         dy_normi=dc_norm(2,i)
3044         dz_normi=dc_norm(3,i)
3045         xmedi=c(1,i)+0.5d0*dxi
3046         ymedi=c(2,i)+0.5d0*dyi
3047         zmedi=c(3,i)+0.5d0*dzi
3048         num_conti=num_cont_hb(i)
3049         call eelecij(i,i+3,ees,evdw1,eel_loc)
3050         if (wturn4.gt.0.0d0) call eturn4(i,eello_turn4)
3051         num_cont_hb(i)=num_conti
3052       enddo   ! i
3053 c
3054 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3055 c
3056       do i=iatel_s,iatel_e
3057         dxi=dc(1,i)
3058         dyi=dc(2,i)
3059         dzi=dc(3,i)
3060         dx_normi=dc_norm(1,i)
3061         dy_normi=dc_norm(2,i)
3062         dz_normi=dc_norm(3,i)
3063         xmedi=c(1,i)+0.5d0*dxi
3064         ymedi=c(2,i)+0.5d0*dyi
3065         zmedi=c(3,i)+0.5d0*dzi
3066 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3067         num_conti=num_cont_hb(i)
3068         do j=ielstart(i),ielend(i)
3069           call eelecij(i,j,ees,evdw1,eel_loc)
3070         enddo ! j
3071         num_cont_hb(i)=num_conti
3072       enddo   ! i
3073 c      write (iout,*) "Number of loop steps in EELEC:",ind
3074 cd      do i=1,nres
3075 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3076 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3077 cd      enddo
3078 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3079 ccc      eel_loc=eel_loc+eello_turn3
3080 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3081       return
3082       end
3083 C-------------------------------------------------------------------------------
3084       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3085       implicit real*8 (a-h,o-z)
3086       include 'DIMENSIONS'
3087 #ifdef MPI
3088       include "mpif.h"
3089 #endif
3090       include 'COMMON.CONTROL'
3091       include 'COMMON.IOUNITS'
3092       include 'COMMON.GEO'
3093       include 'COMMON.VAR'
3094       include 'COMMON.LOCAL'
3095       include 'COMMON.CHAIN'
3096       include 'COMMON.DERIV'
3097       include 'COMMON.INTERACT'
3098       include 'COMMON.CONTACTS'
3099       include 'COMMON.TORSION'
3100       include 'COMMON.VECTORS'
3101       include 'COMMON.FFIELD'
3102       include 'COMMON.TIME1'
3103       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3104      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3105       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3106      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3107       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3108      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3109      &    num_conti,j1,j2
3110 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3111 #ifdef MOMENT
3112       double precision scal_el /1.0d0/
3113 #else
3114       double precision scal_el /0.5d0/
3115 #endif
3116 C 12/13/98
3117 C 13-go grudnia roku pamietnego...
3118       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3119      &                   0.0d0,1.0d0,0.0d0,
3120      &                   0.0d0,0.0d0,1.0d0/
3121 c          time00=MPI_Wtime()
3122 cd      write (iout,*) "eelecij",i,j
3123 c          ind=ind+1
3124           iteli=itel(i)
3125           itelj=itel(j)
3126           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3127           aaa=app(iteli,itelj)
3128           bbb=bpp(iteli,itelj)
3129           ael6i=ael6(iteli,itelj)
3130           ael3i=ael3(iteli,itelj)
3131           dxj=dc(1,j)
3132           dyj=dc(2,j)
3133           dzj=dc(3,j)
3134           dx_normj=dc_norm(1,j)
3135           dy_normj=dc_norm(2,j)
3136           dz_normj=dc_norm(3,j)
3137           xj=c(1,j)+0.5D0*dxj-xmedi
3138           yj=c(2,j)+0.5D0*dyj-ymedi
3139           zj=c(3,j)+0.5D0*dzj-zmedi
3140           rij=xj*xj+yj*yj+zj*zj
3141           rrmij=1.0D0/rij
3142           rij=dsqrt(rij)
3143           rmij=1.0D0/rij
3144           r3ij=rrmij*rmij
3145           r6ij=r3ij*r3ij
3146           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3147           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3148           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3149           fac=cosa-3.0D0*cosb*cosg
3150           ev1=aaa*r6ij*r6ij
3151 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3152           if (j.eq.i+2) ev1=scal_el*ev1
3153           ev2=bbb*r6ij
3154           fac3=ael6i*r6ij
3155           fac4=ael3i*r3ij
3156           evdwij=ev1+ev2
3157           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3158           el2=fac4*fac
3159           eesij=el1+el2
3160 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3161           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3162           ees=ees+eesij
3163           evdw1=evdw1+evdwij
3164 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3165 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3166 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3167 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3168
3169           if (energy_dec) then
3170               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3171               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3172           endif
3173
3174 C
3175 C Calculate contributions to the Cartesian gradient.
3176 C
3177 #ifdef SPLITELE
3178           facvdw=-6*rrmij*(ev1+evdwij)
3179           facel=-3*rrmij*(el1+eesij)
3180           fac1=fac
3181           erij(1)=xj*rmij
3182           erij(2)=yj*rmij
3183           erij(3)=zj*rmij
3184 *
3185 * Radial derivatives. First process both termini of the fragment (i,j)
3186 *
3187           ggg(1)=facel*xj
3188           ggg(2)=facel*yj
3189           ggg(3)=facel*zj
3190 c          do k=1,3
3191 c            ghalf=0.5D0*ggg(k)
3192 c            gelc(k,i)=gelc(k,i)+ghalf
3193 c            gelc(k,j)=gelc(k,j)+ghalf
3194 c          enddo
3195 c 9/28/08 AL Gradient compotents will be summed only at the end
3196           do k=1,3
3197             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3198             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3199           enddo
3200 *
3201 * Loop over residues i+1 thru j-1.
3202 *
3203 cgrad          do k=i+1,j-1
3204 cgrad            do l=1,3
3205 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3206 cgrad            enddo
3207 cgrad          enddo
3208           ggg(1)=facvdw*xj
3209           ggg(2)=facvdw*yj
3210           ggg(3)=facvdw*zj
3211 c          do k=1,3
3212 c            ghalf=0.5D0*ggg(k)
3213 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3214 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3215 c          enddo
3216 c 9/28/08 AL Gradient compotents will be summed only at the end
3217           do k=1,3
3218             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3219             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3220           enddo
3221 *
3222 * Loop over residues i+1 thru j-1.
3223 *
3224 cgrad          do k=i+1,j-1
3225 cgrad            do l=1,3
3226 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3227 cgrad            enddo
3228 cgrad          enddo
3229 #else
3230           facvdw=ev1+evdwij
3231           facel=el1+eesij
3232           fac1=fac
3233           fac=-3*rrmij*(facvdw+facvdw+facel)
3234           erij(1)=xj*rmij
3235           erij(2)=yj*rmij
3236           erij(3)=zj*rmij
3237 *
3238 * Radial derivatives. First process both termini of the fragment (i,j)
3239 *
3240           ggg(1)=fac*xj
3241           ggg(2)=fac*yj
3242           ggg(3)=fac*zj
3243 c          do k=1,3
3244 c            ghalf=0.5D0*ggg(k)
3245 c            gelc(k,i)=gelc(k,i)+ghalf
3246 c            gelc(k,j)=gelc(k,j)+ghalf
3247 c          enddo
3248 c 9/28/08 AL Gradient compotents will be summed only at the end
3249           do k=1,3
3250             gelc_long(k,j)=gelc(k,j)+ggg(k)
3251             gelc_long(k,i)=gelc(k,i)-ggg(k)
3252           enddo
3253 *
3254 * Loop over residues i+1 thru j-1.
3255 *
3256 cgrad          do k=i+1,j-1
3257 cgrad            do l=1,3
3258 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3259 cgrad            enddo
3260 cgrad          enddo
3261 c 9/28/08 AL Gradient compotents will be summed only at the end
3262           ggg(1)=facvdw*xj
3263           ggg(2)=facvdw*yj
3264           ggg(3)=facvdw*zj
3265           do k=1,3
3266             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3267             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3268           enddo
3269 #endif
3270 *
3271 * Angular part
3272 *
3273           ecosa=2.0D0*fac3*fac1+fac4
3274           fac4=-3.0D0*fac4
3275           fac3=-6.0D0*fac3
3276           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3277           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3278           do k=1,3
3279             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3280             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3281           enddo
3282 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3283 cd   &          (dcosg(k),k=1,3)
3284           do k=1,3
3285             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3286           enddo
3287 c          do k=1,3
3288 c            ghalf=0.5D0*ggg(k)
3289 c            gelc(k,i)=gelc(k,i)+ghalf
3290 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3291 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3292 c            gelc(k,j)=gelc(k,j)+ghalf
3293 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3294 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3295 c          enddo
3296 cgrad          do k=i+1,j-1
3297 cgrad            do l=1,3
3298 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3299 cgrad            enddo
3300 cgrad          enddo
3301           do k=1,3
3302             gelc(k,i)=gelc(k,i)
3303      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3304      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3305             gelc(k,j)=gelc(k,j)
3306      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3307      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3308             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3309             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3310           enddo
3311           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3312      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3313      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3314 C
3315 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3316 C   energy of a peptide unit is assumed in the form of a second-order
3317 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3318 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3319 C   are computed for EVERY pair of non-contiguous peptide groups.
3320 C
3321           if (j.lt.nres-1) then
3322             j1=j+1
3323             j2=j-1
3324           else
3325             j1=j-1
3326             j2=j-2
3327           endif
3328           kkk=0
3329           do k=1,2
3330             do l=1,2
3331               kkk=kkk+1
3332               muij(kkk)=mu(k,i)*mu(l,j)
3333             enddo
3334           enddo
3335 cd         write (iout,*) 'EELEC: i',i,' j',j
3336 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3337 cd          write(iout,*) 'muij',muij
3338           ury=scalar(uy(1,i),erij)
3339           urz=scalar(uz(1,i),erij)
3340           vry=scalar(uy(1,j),erij)
3341           vrz=scalar(uz(1,j),erij)
3342           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3343           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3344           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3345           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3346           fac=dsqrt(-ael6i)*r3ij
3347           a22=a22*fac
3348           a23=a23*fac
3349           a32=a32*fac
3350           a33=a33*fac
3351 cd          write (iout,'(4i5,4f10.5)')
3352 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3353 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3354 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3355 cd     &      uy(:,j),uz(:,j)
3356 cd          write (iout,'(4f10.5)')
3357 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3358 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3359 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3360 cd           write (iout,'(9f10.5/)')
3361 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3362 C Derivatives of the elements of A in virtual-bond vectors
3363           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3364           do k=1,3
3365             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3366             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3367             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3368             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3369             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3370             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3371             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3372             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3373             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3374             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3375             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3376             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3377           enddo
3378 C Compute radial contributions to the gradient
3379           facr=-3.0d0*rrmij
3380           a22der=a22*facr
3381           a23der=a23*facr
3382           a32der=a32*facr
3383           a33der=a33*facr
3384           agg(1,1)=a22der*xj
3385           agg(2,1)=a22der*yj
3386           agg(3,1)=a22der*zj
3387           agg(1,2)=a23der*xj
3388           agg(2,2)=a23der*yj
3389           agg(3,2)=a23der*zj
3390           agg(1,3)=a32der*xj
3391           agg(2,3)=a32der*yj
3392           agg(3,3)=a32der*zj
3393           agg(1,4)=a33der*xj
3394           agg(2,4)=a33der*yj
3395           agg(3,4)=a33der*zj
3396 C Add the contributions coming from er
3397           fac3=-3.0d0*fac
3398           do k=1,3
3399             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3400             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3401             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3402             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3403           enddo
3404           do k=1,3
3405 C Derivatives in DC(i)
3406 cgrad            ghalf1=0.5d0*agg(k,1)
3407 cgrad            ghalf2=0.5d0*agg(k,2)
3408 cgrad            ghalf3=0.5d0*agg(k,3)
3409 cgrad            ghalf4=0.5d0*agg(k,4)
3410             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3411      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3412             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3413      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3414             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3415      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3416             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3417      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3418 C Derivatives in DC(i+1)
3419             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3420      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3421             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3422      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3423             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3424      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3425             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3426      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3427 C Derivatives in DC(j)
3428             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3429      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3430             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3431      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3432             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3433      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3434             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3435      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3436 C Derivatives in DC(j+1) or DC(nres-1)
3437             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3438      &      -3.0d0*vryg(k,3)*ury)
3439             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3440      &      -3.0d0*vrzg(k,3)*ury)
3441             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3442      &      -3.0d0*vryg(k,3)*urz)
3443             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3444      &      -3.0d0*vrzg(k,3)*urz)
3445 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3446 cgrad              do l=1,4
3447 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3448 cgrad              enddo
3449 cgrad            endif
3450           enddo
3451           acipa(1,1)=a22
3452           acipa(1,2)=a23
3453           acipa(2,1)=a32
3454           acipa(2,2)=a33
3455           a22=-a22
3456           a23=-a23
3457           do l=1,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           if (j.lt.nres-1) then
3467             a22=-a22
3468             a32=-a32
3469             do l=1,3,2
3470               do k=1,3
3471                 agg(k,l)=-agg(k,l)
3472                 aggi(k,l)=-aggi(k,l)
3473                 aggi1(k,l)=-aggi1(k,l)
3474                 aggj(k,l)=-aggj(k,l)
3475                 aggj1(k,l)=-aggj1(k,l)
3476               enddo
3477             enddo
3478           else
3479             a22=-a22
3480             a23=-a23
3481             a32=-a32
3482             a33=-a33
3483             do l=1,4
3484               do k=1,3
3485                 agg(k,l)=-agg(k,l)
3486                 aggi(k,l)=-aggi(k,l)
3487                 aggi1(k,l)=-aggi1(k,l)
3488                 aggj(k,l)=-aggj(k,l)
3489                 aggj1(k,l)=-aggj1(k,l)
3490               enddo
3491             enddo
3492           endif
3493           ENDIF ! WCORR
3494           IF (wel_loc.gt.0.0d0) THEN
3495 C Contribution to the local-electrostatic energy coming from the i-j pair
3496           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3497      &     +a33*muij(4)
3498 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3499
3500           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3501      &            'eelloc',i,j,eel_loc_ij
3502
3503           eel_loc=eel_loc+eel_loc_ij
3504 C Partial derivatives in virtual-bond dihedral angles gamma
3505           if (i.gt.1)
3506      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3507      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3508      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3509           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3510      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3511      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3512 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3513           do l=1,3
3514             ggg(l)=agg(l,1)*muij(1)+
3515      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3516             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3517             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3518 cgrad            ghalf=0.5d0*ggg(l)
3519 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3520 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3521           enddo
3522 cgrad          do k=i+1,j2
3523 cgrad            do l=1,3
3524 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3525 cgrad            enddo
3526 cgrad          enddo
3527 C Remaining derivatives of eello
3528           do l=1,3
3529             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3530      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3531             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3532      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3533             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3534      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3535             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3536      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3537           enddo
3538           ENDIF
3539 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3540 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3541           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3542      &       .and. num_conti.le.maxconts) then
3543 c            write (iout,*) i,j," entered corr"
3544 C
3545 C Calculate the contact function. The ith column of the array JCONT will
3546 C contain the numbers of atoms that make contacts with the atom I (of numbers
3547 C greater than I). The arrays FACONT and GACONT will contain the values of
3548 C the contact function and its derivative.
3549 c           r0ij=1.02D0*rpp(iteli,itelj)
3550 c           r0ij=1.11D0*rpp(iteli,itelj)
3551             r0ij=2.20D0*rpp(iteli,itelj)
3552 c           r0ij=1.55D0*rpp(iteli,itelj)
3553             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3554             if (fcont.gt.0.0D0) then
3555               num_conti=num_conti+1
3556               if (num_conti.gt.maxconts) then
3557                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3558      &                         ' will skip next contacts for this conf.'
3559               else
3560                 jcont_hb(num_conti,i)=j
3561 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3562 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3563                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3564      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3565 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3566 C  terms.
3567                 d_cont(num_conti,i)=rij
3568 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3569 C     --- Electrostatic-interaction matrix ---
3570                 a_chuj(1,1,num_conti,i)=a22
3571                 a_chuj(1,2,num_conti,i)=a23
3572                 a_chuj(2,1,num_conti,i)=a32
3573                 a_chuj(2,2,num_conti,i)=a33
3574 C     --- Gradient of rij
3575                 do kkk=1,3
3576                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3577                 enddo
3578                 kkll=0
3579                 do k=1,2
3580                   do l=1,2
3581                     kkll=kkll+1
3582                     do m=1,3
3583                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3584                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3585                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3586                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3587                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3588                     enddo
3589                   enddo
3590                 enddo
3591                 ENDIF
3592                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3593 C Calculate contact energies
3594                 cosa4=4.0D0*cosa
3595                 wij=cosa-3.0D0*cosb*cosg
3596                 cosbg1=cosb+cosg
3597                 cosbg2=cosb-cosg
3598 c               fac3=dsqrt(-ael6i)/r0ij**3
3599                 fac3=dsqrt(-ael6i)*r3ij
3600 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3601                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3602                 if (ees0tmp.gt.0) then
3603                   ees0pij=dsqrt(ees0tmp)
3604                 else
3605                   ees0pij=0
3606                 endif
3607 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3608                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3609                 if (ees0tmp.gt.0) then
3610                   ees0mij=dsqrt(ees0tmp)
3611                 else
3612                   ees0mij=0
3613                 endif
3614 c               ees0mij=0.0D0
3615                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3616                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3617 C Diagnostics. Comment out or remove after debugging!
3618 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3619 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3620 c               ees0m(num_conti,i)=0.0D0
3621 C End diagnostics.
3622 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3623 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3624 C Angular derivatives of the contact function
3625                 ees0pij1=fac3/ees0pij
3626                 ees0mij1=fac3/ees0mij
3627                 fac3p=-3.0D0*fac3*rrmij
3628                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3629                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3630 c               ees0mij1=0.0D0
3631                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3632                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3633                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3634                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3635                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3636                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3637                 ecosap=ecosa1+ecosa2
3638                 ecosbp=ecosb1+ecosb2
3639                 ecosgp=ecosg1+ecosg2
3640                 ecosam=ecosa1-ecosa2
3641                 ecosbm=ecosb1-ecosb2
3642                 ecosgm=ecosg1-ecosg2
3643 C Diagnostics
3644 c               ecosap=ecosa1
3645 c               ecosbp=ecosb1
3646 c               ecosgp=ecosg1
3647 c               ecosam=0.0D0
3648 c               ecosbm=0.0D0
3649 c               ecosgm=0.0D0
3650 C End diagnostics
3651                 facont_hb(num_conti,i)=fcont
3652                 fprimcont=fprimcont/rij
3653 cd              facont_hb(num_conti,i)=1.0D0
3654 C Following line is for diagnostics.
3655 cd              fprimcont=0.0D0
3656                 do k=1,3
3657                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3658                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3659                 enddo
3660                 do k=1,3
3661                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3662                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3663                 enddo
3664                 gggp(1)=gggp(1)+ees0pijp*xj
3665                 gggp(2)=gggp(2)+ees0pijp*yj
3666                 gggp(3)=gggp(3)+ees0pijp*zj
3667                 gggm(1)=gggm(1)+ees0mijp*xj
3668                 gggm(2)=gggm(2)+ees0mijp*yj
3669                 gggm(3)=gggm(3)+ees0mijp*zj
3670 C Derivatives due to the contact function
3671                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3672                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3673                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3674                 do k=1,3
3675 c
3676 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3677 c          following the change of gradient-summation algorithm.
3678 c
3679 cgrad                  ghalfp=0.5D0*gggp(k)
3680 cgrad                  ghalfm=0.5D0*gggm(k)
3681                   gacontp_hb1(k,num_conti,i)=!ghalfp
3682      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3683      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3684                   gacontp_hb2(k,num_conti,i)=!ghalfp
3685      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3686      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3687                   gacontp_hb3(k,num_conti,i)=gggp(k)
3688                   gacontm_hb1(k,num_conti,i)=!ghalfm
3689      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3690      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3691                   gacontm_hb2(k,num_conti,i)=!ghalfm
3692      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3693      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3694                   gacontm_hb3(k,num_conti,i)=gggm(k)
3695                 enddo
3696 C Diagnostics. Comment out or remove after debugging!
3697 cdiag           do k=1,3
3698 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3699 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3700 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3701 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3702 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3703 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3704 cdiag           enddo
3705               ENDIF ! wcorr
3706               endif  ! num_conti.le.maxconts
3707             endif  ! fcont.gt.0
3708           endif    ! j.gt.i+1
3709           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3710             do k=1,4
3711               do l=1,3
3712                 ghalf=0.5d0*agg(l,k)
3713                 aggi(l,k)=aggi(l,k)+ghalf
3714                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3715                 aggj(l,k)=aggj(l,k)+ghalf
3716               enddo
3717             enddo
3718             if (j.eq.nres-1 .and. i.lt.j-2) then
3719               do k=1,4
3720                 do l=1,3
3721                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3722                 enddo
3723               enddo
3724             endif
3725           endif
3726 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3727       return
3728       end
3729 C-----------------------------------------------------------------------------
3730       subroutine eturn3(i,eello_turn3)
3731 C Third- and fourth-order contributions from turns
3732       implicit real*8 (a-h,o-z)
3733       include 'DIMENSIONS'
3734       include 'COMMON.IOUNITS'
3735       include 'COMMON.GEO'
3736       include 'COMMON.VAR'
3737       include 'COMMON.LOCAL'
3738       include 'COMMON.CHAIN'
3739       include 'COMMON.DERIV'
3740       include 'COMMON.INTERACT'
3741       include 'COMMON.CONTACTS'
3742       include 'COMMON.TORSION'
3743       include 'COMMON.VECTORS'
3744       include 'COMMON.FFIELD'
3745       include 'COMMON.CONTROL'
3746       dimension ggg(3)
3747       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3748      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3749      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3750       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3751      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3752       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3753      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3754      &    num_conti,j1,j2
3755       j=i+2
3756 c      write (iout,*) "eturn3",i,j,j1,j2
3757       a_temp(1,1)=a22
3758       a_temp(1,2)=a23
3759       a_temp(2,1)=a32
3760       a_temp(2,2)=a33
3761 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3762 C
3763 C               Third-order contributions
3764 C
3765 C                 (i+2)o----(i+3)
3766 C                      | |
3767 C                      | |
3768 C                 (i+1)o----i
3769 C
3770 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3771 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3772         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3773         call transpose2(auxmat(1,1),auxmat1(1,1))
3774         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3775         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3776         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3777      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3778 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3779 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3780 cd     &    ' eello_turn3_num',4*eello_turn3_num
3781 C Derivatives in gamma(i)
3782         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3783         call transpose2(auxmat2(1,1),auxmat3(1,1))
3784         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3785         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3786 C Derivatives in gamma(i+1)
3787         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3788         call transpose2(auxmat2(1,1),auxmat3(1,1))
3789         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3790         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3791      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3792 C Cartesian derivatives
3793         do l=1,3
3794 c            ghalf1=0.5d0*agg(l,1)
3795 c            ghalf2=0.5d0*agg(l,2)
3796 c            ghalf3=0.5d0*agg(l,3)
3797 c            ghalf4=0.5d0*agg(l,4)
3798           a_temp(1,1)=aggi(l,1)!+ghalf1
3799           a_temp(1,2)=aggi(l,2)!+ghalf2
3800           a_temp(2,1)=aggi(l,3)!+ghalf3
3801           a_temp(2,2)=aggi(l,4)!+ghalf4
3802           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3803           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3804      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3805           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3806           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3807           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3808           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3809           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3810           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3811      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3812           a_temp(1,1)=aggj(l,1)!+ghalf1
3813           a_temp(1,2)=aggj(l,2)!+ghalf2
3814           a_temp(2,1)=aggj(l,3)!+ghalf3
3815           a_temp(2,2)=aggj(l,4)!+ghalf4
3816           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3817           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3818      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3819           a_temp(1,1)=aggj1(l,1)
3820           a_temp(1,2)=aggj1(l,2)
3821           a_temp(2,1)=aggj1(l,3)
3822           a_temp(2,2)=aggj1(l,4)
3823           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3824           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3825      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3826         enddo
3827       return
3828       end
3829 C-------------------------------------------------------------------------------
3830       subroutine eturn4(i,eello_turn4)
3831 C Third- and fourth-order contributions from turns
3832       implicit real*8 (a-h,o-z)
3833       include 'DIMENSIONS'
3834       include 'COMMON.IOUNITS'
3835       include 'COMMON.GEO'
3836       include 'COMMON.VAR'
3837       include 'COMMON.LOCAL'
3838       include 'COMMON.CHAIN'
3839       include 'COMMON.DERIV'
3840       include 'COMMON.INTERACT'
3841       include 'COMMON.CONTACTS'
3842       include 'COMMON.TORSION'
3843       include 'COMMON.VECTORS'
3844       include 'COMMON.FFIELD'
3845       include 'COMMON.CONTROL'
3846       dimension ggg(3)
3847       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3848      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3849      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3850       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3851      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3852       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3853      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3854      &    num_conti,j1,j2
3855       j=i+3
3856 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3857 C
3858 C               Fourth-order contributions
3859 C
3860 C                 (i+3)o----(i+4)
3861 C                     /  |
3862 C               (i+2)o   |
3863 C                     \  |
3864 C                 (i+1)o----i
3865 C
3866 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3867 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3868 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3869         a_temp(1,1)=a22
3870         a_temp(1,2)=a23
3871         a_temp(2,1)=a32
3872         a_temp(2,2)=a33
3873         iti1=itortyp(itype(i+1))
3874         iti2=itortyp(itype(i+2))
3875         iti3=itortyp(itype(i+3))
3876 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3877         call transpose2(EUg(1,1,i+1),e1t(1,1))
3878         call transpose2(Eug(1,1,i+2),e2t(1,1))
3879         call transpose2(Eug(1,1,i+3),e3t(1,1))
3880         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3881         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3882         s1=scalar2(b1(1,iti2),auxvec(1))
3883         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3884         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3885         s2=scalar2(b1(1,iti1),auxvec(1))
3886         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3887         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3888         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3889         eello_turn4=eello_turn4-(s1+s2+s3)
3890         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3891      &      'eturn4',i,j,-(s1+s2+s3)
3892 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3893 cd     &    ' eello_turn4_num',8*eello_turn4_num
3894 C Derivatives in gamma(i)
3895         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3896         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3897         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3898         s1=scalar2(b1(1,iti2),auxvec(1))
3899         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3900         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3901         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3902 C Derivatives in gamma(i+1)
3903         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3904         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3905         s2=scalar2(b1(1,iti1),auxvec(1))
3906         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3907         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3908         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3909         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3910 C Derivatives in gamma(i+2)
3911         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3912         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3913         s1=scalar2(b1(1,iti2),auxvec(1))
3914         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3915         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3916         s2=scalar2(b1(1,iti1),auxvec(1))
3917         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3918         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3919         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3920         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3921 C Cartesian derivatives
3922 C Derivatives of this turn contributions in DC(i+2)
3923         if (j.lt.nres-1) then
3924           do l=1,3
3925             a_temp(1,1)=agg(l,1)
3926             a_temp(1,2)=agg(l,2)
3927             a_temp(2,1)=agg(l,3)
3928             a_temp(2,2)=agg(l,4)
3929             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3930             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3931             s1=scalar2(b1(1,iti2),auxvec(1))
3932             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3933             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3934             s2=scalar2(b1(1,iti1),auxvec(1))
3935             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3936             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3937             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3938             ggg(l)=-(s1+s2+s3)
3939             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3940           enddo
3941         endif
3942 C Remaining derivatives of this turn contribution
3943         do l=1,3
3944           a_temp(1,1)=aggi(l,1)
3945           a_temp(1,2)=aggi(l,2)
3946           a_temp(2,1)=aggi(l,3)
3947           a_temp(2,2)=aggi(l,4)
3948           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3949           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3950           s1=scalar2(b1(1,iti2),auxvec(1))
3951           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3952           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3953           s2=scalar2(b1(1,iti1),auxvec(1))
3954           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3955           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3956           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3957           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3958           a_temp(1,1)=aggi1(l,1)
3959           a_temp(1,2)=aggi1(l,2)
3960           a_temp(2,1)=aggi1(l,3)
3961           a_temp(2,2)=aggi1(l,4)
3962           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3963           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3964           s1=scalar2(b1(1,iti2),auxvec(1))
3965           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3966           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3967           s2=scalar2(b1(1,iti1),auxvec(1))
3968           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3969           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3970           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3971           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3972           a_temp(1,1)=aggj(l,1)
3973           a_temp(1,2)=aggj(l,2)
3974           a_temp(2,1)=aggj(l,3)
3975           a_temp(2,2)=aggj(l,4)
3976           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3977           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3978           s1=scalar2(b1(1,iti2),auxvec(1))
3979           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3980           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3981           s2=scalar2(b1(1,iti1),auxvec(1))
3982           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3983           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3984           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3985           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3986           a_temp(1,1)=aggj1(l,1)
3987           a_temp(1,2)=aggj1(l,2)
3988           a_temp(2,1)=aggj1(l,3)
3989           a_temp(2,2)=aggj1(l,4)
3990           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3991           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3992           s1=scalar2(b1(1,iti2),auxvec(1))
3993           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3994           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3995           s2=scalar2(b1(1,iti1),auxvec(1))
3996           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3997           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3998           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3999 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4000           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4001         enddo
4002       return
4003       end
4004 C-----------------------------------------------------------------------------
4005       subroutine vecpr(u,v,w)
4006       implicit real*8(a-h,o-z)
4007       dimension u(3),v(3),w(3)
4008       w(1)=u(2)*v(3)-u(3)*v(2)
4009       w(2)=-u(1)*v(3)+u(3)*v(1)
4010       w(3)=u(1)*v(2)-u(2)*v(1)
4011       return
4012       end
4013 C-----------------------------------------------------------------------------
4014       subroutine unormderiv(u,ugrad,unorm,ungrad)
4015 C This subroutine computes the derivatives of a normalized vector u, given
4016 C the derivatives computed without normalization conditions, ugrad. Returns
4017 C ungrad.
4018       implicit none
4019       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4020       double precision vec(3)
4021       double precision scalar
4022       integer i,j
4023 c      write (2,*) 'ugrad',ugrad
4024 c      write (2,*) 'u',u
4025       do i=1,3
4026         vec(i)=scalar(ugrad(1,i),u(1))
4027       enddo
4028 c      write (2,*) 'vec',vec
4029       do i=1,3
4030         do j=1,3
4031           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4032         enddo
4033       enddo
4034 c      write (2,*) 'ungrad',ungrad
4035       return
4036       end
4037 C-----------------------------------------------------------------------------
4038       subroutine escp_soft_sphere(evdw2,evdw2_14)
4039 C
4040 C This subroutine calculates the excluded-volume interaction energy between
4041 C peptide-group centers and side chains and its gradient in virtual-bond and
4042 C side-chain vectors.
4043 C
4044       implicit real*8 (a-h,o-z)
4045       include 'DIMENSIONS'
4046       include 'COMMON.GEO'
4047       include 'COMMON.VAR'
4048       include 'COMMON.LOCAL'
4049       include 'COMMON.CHAIN'
4050       include 'COMMON.DERIV'
4051       include 'COMMON.INTERACT'
4052       include 'COMMON.FFIELD'
4053       include 'COMMON.IOUNITS'
4054       include 'COMMON.CONTROL'
4055       dimension ggg(3)
4056       evdw2=0.0D0
4057       evdw2_14=0.0d0
4058       r0_scp=4.5d0
4059 cd    print '(a)','Enter ESCP'
4060 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4061       do i=iatscp_s,iatscp_e
4062         iteli=itel(i)
4063         xi=0.5D0*(c(1,i)+c(1,i+1))
4064         yi=0.5D0*(c(2,i)+c(2,i+1))
4065         zi=0.5D0*(c(3,i)+c(3,i+1))
4066
4067         do iint=1,nscp_gr(i)
4068
4069         do j=iscpstart(i,iint),iscpend(i,iint)
4070           itypj=itype(j)
4071 C Uncomment following three lines for SC-p interactions
4072 c         xj=c(1,nres+j)-xi
4073 c         yj=c(2,nres+j)-yi
4074 c         zj=c(3,nres+j)-zi
4075 C Uncomment following three lines for Ca-p interactions
4076           xj=c(1,j)-xi
4077           yj=c(2,j)-yi
4078           zj=c(3,j)-zi
4079           rij=xj*xj+yj*yj+zj*zj
4080           r0ij=r0_scp
4081           r0ijsq=r0ij*r0ij
4082           if (rij.lt.r0ijsq) then
4083             evdwij=0.25d0*(rij-r0ijsq)**2
4084             fac=rij-r0ijsq
4085           else
4086             evdwij=0.0d0
4087             fac=0.0d0
4088           endif
4089           evdw2=evdw2+evdwij
4090 C
4091 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4092 C
4093           ggg(1)=xj*fac
4094           ggg(2)=yj*fac
4095           ggg(3)=zj*fac
4096 cgrad          if (j.lt.i) then
4097 cd          write (iout,*) 'j<i'
4098 C Uncomment following three lines for SC-p interactions
4099 c           do k=1,3
4100 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4101 c           enddo
4102 cgrad          else
4103 cd          write (iout,*) 'j>i'
4104 cgrad            do k=1,3
4105 cgrad              ggg(k)=-ggg(k)
4106 C Uncomment following line for SC-p interactions
4107 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4108 cgrad            enddo
4109 cgrad          endif
4110 cgrad          do k=1,3
4111 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4112 cgrad          enddo
4113 cgrad          kstart=min0(i+1,j)
4114 cgrad          kend=max0(i-1,j-1)
4115 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4116 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4117 cgrad          do k=kstart,kend
4118 cgrad            do l=1,3
4119 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4120 cgrad            enddo
4121 cgrad          enddo
4122           do k=1,3
4123             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4124             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4125           enddo
4126         enddo
4127
4128         enddo ! iint
4129       enddo ! i
4130       return
4131       end
4132 C-----------------------------------------------------------------------------
4133       subroutine escp(evdw2,evdw2_14)
4134 C
4135 C This subroutine calculates the excluded-volume interaction energy between
4136 C peptide-group centers and side chains and its gradient in virtual-bond and
4137 C side-chain vectors.
4138 C
4139       implicit real*8 (a-h,o-z)
4140       include 'DIMENSIONS'
4141       include 'COMMON.GEO'
4142       include 'COMMON.VAR'
4143       include 'COMMON.LOCAL'
4144       include 'COMMON.CHAIN'
4145       include 'COMMON.DERIV'
4146       include 'COMMON.INTERACT'
4147       include 'COMMON.FFIELD'
4148       include 'COMMON.IOUNITS'
4149       include 'COMMON.CONTROL'
4150       dimension ggg(3)
4151       evdw2=0.0D0
4152       evdw2_14=0.0d0
4153 cd    print '(a)','Enter ESCP'
4154 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4155       do i=iatscp_s,iatscp_e
4156         iteli=itel(i)
4157         xi=0.5D0*(c(1,i)+c(1,i+1))
4158         yi=0.5D0*(c(2,i)+c(2,i+1))
4159         zi=0.5D0*(c(3,i)+c(3,i+1))
4160
4161         do iint=1,nscp_gr(i)
4162
4163         do j=iscpstart(i,iint),iscpend(i,iint)
4164           itypj=itype(j)
4165 C Uncomment following three lines for SC-p interactions
4166 c         xj=c(1,nres+j)-xi
4167 c         yj=c(2,nres+j)-yi
4168 c         zj=c(3,nres+j)-zi
4169 C Uncomment following three lines for Ca-p interactions
4170           xj=c(1,j)-xi
4171           yj=c(2,j)-yi
4172           zj=c(3,j)-zi
4173           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4174           fac=rrij**expon2
4175           e1=fac*fac*aad(itypj,iteli)
4176           e2=fac*bad(itypj,iteli)
4177           if (iabs(j-i) .le. 2) then
4178             e1=scal14*e1
4179             e2=scal14*e2
4180             evdw2_14=evdw2_14+e1+e2
4181           endif
4182           evdwij=e1+e2
4183           evdw2=evdw2+evdwij
4184           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4185      &        'evdw2',i,j,evdwij
4186 C
4187 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4188 C
4189           fac=-(evdwij+e1)*rrij
4190           ggg(1)=xj*fac
4191           ggg(2)=yj*fac
4192           ggg(3)=zj*fac
4193 cgrad          if (j.lt.i) then
4194 cd          write (iout,*) 'j<i'
4195 C Uncomment following three lines for SC-p interactions
4196 c           do k=1,3
4197 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4198 c           enddo
4199 cgrad          else
4200 cd          write (iout,*) 'j>i'
4201 cgrad            do k=1,3
4202 cgrad              ggg(k)=-ggg(k)
4203 C Uncomment following line for SC-p interactions
4204 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4205 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4206 cgrad            enddo
4207 cgrad          endif
4208 cgrad          do k=1,3
4209 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4210 cgrad          enddo
4211 cgrad          kstart=min0(i+1,j)
4212 cgrad          kend=max0(i-1,j-1)
4213 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4214 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4215 cgrad          do k=kstart,kend
4216 cgrad            do l=1,3
4217 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4218 cgrad            enddo
4219 cgrad          enddo
4220           do k=1,3
4221             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4222             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4223           enddo
4224         enddo
4225
4226         enddo ! iint
4227       enddo ! i
4228       do i=1,nct
4229         do j=1,3
4230           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4231           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4232           gradx_scp(j,i)=expon*gradx_scp(j,i)
4233         enddo
4234       enddo
4235 C******************************************************************************
4236 C
4237 C                              N O T E !!!
4238 C
4239 C To save time the factor EXPON has been extracted from ALL components
4240 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4241 C use!
4242 C
4243 C******************************************************************************
4244       return
4245       end
4246 C--------------------------------------------------------------------------
4247       subroutine edis(ehpb)
4248 C
4249 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4250 C
4251       implicit real*8 (a-h,o-z)
4252       include 'DIMENSIONS'
4253       include 'COMMON.SBRIDGE'
4254       include 'COMMON.CHAIN'
4255       include 'COMMON.DERIV'
4256       include 'COMMON.VAR'
4257       include 'COMMON.INTERACT'
4258       include 'COMMON.IOUNITS'
4259       dimension ggg(3)
4260       ehpb=0.0D0
4261 c      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4262 c      write(iout,*)'link_start=',link_start,' link_end=',link_end
4263       if (link_end.eq.0) return
4264       do i=link_start,link_end
4265 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4266 C CA-CA distance used in regularization of structure.
4267         ii=ihpb(i)
4268         jj=jhpb(i)
4269 C iii and jjj point to the residues for which the distance is assigned.
4270         if (ii.gt.nres) then
4271           iii=ii-nres
4272           jjj=jj-nres
4273         else
4274           iii=ii
4275           jjj=jj
4276         endif
4277 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4278 c     &    dhpb(i),dhpb1(i),forcon(i)
4279 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4280 C    distance and angle dependent SS bond potential.
4281         if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4282           call ssbond_ene(iii,jjj,eij)
4283           ehpb=ehpb+2*eij
4284 c          write (iout,*) "eij",eij
4285         else if (ii.gt.nres .and. jj.gt.nres) then
4286 c Restraints from contact prediction
4287           dd=dist(ii,jj)
4288           if (dhpb1(i).gt.0.0d0) then
4289             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4290             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4291 c            write (iout,*) "beta nmr",
4292 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4293           else
4294             dd=dist(ii,jj)
4295             rdis=dd-dhpb(i)
4296 C Get the force constant corresponding to this distance.
4297             waga=forcon(i)
4298 C Calculate the contribution to energy.
4299             ehpb=ehpb+waga*rdis*rdis
4300 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
4301 C
4302 C Evaluate gradient.
4303 C
4304             fac=waga*rdis/dd
4305           endif
4306           do j=1,3
4307             ggg(j)=fac*(c(j,jj)-c(j,ii))
4308           enddo
4309           do j=1,3
4310             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4311             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4312           enddo
4313           do k=1,3
4314             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4315             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4316           enddo
4317         else
4318 C Calculate the distance between the two points and its difference from the
4319 C target distance.
4320           dd=dist(ii,jj)
4321           if (dhpb1(i).gt.0.0d0) then
4322             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4323             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4324 c            write (iout,*) "alph nmr",
4325 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4326           else
4327             rdis=dd-dhpb(i)
4328 C Get the force constant corresponding to this distance.
4329             waga=forcon(i)
4330 C Calculate the contribution to energy.
4331             ehpb=ehpb+waga*rdis*rdis
4332 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
4333 C
4334 C Evaluate gradient.
4335 C
4336             fac=waga*rdis/dd
4337           endif
4338 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4339 cd   &   ' waga=',waga,' fac=',fac
4340             do j=1,3
4341               ggg(j)=fac*(c(j,jj)-c(j,ii))
4342             enddo
4343 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4344 C If this is a SC-SC distance, we need to calculate the contributions to the
4345 C Cartesian gradient in the SC vectors (ghpbx).
4346           if (iii.lt.ii) then
4347           do j=1,3
4348             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4349             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4350           enddo
4351           endif
4352 cgrad        do j=iii,jjj-1
4353 cgrad          do k=1,3
4354 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4355 cgrad          enddo
4356 cgrad        enddo
4357           do k=1,3
4358             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4359             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4360           enddo
4361         endif
4362       enddo
4363       ehpb=0.5D0*ehpb
4364       return
4365       end
4366 C--------------------------------------------------------------------------
4367       subroutine ssbond_ene(i,j,eij)
4368 C
4369 C Calculate the distance and angle dependent SS-bond potential energy
4370 C using a free-energy function derived based on RHF/6-31G** ab initio
4371 C calculations of diethyl disulfide.
4372 C
4373 C A. Liwo and U. Kozlowska, 11/24/03
4374 C
4375       implicit real*8 (a-h,o-z)
4376       include 'DIMENSIONS'
4377       include 'COMMON.SBRIDGE'
4378       include 'COMMON.CHAIN'
4379       include 'COMMON.DERIV'
4380       include 'COMMON.LOCAL'
4381       include 'COMMON.INTERACT'
4382       include 'COMMON.VAR'
4383       include 'COMMON.IOUNITS'
4384       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4385       itypi=itype(i)
4386       xi=c(1,nres+i)
4387       yi=c(2,nres+i)
4388       zi=c(3,nres+i)
4389       dxi=dc_norm(1,nres+i)
4390       dyi=dc_norm(2,nres+i)
4391       dzi=dc_norm(3,nres+i)
4392 c      dsci_inv=dsc_inv(itypi)
4393       dsci_inv=vbld_inv(nres+i)
4394       itypj=itype(j)
4395 c      dscj_inv=dsc_inv(itypj)
4396       dscj_inv=vbld_inv(nres+j)
4397       xj=c(1,nres+j)-xi
4398       yj=c(2,nres+j)-yi
4399       zj=c(3,nres+j)-zi
4400       dxj=dc_norm(1,nres+j)
4401       dyj=dc_norm(2,nres+j)
4402       dzj=dc_norm(3,nres+j)
4403       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4404       rij=dsqrt(rrij)
4405       erij(1)=xj*rij
4406       erij(2)=yj*rij
4407       erij(3)=zj*rij
4408       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4409       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4410       om12=dxi*dxj+dyi*dyj+dzi*dzj
4411       do k=1,3
4412         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4413         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4414       enddo
4415       rij=1.0d0/rij
4416       deltad=rij-d0cm
4417       deltat1=1.0d0-om1
4418       deltat2=1.0d0+om2
4419       deltat12=om2-om1+2.0d0
4420       cosphi=om12-om1*om2
4421       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4422      &  +akct*deltad*deltat12+ebr
4423      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4424      &  +ss_depth
4425 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4426 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4427 c     &  " deltat12",deltat12," eij",eij
4428       ed=2*akcm*deltad+akct*deltat12
4429       pom1=akct*deltad
4430       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4431       eom1=-2*akth*deltat1-pom1-om2*pom2
4432       eom2= 2*akth*deltat2+pom1-om1*pom2
4433       eom12=pom2
4434       do k=1,3
4435         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4436         ghpbx(k,i)=ghpbx(k,i)-ggk
4437      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4438      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4439         ghpbx(k,j)=ghpbx(k,j)+ggk
4440      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4441      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4442         ghpbc(k,i)=ghpbc(k,i)-ggk
4443         ghpbc(k,j)=ghpbc(k,j)+ggk
4444       enddo
4445 C
4446 C Calculate the components of the gradient in DC and X
4447 C
4448 cgrad      do k=i,j-1
4449 cgrad        do l=1,3
4450 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4451 cgrad        enddo
4452 cgrad      enddo
4453       return
4454       end
4455 C--------------------------------------------------------------------------
4456       subroutine ebond(estr)
4457 c
4458 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4459 c
4460       implicit real*8 (a-h,o-z)
4461       include 'DIMENSIONS'
4462       include 'COMMON.LOCAL'
4463       include 'COMMON.GEO'
4464       include 'COMMON.INTERACT'
4465       include 'COMMON.DERIV'
4466       include 'COMMON.VAR'
4467       include 'COMMON.CHAIN'
4468       include 'COMMON.IOUNITS'
4469       include 'COMMON.NAMES'
4470       include 'COMMON.FFIELD'
4471       include 'COMMON.CONTROL'
4472       include 'COMMON.SETUP'
4473       double precision u(3),ud(3)
4474       estr=0.0d0
4475       do i=ibondp_start,ibondp_end
4476         diff = vbld(i)-vbldp0
4477 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4478         estr=estr+diff*diff
4479         do j=1,3
4480           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4481         enddo
4482 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4483       enddo
4484       estr=0.5d0*AKP*estr
4485 c
4486 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4487 c
4488       do i=ibond_start,ibond_end
4489         iti=itype(i)
4490         if (iti.ne.10) then
4491           nbi=nbondterm(iti)
4492           if (nbi.eq.1) then
4493             diff=vbld(i+nres)-vbldsc0(1,iti)
4494 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4495 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4496             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4497             do j=1,3
4498               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4499             enddo
4500           else
4501             do j=1,nbi
4502               diff=vbld(i+nres)-vbldsc0(j,iti)
4503               ud(j)=aksc(j,iti)*diff
4504               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4505             enddo
4506             uprod=u(1)
4507             do j=2,nbi
4508               uprod=uprod*u(j)
4509             enddo
4510             usum=0.0d0
4511             usumsqder=0.0d0
4512             do j=1,nbi
4513               uprod1=1.0d0
4514               uprod2=1.0d0
4515               do k=1,nbi
4516                 if (k.ne.j) then
4517                   uprod1=uprod1*u(k)
4518                   uprod2=uprod2*u(k)*u(k)
4519                 endif
4520               enddo
4521               usum=usum+uprod1
4522               usumsqder=usumsqder+ud(j)*uprod2
4523             enddo
4524             estr=estr+uprod/usum
4525             do j=1,3
4526              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4527             enddo
4528           endif
4529         endif
4530       enddo
4531       return
4532       end
4533 #ifdef CRYST_THETA
4534 C--------------------------------------------------------------------------
4535       subroutine ebend(etheta)
4536 C
4537 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4538 C angles gamma and its derivatives in consecutive thetas and gammas.
4539 C
4540       implicit real*8 (a-h,o-z)
4541       include 'DIMENSIONS'
4542       include 'COMMON.LOCAL'
4543       include 'COMMON.GEO'
4544       include 'COMMON.INTERACT'
4545       include 'COMMON.DERIV'
4546       include 'COMMON.VAR'
4547       include 'COMMON.CHAIN'
4548       include 'COMMON.IOUNITS'
4549       include 'COMMON.NAMES'
4550       include 'COMMON.FFIELD'
4551       include 'COMMON.CONTROL'
4552       common /calcthet/ term1,term2,termm,diffak,ratak,
4553      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4554      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4555       double precision y(2),z(2)
4556       delta=0.02d0*pi
4557 c      time11=dexp(-2*time)
4558 c      time12=1.0d0
4559       etheta=0.0D0
4560 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4561       do i=ithet_start,ithet_end
4562 C Zero the energy function and its derivative at 0 or pi.
4563         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4564         it=itype(i-1)
4565         if (i.gt.3) then
4566 #ifdef OSF
4567           phii=phi(i)
4568           if (phii.ne.phii) phii=150.0
4569 #else
4570           phii=phi(i)
4571 #endif
4572           y(1)=dcos(phii)
4573           y(2)=dsin(phii)
4574         else
4575           y(1)=0.0D0
4576           y(2)=0.0D0
4577         endif
4578         if (i.lt.nres) then
4579 #ifdef OSF
4580           phii1=phi(i+1)
4581           if (phii1.ne.phii1) phii1=150.0
4582           phii1=pinorm(phii1)
4583           z(1)=cos(phii1)
4584 #else
4585           phii1=phi(i+1)
4586           z(1)=dcos(phii1)
4587 #endif
4588           z(2)=dsin(phii1)
4589         else
4590           z(1)=0.0D0
4591           z(2)=0.0D0
4592         endif
4593 C Calculate the "mean" value of theta from the part of the distribution
4594 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4595 C In following comments this theta will be referred to as t_c.
4596         thet_pred_mean=0.0d0
4597         do k=1,2
4598           athetk=athet(k,it)
4599           bthetk=bthet(k,it)
4600           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4601         enddo
4602         dthett=thet_pred_mean*ssd
4603         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4604 C Derivatives of the "mean" values in gamma1 and gamma2.
4605         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
4606         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
4607         if (theta(i).gt.pi-delta) then
4608           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4609      &         E_tc0)
4610           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4611           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4612           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4613      &        E_theta)
4614           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4615      &        E_tc)
4616         else if (theta(i).lt.delta) then
4617           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4618           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4619           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4620      &        E_theta)
4621           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4622           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4623      &        E_tc)
4624         else
4625           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4626      &        E_theta,E_tc)
4627         endif
4628         etheta=etheta+ethetai
4629         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4630      &      'ebend',i,ethetai
4631         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4632         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4633         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4634       enddo
4635 C Ufff.... We've done all this!!!
4636       return
4637       end
4638 C---------------------------------------------------------------------------
4639       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4640      &     E_tc)
4641       implicit real*8 (a-h,o-z)
4642       include 'DIMENSIONS'
4643       include 'COMMON.LOCAL'
4644       include 'COMMON.IOUNITS'
4645       common /calcthet/ term1,term2,termm,diffak,ratak,
4646      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4647      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4648 C Calculate the contributions to both Gaussian lobes.
4649 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4650 C The "polynomial part" of the "standard deviation" of this part of
4651 C the distribution.
4652         sig=polthet(3,it)
4653         do j=2,0,-1
4654           sig=sig*thet_pred_mean+polthet(j,it)
4655         enddo
4656 C Derivative of the "interior part" of the "standard deviation of the"
4657 C gamma-dependent Gaussian lobe in t_c.
4658         sigtc=3*polthet(3,it)
4659         do j=2,1,-1
4660           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4661         enddo
4662         sigtc=sig*sigtc
4663 C Set the parameters of both Gaussian lobes of the distribution.
4664 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4665         fac=sig*sig+sigc0(it)
4666         sigcsq=fac+fac
4667         sigc=1.0D0/sigcsq
4668 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4669         sigsqtc=-4.0D0*sigcsq*sigtc
4670 c       print *,i,sig,sigtc,sigsqtc
4671 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4672         sigtc=-sigtc/(fac*fac)
4673 C Following variable is sigma(t_c)**(-2)
4674         sigcsq=sigcsq*sigcsq
4675         sig0i=sig0(it)
4676         sig0inv=1.0D0/sig0i**2
4677         delthec=thetai-thet_pred_mean
4678         delthe0=thetai-theta0i
4679         term1=-0.5D0*sigcsq*delthec*delthec
4680         term2=-0.5D0*sig0inv*delthe0*delthe0
4681 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4682 C NaNs in taking the logarithm. We extract the largest exponent which is added
4683 C to the energy (this being the log of the distribution) at the end of energy
4684 C term evaluation for this virtual-bond angle.
4685         if (term1.gt.term2) then
4686           termm=term1
4687           term2=dexp(term2-termm)
4688           term1=1.0d0
4689         else
4690           termm=term2
4691           term1=dexp(term1-termm)
4692           term2=1.0d0
4693         endif
4694 C The ratio between the gamma-independent and gamma-dependent lobes of
4695 C the distribution is a Gaussian function of thet_pred_mean too.
4696         diffak=gthet(2,it)-thet_pred_mean
4697         ratak=diffak/gthet(3,it)**2
4698         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4699 C Let's differentiate it in thet_pred_mean NOW.
4700         aktc=ak*ratak
4701 C Now put together the distribution terms to make complete distribution.
4702         termexp=term1+ak*term2
4703         termpre=sigc+ak*sig0i
4704 C Contribution of the bending energy from this theta is just the -log of
4705 C the sum of the contributions from the two lobes and the pre-exponential
4706 C factor. Simple enough, isn't it?
4707         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4708 C NOW the derivatives!!!
4709 C 6/6/97 Take into account the deformation.
4710         E_theta=(delthec*sigcsq*term1
4711      &       +ak*delthe0*sig0inv*term2)/termexp
4712         E_tc=((sigtc+aktc*sig0i)/termpre
4713      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4714      &       aktc*term2)/termexp)
4715       return
4716       end
4717 c-----------------------------------------------------------------------------
4718       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4719       implicit real*8 (a-h,o-z)
4720       include 'DIMENSIONS'
4721       include 'COMMON.LOCAL'
4722       include 'COMMON.IOUNITS'
4723       common /calcthet/ term1,term2,termm,diffak,ratak,
4724      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4725      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4726       delthec=thetai-thet_pred_mean
4727       delthe0=thetai-theta0i
4728 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4729       t3 = thetai-thet_pred_mean
4730       t6 = t3**2
4731       t9 = term1
4732       t12 = t3*sigcsq
4733       t14 = t12+t6*sigsqtc
4734       t16 = 1.0d0
4735       t21 = thetai-theta0i
4736       t23 = t21**2
4737       t26 = term2
4738       t27 = t21*t26
4739       t32 = termexp
4740       t40 = t32**2
4741       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4742      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4743      & *(-t12*t9-ak*sig0inv*t27)
4744       return
4745       end
4746 #else
4747 C--------------------------------------------------------------------------
4748       subroutine ebend(etheta)
4749 C
4750 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4751 C angles gamma and its derivatives in consecutive thetas and gammas.
4752 C ab initio-derived potentials from
4753 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4754 C
4755       implicit real*8 (a-h,o-z)
4756       include 'DIMENSIONS'
4757       include 'COMMON.LOCAL'
4758       include 'COMMON.GEO'
4759       include 'COMMON.INTERACT'
4760       include 'COMMON.DERIV'
4761       include 'COMMON.VAR'
4762       include 'COMMON.CHAIN'
4763       include 'COMMON.IOUNITS'
4764       include 'COMMON.NAMES'
4765       include 'COMMON.FFIELD'
4766       include 'COMMON.CONTROL'
4767       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4768      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4769      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4770      & sinph1ph2(maxdouble,maxdouble)
4771       logical lprn /.false./, lprn1 /.false./
4772       etheta=0.0D0
4773       do i=ithet_start,ithet_end
4774         dethetai=0.0d0
4775         dephii=0.0d0
4776         dephii1=0.0d0
4777         theti2=0.5d0*theta(i)
4778         ityp2=ithetyp(itype(i-1))
4779         do k=1,nntheterm
4780           coskt(k)=dcos(k*theti2)
4781           sinkt(k)=dsin(k*theti2)
4782         enddo
4783         if (i.gt.3) then
4784 #ifdef OSF
4785           phii=phi(i)
4786           if (phii.ne.phii) phii=150.0
4787 #else
4788           phii=phi(i)
4789 #endif
4790           ityp1=ithetyp(itype(i-2))
4791           do k=1,nsingle
4792             cosph1(k)=dcos(k*phii)
4793             sinph1(k)=dsin(k*phii)
4794           enddo
4795         else
4796           phii=0.0d0
4797           ityp1=nthetyp+1
4798           do k=1,nsingle
4799             cosph1(k)=0.0d0
4800             sinph1(k)=0.0d0
4801           enddo
4802         endif
4803         if (i.lt.nres) then
4804 #ifdef OSF
4805           phii1=phi(i+1)
4806           if (phii1.ne.phii1) phii1=150.0
4807           phii1=pinorm(phii1)
4808 #else
4809           phii1=phi(i+1)
4810 #endif
4811           ityp3=ithetyp(itype(i))
4812           do k=1,nsingle
4813             cosph2(k)=dcos(k*phii1)
4814             sinph2(k)=dsin(k*phii1)
4815           enddo
4816         else
4817           phii1=0.0d0
4818           ityp3=nthetyp+1
4819           do k=1,nsingle
4820             cosph2(k)=0.0d0
4821             sinph2(k)=0.0d0
4822           enddo
4823         endif
4824         ethetai=aa0thet(ityp1,ityp2,ityp3)
4825         do k=1,ndouble
4826           do l=1,k-1
4827             ccl=cosph1(l)*cosph2(k-l)
4828             ssl=sinph1(l)*sinph2(k-l)
4829             scl=sinph1(l)*cosph2(k-l)
4830             csl=cosph1(l)*sinph2(k-l)
4831             cosph1ph2(l,k)=ccl-ssl
4832             cosph1ph2(k,l)=ccl+ssl
4833             sinph1ph2(l,k)=scl+csl
4834             sinph1ph2(k,l)=scl-csl
4835           enddo
4836         enddo
4837         if (lprn) then
4838         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4839      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4840         write (iout,*) "coskt and sinkt"
4841         do k=1,nntheterm
4842           write (iout,*) k,coskt(k),sinkt(k)
4843         enddo
4844         endif
4845         do k=1,ntheterm
4846           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4847           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4848      &      *coskt(k)
4849           if (lprn)
4850      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4851      &     " ethetai",ethetai
4852         enddo
4853         if (lprn) then
4854         write (iout,*) "cosph and sinph"
4855         do k=1,nsingle
4856           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4857         enddo
4858         write (iout,*) "cosph1ph2 and sinph2ph2"
4859         do k=2,ndouble
4860           do l=1,k-1
4861             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4862      &         sinph1ph2(l,k),sinph1ph2(k,l)
4863           enddo
4864         enddo
4865         write(iout,*) "ethetai",ethetai
4866         endif
4867         do m=1,ntheterm2
4868           do k=1,nsingle
4869             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4870      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4871      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4872      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4873             ethetai=ethetai+sinkt(m)*aux
4874             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4875             dephii=dephii+k*sinkt(m)*(
4876      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4877      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4878             dephii1=dephii1+k*sinkt(m)*(
4879      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4880      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4881             if (lprn)
4882      &      write (iout,*) "m",m," k",k," bbthet",
4883      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4884      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4885      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4886      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4887           enddo
4888         enddo
4889         if (lprn)
4890      &  write(iout,*) "ethetai",ethetai
4891         do m=1,ntheterm3
4892           do k=2,ndouble
4893             do l=1,k-1
4894               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4895      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4896      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4897      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4898               ethetai=ethetai+sinkt(m)*aux
4899               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4900               dephii=dephii+l*sinkt(m)*(
4901      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4902      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4903      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4904      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4905               dephii1=dephii1+(k-l)*sinkt(m)*(
4906      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4907      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4908      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
4909      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4910               if (lprn) then
4911               write (iout,*) "m",m," k",k," l",l," ffthet",
4912      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
4913      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
4914      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
4915      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4916               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4917      &            cosph1ph2(k,l)*sinkt(m),
4918      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4919               endif
4920             enddo
4921           enddo
4922         enddo
4923 10      continue
4924         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4925      &   i,theta(i)*rad2deg,phii*rad2deg,
4926      &   phii1*rad2deg,ethetai
4927         etheta=etheta+ethetai
4928         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4929         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4930         gloc(nphi+i-2,icg)=wang*dethetai
4931       enddo
4932       return
4933       end
4934 #endif
4935 #ifdef CRYST_SC
4936 c-----------------------------------------------------------------------------
4937       subroutine esc(escloc)
4938 C Calculate the local energy of a side chain and its derivatives in the
4939 C corresponding virtual-bond valence angles THETA and the spherical angles
4940 C ALPHA and OMEGA.
4941       implicit real*8 (a-h,o-z)
4942       include 'DIMENSIONS'
4943       include 'COMMON.GEO'
4944       include 'COMMON.LOCAL'
4945       include 'COMMON.VAR'
4946       include 'COMMON.INTERACT'
4947       include 'COMMON.DERIV'
4948       include 'COMMON.CHAIN'
4949       include 'COMMON.IOUNITS'
4950       include 'COMMON.NAMES'
4951       include 'COMMON.FFIELD'
4952       include 'COMMON.CONTROL'
4953       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4954      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4955       common /sccalc/ time11,time12,time112,theti,it,nlobit
4956       delta=0.02d0*pi
4957       escloc=0.0D0
4958 c     write (iout,'(a)') 'ESC'
4959       do i=loc_start,loc_end
4960         it=itype(i)
4961         if (it.eq.10) goto 1
4962         nlobit=nlob(it)
4963 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4964 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4965         theti=theta(i+1)-pipol
4966         x(1)=dtan(theti)
4967         x(2)=alph(i)
4968         x(3)=omeg(i)
4969
4970         if (x(2).gt.pi-delta) then
4971           xtemp(1)=x(1)
4972           xtemp(2)=pi-delta
4973           xtemp(3)=x(3)
4974           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4975           xtemp(2)=pi
4976           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4977           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4978      &        escloci,dersc(2))
4979           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4980      &        ddersc0(1),dersc(1))
4981           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4982      &        ddersc0(3),dersc(3))
4983           xtemp(2)=pi-delta
4984           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4985           xtemp(2)=pi
4986           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4987           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4988      &            dersc0(2),esclocbi,dersc02)
4989           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4990      &            dersc12,dersc01)
4991           call splinthet(x(2),0.5d0*delta,ss,ssd)
4992           dersc0(1)=dersc01
4993           dersc0(2)=dersc02
4994           dersc0(3)=0.0d0
4995           do k=1,3
4996             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4997           enddo
4998           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4999 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5000 c    &             esclocbi,ss,ssd
5001           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5002 c         escloci=esclocbi
5003 c         write (iout,*) escloci
5004         else if (x(2).lt.delta) then
5005           xtemp(1)=x(1)
5006           xtemp(2)=delta
5007           xtemp(3)=x(3)
5008           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5009           xtemp(2)=0.0d0
5010           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5011           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5012      &        escloci,dersc(2))
5013           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5014      &        ddersc0(1),dersc(1))
5015           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5016      &        ddersc0(3),dersc(3))
5017           xtemp(2)=delta
5018           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5019           xtemp(2)=0.0d0
5020           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5021           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5022      &            dersc0(2),esclocbi,dersc02)
5023           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5024      &            dersc12,dersc01)
5025           dersc0(1)=dersc01
5026           dersc0(2)=dersc02
5027           dersc0(3)=0.0d0
5028           call splinthet(x(2),0.5d0*delta,ss,ssd)
5029           do k=1,3
5030             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5031           enddo
5032           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5033 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5034 c    &             esclocbi,ss,ssd
5035           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5036 c         write (iout,*) escloci
5037         else
5038           call enesc(x,escloci,dersc,ddummy,.false.)
5039         endif
5040
5041         escloc=escloc+escloci
5042         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5043      &     'escloc',i,escloci
5044 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5045
5046         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5047      &   wscloc*dersc(1)
5048         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5049         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5050     1   continue
5051       enddo
5052       return
5053       end
5054 C---------------------------------------------------------------------------
5055       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5056       implicit real*8 (a-h,o-z)
5057       include 'DIMENSIONS'
5058       include 'COMMON.GEO'
5059       include 'COMMON.LOCAL'
5060       include 'COMMON.IOUNITS'
5061       common /sccalc/ time11,time12,time112,theti,it,nlobit
5062       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5063       double precision contr(maxlob,-1:1)
5064       logical mixed
5065 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5066         escloc_i=0.0D0
5067         do j=1,3
5068           dersc(j)=0.0D0
5069           if (mixed) ddersc(j)=0.0d0
5070         enddo
5071         x3=x(3)
5072
5073 C Because of periodicity of the dependence of the SC energy in omega we have
5074 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5075 C To avoid underflows, first compute & store the exponents.
5076
5077         do iii=-1,1
5078
5079           x(3)=x3+iii*dwapi
5080
5081           do j=1,nlobit
5082             do k=1,3
5083               z(k)=x(k)-censc(k,j,it)
5084             enddo
5085             do k=1,3
5086               Axk=0.0D0
5087               do l=1,3
5088                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5089               enddo
5090               Ax(k,j,iii)=Axk
5091             enddo
5092             expfac=0.0D0
5093             do k=1,3
5094               expfac=expfac+Ax(k,j,iii)*z(k)
5095             enddo
5096             contr(j,iii)=expfac
5097           enddo ! j
5098
5099         enddo ! iii
5100
5101         x(3)=x3
5102 C As in the case of ebend, we want to avoid underflows in exponentiation and
5103 C subsequent NaNs and INFs in energy calculation.
5104 C Find the largest exponent
5105         emin=contr(1,-1)
5106         do iii=-1,1
5107           do j=1,nlobit
5108             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5109           enddo
5110         enddo
5111         emin=0.5D0*emin
5112 cd      print *,'it=',it,' emin=',emin
5113
5114 C Compute the contribution to SC energy and derivatives
5115         do iii=-1,1
5116
5117           do j=1,nlobit
5118 #ifdef OSF
5119             adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin
5120             if(adexp.ne.adexp) adexp=1.0
5121             expfac=dexp(adexp)
5122 #else
5123             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
5124 #endif
5125 cd          print *,'j=',j,' expfac=',expfac
5126             escloc_i=escloc_i+expfac
5127             do k=1,3
5128               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5129             enddo
5130             if (mixed) then
5131               do k=1,3,2
5132                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5133      &            +gaussc(k,2,j,it))*expfac
5134               enddo
5135             endif
5136           enddo
5137
5138         enddo ! iii
5139
5140         dersc(1)=dersc(1)/cos(theti)**2
5141         ddersc(1)=ddersc(1)/cos(theti)**2
5142         ddersc(3)=ddersc(3)
5143
5144         escloci=-(dlog(escloc_i)-emin)
5145         do j=1,3
5146           dersc(j)=dersc(j)/escloc_i
5147         enddo
5148         if (mixed) then
5149           do j=1,3,2
5150             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5151           enddo
5152         endif
5153       return
5154       end
5155 C------------------------------------------------------------------------------
5156       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5157       implicit real*8 (a-h,o-z)
5158       include 'DIMENSIONS'
5159       include 'COMMON.GEO'
5160       include 'COMMON.LOCAL'
5161       include 'COMMON.IOUNITS'
5162       common /sccalc/ time11,time12,time112,theti,it,nlobit
5163       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5164       double precision contr(maxlob)
5165       logical mixed
5166
5167       escloc_i=0.0D0
5168
5169       do j=1,3
5170         dersc(j)=0.0D0
5171       enddo
5172
5173       do j=1,nlobit
5174         do k=1,2
5175           z(k)=x(k)-censc(k,j,it)
5176         enddo
5177         z(3)=dwapi
5178         do k=1,3
5179           Axk=0.0D0
5180           do l=1,3
5181             Axk=Axk+gaussc(l,k,j,it)*z(l)
5182           enddo
5183           Ax(k,j)=Axk
5184         enddo
5185         expfac=0.0D0
5186         do k=1,3
5187           expfac=expfac+Ax(k,j)*z(k)
5188         enddo
5189         contr(j)=expfac
5190       enddo ! j
5191
5192 C As in the case of ebend, we want to avoid underflows in exponentiation and
5193 C subsequent NaNs and INFs in energy calculation.
5194 C Find the largest exponent
5195       emin=contr(1)
5196       do j=1,nlobit
5197         if (emin.gt.contr(j)) emin=contr(j)
5198       enddo
5199       emin=0.5D0*emin
5200
5201 C Compute the contribution to SC energy and derivatives
5202
5203       dersc12=0.0d0
5204       do j=1,nlobit
5205         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
5206         escloc_i=escloc_i+expfac
5207         do k=1,2
5208           dersc(k)=dersc(k)+Ax(k,j)*expfac
5209         enddo
5210         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5211      &            +gaussc(1,2,j,it))*expfac
5212         dersc(3)=0.0d0
5213       enddo
5214
5215       dersc(1)=dersc(1)/cos(theti)**2
5216       dersc12=dersc12/cos(theti)**2
5217       escloci=-(dlog(escloc_i)-emin)
5218       do j=1,2
5219         dersc(j)=dersc(j)/escloc_i
5220       enddo
5221       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5222       return
5223       end
5224 #else
5225 c----------------------------------------------------------------------------------
5226       subroutine esc(escloc)
5227 C Calculate the local energy of a side chain and its derivatives in the
5228 C corresponding virtual-bond valence angles THETA and the spherical angles
5229 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5230 C added by Urszula Kozlowska. 07/11/2007
5231 C
5232       implicit real*8 (a-h,o-z)
5233       include 'DIMENSIONS'
5234       include 'COMMON.GEO'
5235       include 'COMMON.LOCAL'
5236       include 'COMMON.VAR'
5237       include 'COMMON.SCROT'
5238       include 'COMMON.INTERACT'
5239       include 'COMMON.DERIV'
5240       include 'COMMON.CHAIN'
5241       include 'COMMON.IOUNITS'
5242       include 'COMMON.NAMES'
5243       include 'COMMON.FFIELD'
5244       include 'COMMON.CONTROL'
5245       include 'COMMON.VECTORS'
5246       double precision x_prime(3),y_prime(3),z_prime(3)
5247      &    , sumene,dsc_i,dp2_i,x(65),
5248      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5249      &    de_dxx,de_dyy,de_dzz,de_dt
5250       double precision s1_t,s1_6_t,s2_t,s2_6_t
5251       double precision
5252      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5253      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5254      & dt_dCi(3),dt_dCi1(3)
5255       common /sccalc/ time11,time12,time112,theti,it,nlobit
5256       delta=0.02d0*pi
5257       escloc=0.0D0
5258       do i=loc_start,loc_end
5259         costtab(i+1) =dcos(theta(i+1))
5260         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5261         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5262         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5263         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5264         cosfac=dsqrt(cosfac2)
5265         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5266         sinfac=dsqrt(sinfac2)
5267         it=itype(i)
5268         if (it.eq.10) goto 1
5269 c
5270 C  Compute the axes of tghe local cartesian coordinates system; store in
5271 c   x_prime, y_prime and z_prime
5272 c
5273         do j=1,3
5274           x_prime(j) = 0.00
5275           y_prime(j) = 0.00
5276           z_prime(j) = 0.00
5277         enddo
5278 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5279 C     &   dc_norm(3,i+nres)
5280         do j = 1,3
5281           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5282           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5283         enddo
5284         do j = 1,3
5285           z_prime(j) = -uz(j,i-1)
5286         enddo
5287 c       write (2,*) "i",i
5288 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5289 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5290 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5291 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5292 c      & " xy",scalar(x_prime(1),y_prime(1)),
5293 c      & " xz",scalar(x_prime(1),z_prime(1)),
5294 c      & " yy",scalar(y_prime(1),y_prime(1)),
5295 c      & " yz",scalar(y_prime(1),z_prime(1)),
5296 c      & " zz",scalar(z_prime(1),z_prime(1))
5297 c
5298 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5299 C to local coordinate system. Store in xx, yy, zz.
5300 c
5301         xx=0.0d0
5302         yy=0.0d0
5303         zz=0.0d0
5304         do j = 1,3
5305           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5306           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5307           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5308         enddo
5309
5310         xxtab(i)=xx
5311         yytab(i)=yy
5312         zztab(i)=zz
5313 C
5314 C Compute the energy of the ith side cbain
5315 C
5316 c        write (2,*) "xx",xx," yy",yy," zz",zz
5317         it=itype(i)
5318         do j = 1,65
5319           x(j) = sc_parmin(j,it)
5320         enddo
5321 #ifdef CHECK_COORD
5322 Cc diagnostics - remove later
5323         xx1 = dcos(alph(2))
5324         yy1 = dsin(alph(2))*dcos(omeg(2))
5325         zz1 = -dsin(alph(2))*dsin(omeg(2))
5326         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5327      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5328      &    xx1,yy1,zz1
5329 C,"  --- ", xx_w,yy_w,zz_w
5330 c end diagnostics
5331 #endif
5332         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5333      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5334      &   + x(10)*yy*zz
5335         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5336      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5337      & + x(20)*yy*zz
5338         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5339      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5340      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5341      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5342      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5343      &  +x(40)*xx*yy*zz
5344         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5345      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5346      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5347      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5348      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5349      &  +x(60)*xx*yy*zz
5350         dsc_i   = 0.743d0+x(61)
5351         dp2_i   = 1.9d0+x(62)
5352         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5353      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5354         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5355      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5356         s1=(1+x(63))/(0.1d0 + dscp1)
5357         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5358         s2=(1+x(65))/(0.1d0 + dscp2)
5359         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5360         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5361      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5362 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5363 c     &   sumene4,
5364 c     &   dscp1,dscp2,sumene
5365 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5366         escloc = escloc + sumene
5367 c        write (2,*) "i",i," escloc",sumene,escloc
5368 #ifdef DEBUG
5369 C
5370 C This section to check the numerical derivatives of the energy of ith side
5371 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5372 C #define DEBUG in the code to turn it on.
5373 C
5374         write (2,*) "sumene               =",sumene
5375         aincr=1.0d-7
5376         xxsave=xx
5377         xx=xx+aincr
5378         write (2,*) xx,yy,zz
5379         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5380         de_dxx_num=(sumenep-sumene)/aincr
5381         xx=xxsave
5382         write (2,*) "xx+ sumene from enesc=",sumenep
5383         yysave=yy
5384         yy=yy+aincr
5385         write (2,*) xx,yy,zz
5386         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5387         de_dyy_num=(sumenep-sumene)/aincr
5388         yy=yysave
5389         write (2,*) "yy+ sumene from enesc=",sumenep
5390         zzsave=zz
5391         zz=zz+aincr
5392         write (2,*) xx,yy,zz
5393         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5394         de_dzz_num=(sumenep-sumene)/aincr
5395         zz=zzsave
5396         write (2,*) "zz+ sumene from enesc=",sumenep
5397         costsave=cost2tab(i+1)
5398         sintsave=sint2tab(i+1)
5399         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5400         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5401         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5402         de_dt_num=(sumenep-sumene)/aincr
5403         write (2,*) " t+ sumene from enesc=",sumenep
5404         cost2tab(i+1)=costsave
5405         sint2tab(i+1)=sintsave
5406 C End of diagnostics section.
5407 #endif
5408 C
5409 C Compute the gradient of esc
5410 C
5411         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5412         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5413         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5414         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5415         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5416         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5417         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5418         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5419         pom1=(sumene3*sint2tab(i+1)+sumene1)
5420      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5421         pom2=(sumene4*cost2tab(i+1)+sumene2)
5422      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5423         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5424         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5425      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5426      &  +x(40)*yy*zz
5427         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5428         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5429      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5430      &  +x(60)*yy*zz
5431         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5432      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5433      &        +(pom1+pom2)*pom_dx
5434 #ifdef DEBUG
5435         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5436 #endif
5437 C
5438         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5439         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5440      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5441      &  +x(40)*xx*zz
5442         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5443         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5444      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5445      &  +x(59)*zz**2 +x(60)*xx*zz
5446         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5447      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5448      &        +(pom1-pom2)*pom_dy
5449 #ifdef DEBUG
5450         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5451 #endif
5452 C
5453         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5454      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5455      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5456      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5457      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5458      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5459      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5460      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5461 #ifdef DEBUG
5462         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5463 #endif
5464 C
5465         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5466      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5467      &  +pom1*pom_dt1+pom2*pom_dt2
5468 #ifdef DEBUG
5469         write(2,*), "de_dt = ", de_dt,de_dt_num
5470 #endif
5471 c
5472 C
5473        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5474        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5475        cosfac2xx=cosfac2*xx
5476        sinfac2yy=sinfac2*yy
5477        do k = 1,3
5478          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5479      &      vbld_inv(i+1)
5480          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5481      &      vbld_inv(i)
5482          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5483          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5484 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5485 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5486 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5487 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5488          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5489          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5490          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5491          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5492          dZZ_Ci1(k)=0.0d0
5493          dZZ_Ci(k)=0.0d0
5494          do j=1,3
5495            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5496            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5497          enddo
5498
5499          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5500          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5501          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5502 c
5503          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5504          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5505        enddo
5506
5507        do k=1,3
5508          dXX_Ctab(k,i)=dXX_Ci(k)
5509          dXX_C1tab(k,i)=dXX_Ci1(k)
5510          dYY_Ctab(k,i)=dYY_Ci(k)
5511          dYY_C1tab(k,i)=dYY_Ci1(k)
5512          dZZ_Ctab(k,i)=dZZ_Ci(k)
5513          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5514          dXX_XYZtab(k,i)=dXX_XYZ(k)
5515          dYY_XYZtab(k,i)=dYY_XYZ(k)
5516          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5517        enddo
5518
5519        do k = 1,3
5520 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5521 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5522 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5523 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5524 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5525 c     &    dt_dci(k)
5526 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5527 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5528          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5529      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5530          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5531      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5532          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5533      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5534        enddo
5535 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5536 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5537
5538 C to check gradient call subroutine check_grad
5539
5540     1 continue
5541       enddo
5542       return
5543       end
5544 c------------------------------------------------------------------------------
5545       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5546       implicit none
5547       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5548      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5549       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5550      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5551      &   + x(10)*yy*zz
5552       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5553      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5554      & + x(20)*yy*zz
5555       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5556      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5557      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5558      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5559      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5560      &  +x(40)*xx*yy*zz
5561       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5562      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5563      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5564      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5565      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5566      &  +x(60)*xx*yy*zz
5567       dsc_i   = 0.743d0+x(61)
5568       dp2_i   = 1.9d0+x(62)
5569       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5570      &          *(xx*cost2+yy*sint2))
5571       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5572      &          *(xx*cost2-yy*sint2))
5573       s1=(1+x(63))/(0.1d0 + dscp1)
5574       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5575       s2=(1+x(65))/(0.1d0 + dscp2)
5576       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5577       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5578      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5579       enesc=sumene
5580       return
5581       end
5582 #endif
5583 c------------------------------------------------------------------------------
5584       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5585 C
5586 C This procedure calculates two-body contact function g(rij) and its derivative:
5587 C
5588 C           eps0ij                                     !       x < -1
5589 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5590 C            0                                         !       x > 1
5591 C
5592 C where x=(rij-r0ij)/delta
5593 C
5594 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5595 C
5596       implicit none
5597       double precision rij,r0ij,eps0ij,fcont,fprimcont
5598       double precision x,x2,x4,delta
5599 c     delta=0.02D0*r0ij
5600 c      delta=0.2D0*r0ij
5601       x=(rij-r0ij)/delta
5602       if (x.lt.-1.0D0) then
5603         fcont=eps0ij
5604         fprimcont=0.0D0
5605       else if (x.le.1.0D0) then
5606         x2=x*x
5607         x4=x2*x2
5608         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5609         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5610       else
5611         fcont=0.0D0
5612         fprimcont=0.0D0
5613       endif
5614       return
5615       end
5616 c------------------------------------------------------------------------------
5617       subroutine splinthet(theti,delta,ss,ssder)
5618       implicit real*8 (a-h,o-z)
5619       include 'DIMENSIONS'
5620       include 'COMMON.VAR'
5621       include 'COMMON.GEO'
5622       thetup=pi-delta
5623       thetlow=delta
5624       if (theti.gt.pipol) then
5625         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5626       else
5627         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5628         ssder=-ssder
5629       endif
5630       return
5631       end
5632 c------------------------------------------------------------------------------
5633       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5634       implicit none
5635       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5636       double precision ksi,ksi2,ksi3,a1,a2,a3
5637       a1=fprim0*delta/(f1-f0)
5638       a2=3.0d0-2.0d0*a1
5639       a3=a1-2.0d0
5640       ksi=(x-x0)/delta
5641       ksi2=ksi*ksi
5642       ksi3=ksi2*ksi
5643       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5644       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5645       return
5646       end
5647 c------------------------------------------------------------------------------
5648       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5649       implicit none
5650       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5651       double precision ksi,ksi2,ksi3,a1,a2,a3
5652       ksi=(x-x0)/delta
5653       ksi2=ksi*ksi
5654       ksi3=ksi2*ksi
5655       a1=fprim0x*delta
5656       a2=3*(f1x-f0x)-2*fprim0x*delta
5657       a3=fprim0x*delta-2*(f1x-f0x)
5658       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5659       return
5660       end
5661 C-----------------------------------------------------------------------------
5662 #ifdef CRYST_TOR
5663 C-----------------------------------------------------------------------------
5664       subroutine etor(etors,edihcnstr)
5665       implicit real*8 (a-h,o-z)
5666       include 'DIMENSIONS'
5667       include 'COMMON.VAR'
5668       include 'COMMON.GEO'
5669       include 'COMMON.LOCAL'
5670       include 'COMMON.TORSION'
5671       include 'COMMON.INTERACT'
5672       include 'COMMON.DERIV'
5673       include 'COMMON.CHAIN'
5674       include 'COMMON.NAMES'
5675       include 'COMMON.IOUNITS'
5676       include 'COMMON.FFIELD'
5677       include 'COMMON.TORCNSTR'
5678       include 'COMMON.CONTROL'
5679       logical lprn
5680 C Set lprn=.true. for debugging
5681       lprn=.false.
5682 c      lprn=.true.
5683       etors=0.0D0
5684       do i=iphi_start,iphi_end
5685       etors_ii=0.0D0
5686         itori=itortyp(itype(i-2))
5687         itori1=itortyp(itype(i-1))
5688         phii=phi(i)
5689         gloci=0.0D0
5690 C Proline-Proline pair is a special case...
5691         if (itori.eq.3 .and. itori1.eq.3) then
5692           if (phii.gt.-dwapi3) then
5693             cosphi=dcos(3*phii)
5694             fac=1.0D0/(1.0D0-cosphi)
5695             etorsi=v1(1,3,3)*fac
5696             etorsi=etorsi+etorsi
5697             etors=etors+etorsi-v1(1,3,3)
5698             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5699             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5700           endif
5701           do j=1,3
5702             v1ij=v1(j+1,itori,itori1)
5703             v2ij=v2(j+1,itori,itori1)
5704             cosphi=dcos(j*phii)
5705             sinphi=dsin(j*phii)
5706             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5707             if (energy_dec) etors_ii=etors_ii+
5708      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5709             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5710           enddo
5711         else
5712           do j=1,nterm_old
5713             v1ij=v1(j,itori,itori1)
5714             v2ij=v2(j,itori,itori1)
5715             cosphi=dcos(j*phii)
5716             sinphi=dsin(j*phii)
5717             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5718             if (energy_dec) etors_ii=etors_ii+
5719      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5720             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5721           enddo
5722         endif
5723         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5724      &        'etor',i,etors_ii
5725         if (lprn)
5726      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5727      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5728      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5729         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5730         write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5731       enddo
5732 ! 6/20/98 - dihedral angle constraints
5733       edihcnstr=0.0d0
5734       do i=1,ndih_constr
5735         itori=idih_constr(i)
5736         phii=phi(itori)
5737         difi=phii-phi0(i)
5738         if (difi.gt.drange(i)) then
5739           difi=difi-drange(i)
5740           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5741           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5742         else if (difi.lt.-drange(i)) then
5743           difi=difi+drange(i)
5744           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5745           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5746         endif
5747 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5748 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5749       enddo
5750 !      write (iout,*) 'edihcnstr',edihcnstr
5751       return
5752       end
5753 c------------------------------------------------------------------------------
5754       subroutine etor_d(etors_d)
5755       etors_d=0.0d0
5756       return
5757       end
5758 c----------------------------------------------------------------------------
5759 #else
5760       subroutine etor(etors,edihcnstr)
5761       implicit real*8 (a-h,o-z)
5762       include 'DIMENSIONS'
5763       include 'COMMON.VAR'
5764       include 'COMMON.GEO'
5765       include 'COMMON.LOCAL'
5766       include 'COMMON.TORSION'
5767       include 'COMMON.INTERACT'
5768       include 'COMMON.DERIV'
5769       include 'COMMON.CHAIN'
5770       include 'COMMON.NAMES'
5771       include 'COMMON.IOUNITS'
5772       include 'COMMON.FFIELD'
5773       include 'COMMON.TORCNSTR'
5774       include 'COMMON.CONTROL'
5775       logical lprn
5776 C Set lprn=.true. for debugging
5777       lprn=.false.
5778 c     lprn=.true.
5779       etors=0.0D0
5780       do i=iphi_start,iphi_end
5781       etors_ii=0.0D0
5782         itori=itortyp(itype(i-2))
5783         itori1=itortyp(itype(i-1))
5784         phii=phi(i)
5785         gloci=0.0D0
5786 C Regular cosine and sine terms
5787         do j=1,nterm(itori,itori1)
5788           v1ij=v1(j,itori,itori1)
5789           v2ij=v2(j,itori,itori1)
5790           cosphi=dcos(j*phii)
5791           sinphi=dsin(j*phii)
5792           etors=etors+v1ij*cosphi+v2ij*sinphi
5793           if (energy_dec) etors_ii=etors_ii+
5794      &                v1ij*cosphi+v2ij*sinphi
5795           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5796         enddo
5797 C Lorentz terms
5798 C                         v1
5799 C  E = SUM ----------------------------------- - v1
5800 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5801 C
5802         cosphi=dcos(0.5d0*phii)
5803         sinphi=dsin(0.5d0*phii)
5804         do j=1,nlor(itori,itori1)
5805           vl1ij=vlor1(j,itori,itori1)
5806           vl2ij=vlor2(j,itori,itori1)
5807           vl3ij=vlor3(j,itori,itori1)
5808           pom=vl2ij*cosphi+vl3ij*sinphi
5809           pom1=1.0d0/(pom*pom+1.0d0)
5810           etors=etors+vl1ij*pom1
5811           if (energy_dec) etors_ii=etors_ii+
5812      &                vl1ij*pom1
5813           pom=-pom*pom1*pom1
5814           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5815         enddo
5816 C Subtract the constant term
5817         etors=etors-v0(itori,itori1)
5818           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5819      &         'etor',i,etors_ii-v0(itori,itori1)
5820         if (lprn)
5821      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5822      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5823      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5824         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5825 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5826       enddo
5827 ! 6/20/98 - dihedral angle constraints
5828       edihcnstr=0.0d0
5829 c      do i=1,ndih_constr
5830       do i=idihconstr_start,idihconstr_end
5831         itori=idih_constr(i)
5832         phii=phi(itori)
5833         difi=pinorm(phii-phi0(i))
5834         if (difi.gt.drange(i)) then
5835           difi=difi-drange(i)
5836           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5837           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5838         else if (difi.lt.-drange(i)) then
5839           difi=difi+drange(i)
5840           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5841           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5842         else
5843           difi=0.0
5844         endif
5845 c        write (iout,*) "gloci", gloc(i-3,icg)
5846 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5847 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5848 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5849       enddo
5850 cd       write (iout,*) 'edihcnstr',edihcnstr
5851       return
5852       end
5853 c----------------------------------------------------------------------------
5854       subroutine etor_d(etors_d)
5855 C 6/23/01 Compute double torsional energy
5856       implicit real*8 (a-h,o-z)
5857       include 'DIMENSIONS'
5858       include 'COMMON.VAR'
5859       include 'COMMON.GEO'
5860       include 'COMMON.LOCAL'
5861       include 'COMMON.TORSION'
5862       include 'COMMON.INTERACT'
5863       include 'COMMON.DERIV'
5864       include 'COMMON.CHAIN'
5865       include 'COMMON.NAMES'
5866       include 'COMMON.IOUNITS'
5867       include 'COMMON.FFIELD'
5868       include 'COMMON.TORCNSTR'
5869       logical lprn
5870 C Set lprn=.true. for debugging
5871       lprn=.false.
5872 c     lprn=.true.
5873       etors_d=0.0D0
5874       do i=iphid_start,iphid_end
5875         itori=itortyp(itype(i-2))
5876         itori1=itortyp(itype(i-1))
5877         itori2=itortyp(itype(i))
5878         phii=phi(i)
5879         phii1=phi(i+1)
5880         gloci1=0.0D0
5881         gloci2=0.0D0
5882         do j=1,ntermd_1(itori,itori1,itori2)
5883           v1cij=v1c(1,j,itori,itori1,itori2)
5884           v1sij=v1s(1,j,itori,itori1,itori2)
5885           v2cij=v1c(2,j,itori,itori1,itori2)
5886           v2sij=v1s(2,j,itori,itori1,itori2)
5887           cosphi1=dcos(j*phii)
5888           sinphi1=dsin(j*phii)
5889           cosphi2=dcos(j*phii1)
5890           sinphi2=dsin(j*phii1)
5891           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5892      &     v2cij*cosphi2+v2sij*sinphi2
5893           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5894           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5895         enddo
5896         do k=2,ntermd_2(itori,itori1,itori2)
5897           do l=1,k-1
5898             v1cdij = v2c(k,l,itori,itori1,itori2)
5899             v2cdij = v2c(l,k,itori,itori1,itori2)
5900             v1sdij = v2s(k,l,itori,itori1,itori2)
5901             v2sdij = v2s(l,k,itori,itori1,itori2)
5902             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5903             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5904             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5905             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5906             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5907      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5908             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5909      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5910             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5911      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5912           enddo
5913         enddo
5914         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5915         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5916 c        write (iout,*) "gloci", gloc(i-3,icg)
5917       enddo
5918       return
5919       end
5920 #endif
5921 c------------------------------------------------------------------------------
5922       subroutine eback_sc_corr(esccor)
5923 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5924 c        conformational states; temporarily implemented as differences
5925 c        between UNRES torsional potentials (dependent on three types of
5926 c        residues) and the torsional potentials dependent on all 20 types
5927 c        of residues computed from AM1  energy surfaces of terminally-blocked
5928 c        amino-acid residues.
5929       implicit real*8 (a-h,o-z)
5930       include 'DIMENSIONS'
5931       include 'COMMON.VAR'
5932       include 'COMMON.GEO'
5933       include 'COMMON.LOCAL'
5934       include 'COMMON.TORSION'
5935       include 'COMMON.SCCOR'
5936       include 'COMMON.INTERACT'
5937       include 'COMMON.DERIV'
5938       include 'COMMON.CHAIN'
5939       include 'COMMON.NAMES'
5940       include 'COMMON.IOUNITS'
5941       include 'COMMON.FFIELD'
5942       include 'COMMON.CONTROL'
5943       logical lprn
5944 C Set lprn=.true. for debugging
5945       lprn=.false.
5946 c      lprn=.true.
5947 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
5948       esccor=0.0D0
5949       do i=itau_start,itau_end
5950         esccor_ii=0.0D0
5951         isccori=isccortyp(itype(i-2))
5952         isccori1=isccortyp(itype(i-1))
5953         phii=phi(i)
5954 cccc  Added 9 May 2012
5955 cc Tauangle is torsional engle depending on the value of first digit
5956 c(see comment below)
5957 cc Omicron is flat angle depending on the value of first digit
5958 c(see comment below)
5959
5960
5961         do intertyp=1,3 !intertyp
5962 cc Added 09 May 2012 (Adasko)
5963 cc  Intertyp means interaction type of backbone mainchain correlation:
5964 c   1 = SC...Ca...Ca...Ca
5965 c   2 = Ca...Ca...Ca...SC
5966 c   3 = SC...Ca...Ca...SCi
5967         gloci=0.0D0
5968         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5969      &      (itype(i-1).eq.10).or.(itype(i-2).eq.21).or.
5970      &      (itype(i-1).eq.21)))
5971      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5972      &     .or.(itype(i-2).eq.21)))
5973      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5974      &      (itype(i-1).eq.21)))) cycle
5975         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle
5976         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21))
5977      & cycle
5978         do j=1,nterm_sccor(isccori,isccori1)
5979           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5980           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5981           cosphi=dcos(j*tauangle(intertyp,i))
5982           sinphi=dsin(j*tauangle(intertyp,i))
5983           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5984           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5985         enddo
5986         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5987 c        write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
5988 c     &gloc_sc(intertyp,i-3,icg)
5989         if (lprn)
5990      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5991      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5992      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
5993      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
5994         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5995        enddo !intertyp
5996       enddo
5997 c        do i=1,nres
5998 c        write (iout,*) "W@T@F",  gloc_sc(1,i,icg),gloc(i,icg)
5999 c        enddo
6000       return
6001       end
6002 c----------------------------------------------------------------------------
6003       subroutine multibody(ecorr)
6004 C This subroutine calculates multi-body contributions to energy following
6005 C the idea of Skolnick et al. If side chains I and J make a contact and
6006 C at the same time side chains I+1 and J+1 make a contact, an extra
6007 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6008       implicit real*8 (a-h,o-z)
6009       include 'DIMENSIONS'
6010       include 'COMMON.IOUNITS'
6011       include 'COMMON.DERIV'
6012       include 'COMMON.INTERACT'
6013       include 'COMMON.CONTACTS'
6014       double precision gx(3),gx1(3)
6015       logical lprn
6016
6017 C Set lprn=.true. for debugging
6018       lprn=.false.
6019
6020       if (lprn) then
6021         write (iout,'(a)') 'Contact function values:'
6022         do i=nnt,nct-2
6023           write (iout,'(i2,20(1x,i2,f10.5))')
6024      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6025         enddo
6026       endif
6027       ecorr=0.0D0
6028       do i=nnt,nct
6029         do j=1,3
6030           gradcorr(j,i)=0.0D0
6031           gradxorr(j,i)=0.0D0
6032         enddo
6033       enddo
6034       do i=nnt,nct-2
6035
6036         DO ISHIFT = 3,4
6037
6038         i1=i+ishift
6039         num_conti=num_cont(i)
6040         num_conti1=num_cont(i1)
6041         do jj=1,num_conti
6042           j=jcont(jj,i)
6043           do kk=1,num_conti1
6044             j1=jcont(kk,i1)
6045             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6046 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6047 cd   &                   ' ishift=',ishift
6048 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6049 C The system gains extra energy.
6050               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6051             endif   ! j1==j+-ishift
6052           enddo     ! kk
6053         enddo       ! jj
6054
6055         ENDDO ! ISHIFT
6056
6057       enddo         ! i
6058       return
6059       end
6060 c------------------------------------------------------------------------------
6061       double precision function esccorr(i,j,k,l,jj,kk)
6062       implicit real*8 (a-h,o-z)
6063       include 'DIMENSIONS'
6064       include 'COMMON.IOUNITS'
6065       include 'COMMON.DERIV'
6066       include 'COMMON.INTERACT'
6067       include 'COMMON.CONTACTS'
6068       double precision gx(3),gx1(3)
6069       logical lprn
6070       lprn=.false.
6071       eij=facont(jj,i)
6072       ekl=facont(kk,k)
6073 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6074 C Calculate the multi-body contribution to energy.
6075 C Calculate multi-body contributions to the gradient.
6076 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6077 cd   & k,l,(gacont(m,kk,k),m=1,3)
6078       do m=1,3
6079         gx(m) =ekl*gacont(m,jj,i)
6080         gx1(m)=eij*gacont(m,kk,k)
6081         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6082         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6083         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6084         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6085       enddo
6086       do m=i,j-1
6087         do ll=1,3
6088           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6089         enddo
6090       enddo
6091       do m=k,l-1
6092         do ll=1,3
6093           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6094         enddo
6095       enddo
6096       esccorr=-eij*ekl
6097       return
6098       end
6099 c------------------------------------------------------------------------------
6100       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6101 C This subroutine calculates multi-body contributions to hydrogen-bonding
6102       implicit real*8 (a-h,o-z)
6103       include 'DIMENSIONS'
6104       include 'COMMON.IOUNITS'
6105 #ifdef MPI
6106       include "mpif.h"
6107       parameter (max_cont=maxconts)
6108       parameter (max_dim=26)
6109       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6110       double precision zapas(max_dim,maxconts,max_fg_procs),
6111      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6112       common /przechowalnia/ zapas
6113       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6114      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6115 #endif
6116       include 'COMMON.SETUP'
6117       include 'COMMON.FFIELD'
6118       include 'COMMON.DERIV'
6119       include 'COMMON.INTERACT'
6120       include 'COMMON.CONTACTS'
6121       include 'COMMON.CONTROL'
6122       include 'COMMON.LOCAL'
6123       double precision gx(3),gx1(3),time00
6124       logical lprn,ldone
6125
6126 C Set lprn=.true. for debugging
6127       lprn=.false.
6128 #ifdef MPI
6129       n_corr=0
6130       n_corr1=0
6131       if (nfgtasks.le.1) goto 30
6132       if (lprn) then
6133         write (iout,'(a)') 'Contact function values before RECEIVE:'
6134         do i=nnt,nct-2
6135           write (iout,'(2i3,50(1x,i2,f5.2))')
6136      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6137      &    j=1,num_cont_hb(i))
6138         enddo
6139       endif
6140       call flush(iout)
6141       do i=1,ntask_cont_from
6142         ncont_recv(i)=0
6143       enddo
6144       do i=1,ntask_cont_to
6145         ncont_sent(i)=0
6146       enddo
6147 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6148 c     & ntask_cont_to
6149 C Make the list of contacts to send to send to other procesors
6150 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6151 c      call flush(iout)
6152       do i=iturn3_start,iturn3_end
6153 c        write (iout,*) "make contact list turn3",i," num_cont",
6154 c     &    num_cont_hb(i)
6155         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6156       enddo
6157       do i=iturn4_start,iturn4_end
6158 c        write (iout,*) "make contact list turn4",i," num_cont",
6159 c     &   num_cont_hb(i)
6160         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6161       enddo
6162       do ii=1,nat_sent
6163         i=iat_sent(ii)
6164 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6165 c     &    num_cont_hb(i)
6166         do j=1,num_cont_hb(i)
6167         do k=1,4
6168           jjc=jcont_hb(j,i)
6169           iproc=iint_sent_local(k,jjc,ii)
6170 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6171           if (iproc.gt.0) then
6172             ncont_sent(iproc)=ncont_sent(iproc)+1
6173             nn=ncont_sent(iproc)
6174             zapas(1,nn,iproc)=i
6175             zapas(2,nn,iproc)=jjc
6176             zapas(3,nn,iproc)=facont_hb(j,i)
6177             zapas(4,nn,iproc)=ees0p(j,i)
6178             zapas(5,nn,iproc)=ees0m(j,i)
6179             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6180             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6181             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6182             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6183             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6184             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6185             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6186             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6187             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6188             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6189             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6190             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6191             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6192             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6193             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6194             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6195             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6196             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6197             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6198             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6199             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6200           endif
6201         enddo
6202         enddo
6203       enddo
6204       if (lprn) then
6205       write (iout,*)
6206      &  "Numbers of contacts to be sent to other processors",
6207      &  (ncont_sent(i),i=1,ntask_cont_to)
6208       write (iout,*) "Contacts sent"
6209       do ii=1,ntask_cont_to
6210         nn=ncont_sent(ii)
6211         iproc=itask_cont_to(ii)
6212         write (iout,*) nn," contacts to processor",iproc,
6213      &   " of CONT_TO_COMM group"
6214         do i=1,nn
6215           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6216         enddo
6217       enddo
6218       call flush(iout)
6219       endif
6220       CorrelType=477
6221       CorrelID=fg_rank+1
6222       CorrelType1=478
6223       CorrelID1=nfgtasks+fg_rank+1
6224       ireq=0
6225 C Receive the numbers of needed contacts from other processors
6226       do ii=1,ntask_cont_from
6227         iproc=itask_cont_from(ii)
6228         ireq=ireq+1
6229         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6230      &    FG_COMM,req(ireq),IERR)
6231       enddo
6232 c      write (iout,*) "IRECV ended"
6233 c      call flush(iout)
6234 C Send the number of contacts needed by other processors
6235       do ii=1,ntask_cont_to
6236         iproc=itask_cont_to(ii)
6237         ireq=ireq+1
6238         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6239      &    FG_COMM,req(ireq),IERR)
6240       enddo
6241 c      write (iout,*) "ISEND ended"
6242 c      write (iout,*) "number of requests (nn)",ireq
6243       call flush(iout)
6244       if (ireq.gt.0)
6245      &  call MPI_Waitall(ireq,req,status_array,ierr)
6246 c      write (iout,*)
6247 c     &  "Numbers of contacts to be received from other processors",
6248 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6249 c      call flush(iout)
6250 C Receive contacts
6251       ireq=0
6252       do ii=1,ntask_cont_from
6253         iproc=itask_cont_from(ii)
6254         nn=ncont_recv(ii)
6255 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6256 c     &   " of CONT_TO_COMM group"
6257         call flush(iout)
6258         if (nn.gt.0) then
6259           ireq=ireq+1
6260           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6261      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6262 c          write (iout,*) "ireq,req",ireq,req(ireq)
6263         endif
6264       enddo
6265 C Send the contacts to processors that need them
6266       do ii=1,ntask_cont_to
6267         iproc=itask_cont_to(ii)
6268         nn=ncont_sent(ii)
6269 c        write (iout,*) nn," contacts to processor",iproc,
6270 c     &   " of CONT_TO_COMM group"
6271         if (nn.gt.0) then
6272           ireq=ireq+1
6273           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6274      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6275 c          write (iout,*) "ireq,req",ireq,req(ireq)
6276 c          do i=1,nn
6277 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6278 c          enddo
6279         endif
6280       enddo
6281 c      write (iout,*) "number of requests (contacts)",ireq
6282 c      write (iout,*) "req",(req(i),i=1,4)
6283 c      call flush(iout)
6284       if (ireq.gt.0)
6285      & call MPI_Waitall(ireq,req,status_array,ierr)
6286       do iii=1,ntask_cont_from
6287         iproc=itask_cont_from(iii)
6288         nn=ncont_recv(iii)
6289         if (lprn) then
6290         write (iout,*) "Received",nn," contacts from processor",iproc,
6291      &   " of CONT_FROM_COMM group"
6292         call flush(iout)
6293         do i=1,nn
6294           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6295         enddo
6296         call flush(iout)
6297         endif
6298         do i=1,nn
6299           ii=zapas_recv(1,i,iii)
6300 c Flag the received contacts to prevent double-counting
6301           jj=-zapas_recv(2,i,iii)
6302 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6303 c          call flush(iout)
6304           nnn=num_cont_hb(ii)+1
6305           num_cont_hb(ii)=nnn
6306           jcont_hb(nnn,ii)=jj
6307           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6308           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6309           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6310           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6311           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6312           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6313           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6314           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6315           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6316           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6317           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6318           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6319           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6320           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6321           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6322           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6323           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6324           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6325           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6326           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6327           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6328           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6329           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6330           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6331         enddo
6332       enddo
6333       call flush(iout)
6334       if (lprn) then
6335         write (iout,'(a)') 'Contact function values after receive:'
6336         do i=nnt,nct-2
6337           write (iout,'(2i3,50(1x,i3,f5.2))')
6338      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6339      &    j=1,num_cont_hb(i))
6340         enddo
6341         call flush(iout)
6342       endif
6343    30 continue
6344 #endif
6345       if (lprn) then
6346         write (iout,'(a)') 'Contact function values:'
6347         do i=nnt,nct-2
6348           write (iout,'(2i3,50(1x,i3,f5.2))')
6349      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6350      &    j=1,num_cont_hb(i))
6351         enddo
6352       endif
6353       ecorr=0.0D0
6354 C Remove the loop below after debugging !!!
6355       do i=nnt,nct
6356         do j=1,3
6357           gradcorr(j,i)=0.0D0
6358           gradxorr(j,i)=0.0D0
6359         enddo
6360       enddo
6361 C Calculate the local-electrostatic correlation terms
6362       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6363         i1=i+1
6364         num_conti=num_cont_hb(i)
6365         num_conti1=num_cont_hb(i+1)
6366         do jj=1,num_conti
6367           j=jcont_hb(jj,i)
6368           jp=iabs(j)
6369           do kk=1,num_conti1
6370             j1=jcont_hb(kk,i1)
6371             jp1=iabs(j1)
6372 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6373 c     &         ' jj=',jj,' kk=',kk
6374             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6375      &          .or. j.lt.0 .and. j1.gt.0) .and.
6376      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6377 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6378 C The system gains extra energy.
6379               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6380               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6381      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6382               n_corr=n_corr+1
6383             else if (j1.eq.j) then
6384 C Contacts I-J and I-(J+1) occur simultaneously.
6385 C The system loses extra energy.
6386 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6387             endif
6388           enddo ! kk
6389           do kk=1,num_conti
6390             j1=jcont_hb(kk,i)
6391 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6392 c    &         ' jj=',jj,' kk=',kk
6393             if (j1.eq.j+1) then
6394 C Contacts I-J and (I+1)-J occur simultaneously.
6395 C The system loses extra energy.
6396 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6397             endif ! j1==j+1
6398           enddo ! kk
6399         enddo ! jj
6400       enddo ! i
6401       return
6402       end
6403 c------------------------------------------------------------------------------
6404       subroutine add_hb_contact(ii,jj,itask)
6405       implicit real*8 (a-h,o-z)
6406       include "DIMENSIONS"
6407       include "COMMON.IOUNITS"
6408       integer max_cont
6409       integer max_dim
6410       parameter (max_cont=maxconts)
6411       parameter (max_dim=26)
6412       include "COMMON.CONTACTS"
6413       double precision zapas(max_dim,maxconts,max_fg_procs),
6414      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6415       common /przechowalnia/ zapas
6416       integer i,j,ii,jj,iproc,itask(4),nn
6417 c      write (iout,*) "itask",itask
6418       do i=1,2
6419         iproc=itask(i)
6420         if (iproc.gt.0) then
6421           do j=1,num_cont_hb(ii)
6422             jjc=jcont_hb(j,ii)
6423 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6424             if (jjc.eq.jj) then
6425               ncont_sent(iproc)=ncont_sent(iproc)+1
6426               nn=ncont_sent(iproc)
6427               zapas(1,nn,iproc)=ii
6428               zapas(2,nn,iproc)=jjc
6429               zapas(3,nn,iproc)=facont_hb(j,ii)
6430               zapas(4,nn,iproc)=ees0p(j,ii)
6431               zapas(5,nn,iproc)=ees0m(j,ii)
6432               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6433               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6434               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6435               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6436               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6437               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6438               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6439               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6440               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6441               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6442               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6443               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6444               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6445               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6446               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6447               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6448               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6449               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6450               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6451               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6452               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6453               exit
6454             endif
6455           enddo
6456         endif
6457       enddo
6458       return
6459       end
6460 c------------------------------------------------------------------------------
6461       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6462      &  n_corr1)
6463 C This subroutine calculates multi-body contributions to hydrogen-bonding
6464       implicit real*8 (a-h,o-z)
6465       include 'DIMENSIONS'
6466       include 'COMMON.IOUNITS'
6467 #ifdef MPI
6468       include "mpif.h"
6469       parameter (max_cont=maxconts)
6470       parameter (max_dim=70)
6471       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6472       double precision zapas(max_dim,maxconts,max_fg_procs),
6473      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6474       common /przechowalnia/ zapas
6475       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6476      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6477 #endif
6478       include 'COMMON.SETUP'
6479       include 'COMMON.FFIELD'
6480       include 'COMMON.DERIV'
6481       include 'COMMON.LOCAL'
6482       include 'COMMON.INTERACT'
6483       include 'COMMON.CONTACTS'
6484       include 'COMMON.CHAIN'
6485       include 'COMMON.CONTROL'
6486       double precision gx(3),gx1(3)
6487       integer num_cont_hb_old(maxres)
6488       logical lprn,ldone
6489       double precision eello4,eello5,eelo6,eello_turn6
6490       external eello4,eello5,eello6,eello_turn6
6491 C Set lprn=.true. for debugging
6492       lprn=.false.
6493       eturn6=0.0d0
6494 #ifdef MPI
6495       do i=1,nres
6496         num_cont_hb_old(i)=num_cont_hb(i)
6497       enddo
6498       n_corr=0
6499       n_corr1=0
6500       if (nfgtasks.le.1) goto 30
6501       if (lprn) then
6502         write (iout,'(a)') 'Contact function values before RECEIVE:'
6503         do i=nnt,nct-2
6504           write (iout,'(2i3,50(1x,i2,f5.2))')
6505      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6506      &    j=1,num_cont_hb(i))
6507         enddo
6508       endif
6509       call flush(iout)
6510       do i=1,ntask_cont_from
6511         ncont_recv(i)=0
6512       enddo
6513       do i=1,ntask_cont_to
6514         ncont_sent(i)=0
6515       enddo
6516 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6517 c     & ntask_cont_to
6518 C Make the list of contacts to send to send to other procesors
6519       do i=iturn3_start,iturn3_end
6520 c        write (iout,*) "make contact list turn3",i," num_cont",
6521 c     &    num_cont_hb(i)
6522         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6523       enddo
6524       do i=iturn4_start,iturn4_end
6525 c        write (iout,*) "make contact list turn4",i," num_cont",
6526 c     &   num_cont_hb(i)
6527         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6528       enddo
6529       do ii=1,nat_sent
6530         i=iat_sent(ii)
6531 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6532 c     &    num_cont_hb(i)
6533         do j=1,num_cont_hb(i)
6534         do k=1,4
6535           jjc=jcont_hb(j,i)
6536           iproc=iint_sent_local(k,jjc,ii)
6537 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6538           if (iproc.ne.0) then
6539             ncont_sent(iproc)=ncont_sent(iproc)+1
6540             nn=ncont_sent(iproc)
6541             zapas(1,nn,iproc)=i
6542             zapas(2,nn,iproc)=jjc
6543             zapas(3,nn,iproc)=d_cont(j,i)
6544             ind=3
6545             do kk=1,3
6546               ind=ind+1
6547               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6548             enddo
6549             do kk=1,2
6550               do ll=1,2
6551                 ind=ind+1
6552                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6553               enddo
6554             enddo
6555             do jj=1,5
6556               do kk=1,3
6557                 do ll=1,2
6558                   do mm=1,2
6559                     ind=ind+1
6560                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6561                   enddo
6562                 enddo
6563               enddo
6564             enddo
6565           endif
6566         enddo
6567         enddo
6568       enddo
6569       if (lprn) then
6570       write (iout,*)
6571      &  "Numbers of contacts to be sent to other processors",
6572      &  (ncont_sent(i),i=1,ntask_cont_to)
6573       write (iout,*) "Contacts sent"
6574       do ii=1,ntask_cont_to
6575         nn=ncont_sent(ii)
6576         iproc=itask_cont_to(ii)
6577         write (iout,*) nn," contacts to processor",iproc,
6578      &   " of CONT_TO_COMM group"
6579         do i=1,nn
6580           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6581         enddo
6582       enddo
6583       call flush(iout)
6584       endif
6585       CorrelType=477
6586       CorrelID=fg_rank+1
6587       CorrelType1=478
6588       CorrelID1=nfgtasks+fg_rank+1
6589       ireq=0
6590 C Receive the numbers of needed contacts from other processors
6591       do ii=1,ntask_cont_from
6592         iproc=itask_cont_from(ii)
6593         ireq=ireq+1
6594         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6595      &    FG_COMM,req(ireq),IERR)
6596       enddo
6597 c      write (iout,*) "IRECV ended"
6598 c      call flush(iout)
6599 C Send the number of contacts needed by other processors
6600       do ii=1,ntask_cont_to
6601         iproc=itask_cont_to(ii)
6602         ireq=ireq+1
6603         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6604      &    FG_COMM,req(ireq),IERR)
6605       enddo
6606 c      write (iout,*) "ISEND ended"
6607 c      write (iout,*) "number of requests (nn)",ireq
6608       call flush(iout)
6609       if (ireq.gt.0)
6610      &  call MPI_Waitall(ireq,req,status_array,ierr)
6611 c      write (iout,*)
6612 c     &  "Numbers of contacts to be received from other processors",
6613 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6614 c      call flush(iout)
6615 C Receive contacts
6616       ireq=0
6617       do ii=1,ntask_cont_from
6618         iproc=itask_cont_from(ii)
6619         nn=ncont_recv(ii)
6620 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6621 c     &   " of CONT_TO_COMM group"
6622         call flush(iout)
6623         if (nn.gt.0) then
6624           ireq=ireq+1
6625           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6626      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6627 c          write (iout,*) "ireq,req",ireq,req(ireq)
6628         endif
6629       enddo
6630 C Send the contacts to processors that need them
6631       do ii=1,ntask_cont_to
6632         iproc=itask_cont_to(ii)
6633         nn=ncont_sent(ii)
6634 c        write (iout,*) nn," contacts to processor",iproc,
6635 c     &   " of CONT_TO_COMM group"
6636         if (nn.gt.0) then
6637           ireq=ireq+1
6638           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6639      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6640 c          write (iout,*) "ireq,req",ireq,req(ireq)
6641 c          do i=1,nn
6642 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6643 c          enddo
6644         endif
6645       enddo
6646 c      write (iout,*) "number of requests (contacts)",ireq
6647 c      write (iout,*) "req",(req(i),i=1,4)
6648 c      call flush(iout)
6649       if (ireq.gt.0)
6650      & call MPI_Waitall(ireq,req,status_array,ierr)
6651       do iii=1,ntask_cont_from
6652         iproc=itask_cont_from(iii)
6653         nn=ncont_recv(iii)
6654         if (lprn) then
6655         write (iout,*) "Received",nn," contacts from processor",iproc,
6656      &   " of CONT_FROM_COMM group"
6657         call flush(iout)
6658         do i=1,nn
6659           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6660         enddo
6661         call flush(iout)
6662         endif
6663         do i=1,nn
6664           ii=zapas_recv(1,i,iii)
6665 c Flag the received contacts to prevent double-counting
6666           jj=-zapas_recv(2,i,iii)
6667 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6668 c          call flush(iout)
6669           nnn=num_cont_hb(ii)+1
6670           num_cont_hb(ii)=nnn
6671           jcont_hb(nnn,ii)=jj
6672           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6673           ind=3
6674           do kk=1,3
6675             ind=ind+1
6676             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6677           enddo
6678           do kk=1,2
6679             do ll=1,2
6680               ind=ind+1
6681               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6682             enddo
6683           enddo
6684           do jj=1,5
6685             do kk=1,3
6686               do ll=1,2
6687                 do mm=1,2
6688                   ind=ind+1
6689                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6690                 enddo
6691               enddo
6692             enddo
6693           enddo
6694         enddo
6695       enddo
6696       call flush(iout)
6697       if (lprn) then
6698         write (iout,'(a)') 'Contact function values after receive:'
6699         do i=nnt,nct-2
6700           write (iout,'(2i3,50(1x,i3,5f6.3))')
6701      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6702      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6703         enddo
6704         call flush(iout)
6705       endif
6706    30 continue
6707 #endif
6708       if (lprn) then
6709         write (iout,'(a)') 'Contact function values:'
6710         do i=nnt,nct-2
6711           write (iout,'(2i3,50(1x,i2,5f6.3))')
6712      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6713      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6714         enddo
6715       endif
6716       ecorr=0.0D0
6717       ecorr5=0.0d0
6718       ecorr6=0.0d0
6719 C Remove the loop below after debugging !!!
6720       do i=nnt,nct
6721         do j=1,3
6722           gradcorr(j,i)=0.0D0
6723           gradxorr(j,i)=0.0D0
6724         enddo
6725       enddo
6726 C Calculate the dipole-dipole interaction energies
6727       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6728       do i=iatel_s,iatel_e+1
6729         num_conti=num_cont_hb(i)
6730         do jj=1,num_conti
6731           j=jcont_hb(jj,i)
6732 #ifdef MOMENT
6733           call dipole(i,j,jj)
6734 #endif
6735         enddo
6736       enddo
6737       endif
6738 C Calculate the local-electrostatic correlation terms
6739 c                write (iout,*) "gradcorr5 in eello5 before loop"
6740 c                do iii=1,nres
6741 c                  write (iout,'(i5,3f10.5)')
6742 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6743 c                enddo
6744       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6745 c        write (iout,*) "corr loop i",i
6746         i1=i+1
6747         num_conti=num_cont_hb(i)
6748         num_conti1=num_cont_hb(i+1)
6749         do jj=1,num_conti
6750           j=jcont_hb(jj,i)
6751           jp=iabs(j)
6752           do kk=1,num_conti1
6753             j1=jcont_hb(kk,i1)
6754             jp1=iabs(j1)
6755 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6756 c     &         ' jj=',jj,' kk=',kk
6757 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6758             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6759      &          .or. j.lt.0 .and. j1.gt.0) .and.
6760      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6761 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6762 C The system gains extra energy.
6763               n_corr=n_corr+1
6764               sqd1=dsqrt(d_cont(jj,i))
6765               sqd2=dsqrt(d_cont(kk,i1))
6766               sred_geom = sqd1*sqd2
6767               IF (sred_geom.lt.cutoff_corr) THEN
6768                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6769      &            ekont,fprimcont)
6770 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6771 cd     &         ' jj=',jj,' kk=',kk
6772                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6773                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6774                 do l=1,3
6775                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6776                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6777                 enddo
6778                 n_corr1=n_corr1+1
6779 cd               write (iout,*) 'sred_geom=',sred_geom,
6780 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6781 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6782 cd               write (iout,*) "g_contij",g_contij
6783 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6784 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6785                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6786                 if (wcorr4.gt.0.0d0)
6787      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6788                   if (energy_dec.and.wcorr4.gt.0.0d0)
6789      1                 write (iout,'(a6,4i5,0pf7.3)')
6790      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6791 c                write (iout,*) "gradcorr5 before eello5"
6792 c                do iii=1,nres
6793 c                  write (iout,'(i5,3f10.5)')
6794 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6795 c                enddo
6796                 if (wcorr5.gt.0.0d0)
6797      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6798 c                write (iout,*) "gradcorr5 after eello5"
6799 c                do iii=1,nres
6800 c                  write (iout,'(i5,3f10.5)')
6801 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6802 c                enddo
6803                   if (energy_dec.and.wcorr5.gt.0.0d0)
6804      1                 write (iout,'(a6,4i5,0pf7.3)')
6805      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6806 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6807 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6808                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6809      &               .or. wturn6.eq.0.0d0))then
6810 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6811                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6812                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6813      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6814 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6815 cd     &            'ecorr6=',ecorr6
6816 cd                write (iout,'(4e15.5)') sred_geom,
6817 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6818 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6819 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6820                 else if (wturn6.gt.0.0d0
6821      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6822 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6823                   eturn6=eturn6+eello_turn6(i,jj,kk)
6824                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6825      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6826 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6827                 endif
6828               ENDIF
6829 1111          continue
6830             endif
6831           enddo ! kk
6832         enddo ! jj
6833       enddo ! i
6834       do i=1,nres
6835         num_cont_hb(i)=num_cont_hb_old(i)
6836       enddo
6837 c                write (iout,*) "gradcorr5 in eello5"
6838 c                do iii=1,nres
6839 c                  write (iout,'(i5,3f10.5)')
6840 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6841 c                enddo
6842       return
6843       end
6844 c------------------------------------------------------------------------------
6845       subroutine add_hb_contact_eello(ii,jj,itask)
6846       implicit real*8 (a-h,o-z)
6847       include "DIMENSIONS"
6848       include "COMMON.IOUNITS"
6849       integer max_cont
6850       integer max_dim
6851       parameter (max_cont=maxconts)
6852       parameter (max_dim=70)
6853       include "COMMON.CONTACTS"
6854       double precision zapas(max_dim,maxconts,max_fg_procs),
6855      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6856       common /przechowalnia/ zapas
6857       integer i,j,ii,jj,iproc,itask(4),nn
6858 c      write (iout,*) "itask",itask
6859       do i=1,2
6860         iproc=itask(i)
6861         if (iproc.gt.0) then
6862           do j=1,num_cont_hb(ii)
6863             jjc=jcont_hb(j,ii)
6864 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6865             if (jjc.eq.jj) then
6866               ncont_sent(iproc)=ncont_sent(iproc)+1
6867               nn=ncont_sent(iproc)
6868               zapas(1,nn,iproc)=ii
6869               zapas(2,nn,iproc)=jjc
6870               zapas(3,nn,iproc)=d_cont(j,ii)
6871               ind=3
6872               do kk=1,3
6873                 ind=ind+1
6874                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6875               enddo
6876               do kk=1,2
6877                 do ll=1,2
6878                   ind=ind+1
6879                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6880                 enddo
6881               enddo
6882               do jj=1,5
6883                 do kk=1,3
6884                   do ll=1,2
6885                     do mm=1,2
6886                       ind=ind+1
6887                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6888                     enddo
6889                   enddo
6890                 enddo
6891               enddo
6892               exit
6893             endif
6894           enddo
6895         endif
6896       enddo
6897       return
6898       end
6899 c------------------------------------------------------------------------------
6900       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6901       implicit real*8 (a-h,o-z)
6902       include 'DIMENSIONS'
6903       include 'COMMON.IOUNITS'
6904       include 'COMMON.DERIV'
6905       include 'COMMON.INTERACT'
6906       include 'COMMON.CONTACTS'
6907       double precision gx(3),gx1(3)
6908       logical lprn
6909       lprn=.false.
6910       eij=facont_hb(jj,i)
6911       ekl=facont_hb(kk,k)
6912       ees0pij=ees0p(jj,i)
6913       ees0pkl=ees0p(kk,k)
6914       ees0mij=ees0m(jj,i)
6915       ees0mkl=ees0m(kk,k)
6916       ekont=eij*ekl
6917       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6918 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6919 C Following 4 lines for diagnostics.
6920 cd    ees0pkl=0.0D0
6921 cd    ees0pij=1.0D0
6922 cd    ees0mkl=0.0D0
6923 cd    ees0mij=1.0D0
6924 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6925 c     & 'Contacts ',i,j,
6926 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6927 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6928 c     & 'gradcorr_long'
6929 C Calculate the multi-body contribution to energy.
6930 c      ecorr=ecorr+ekont*ees
6931 C Calculate multi-body contributions to the gradient.
6932       coeffpees0pij=coeffp*ees0pij
6933       coeffmees0mij=coeffm*ees0mij
6934       coeffpees0pkl=coeffp*ees0pkl
6935       coeffmees0mkl=coeffm*ees0mkl
6936       do ll=1,3
6937 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6938         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6939      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6940      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6941         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6942      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6943      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6944 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6945         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6946      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6947      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6948         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6949      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6950      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6951         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6952      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6953      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6954         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6955         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6956         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6957      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6958      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6959         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6960         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6961 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6962       enddo
6963 c      write (iout,*)
6964 cgrad      do m=i+1,j-1
6965 cgrad        do ll=1,3
6966 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6967 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6968 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6969 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6970 cgrad        enddo
6971 cgrad      enddo
6972 cgrad      do m=k+1,l-1
6973 cgrad        do ll=1,3
6974 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6975 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6976 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6977 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6978 cgrad        enddo
6979 cgrad      enddo
6980 c      write (iout,*) "ehbcorr",ekont*ees
6981       ehbcorr=ekont*ees
6982       return
6983       end
6984 #ifdef MOMENT
6985 C---------------------------------------------------------------------------
6986       subroutine dipole(i,j,jj)
6987       implicit real*8 (a-h,o-z)
6988       include 'DIMENSIONS'
6989       include 'COMMON.IOUNITS'
6990       include 'COMMON.CHAIN'
6991       include 'COMMON.FFIELD'
6992       include 'COMMON.DERIV'
6993       include 'COMMON.INTERACT'
6994       include 'COMMON.CONTACTS'
6995       include 'COMMON.TORSION'
6996       include 'COMMON.VAR'
6997       include 'COMMON.GEO'
6998       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6999      &  auxmat(2,2)
7000       iti1 = itortyp(itype(i+1))
7001       if (j.lt.nres-1) then
7002         itj1 = itortyp(itype(j+1))
7003       else
7004         itj1=ntortyp+1
7005       endif
7006       do iii=1,2
7007         dipi(iii,1)=Ub2(iii,i)
7008         dipderi(iii)=Ub2der(iii,i)
7009         dipi(iii,2)=b1(iii,iti1)
7010         dipj(iii,1)=Ub2(iii,j)
7011         dipderj(iii)=Ub2der(iii,j)
7012         dipj(iii,2)=b1(iii,itj1)
7013       enddo
7014       kkk=0
7015       do iii=1,2
7016         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7017         do jjj=1,2
7018           kkk=kkk+1
7019           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7020         enddo
7021       enddo
7022       do kkk=1,5
7023         do lll=1,3
7024           mmm=0
7025           do iii=1,2
7026             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7027      &        auxvec(1))
7028             do jjj=1,2
7029               mmm=mmm+1
7030               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7031             enddo
7032           enddo
7033         enddo
7034       enddo
7035       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7036       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7037       do iii=1,2
7038         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7039       enddo
7040       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7041       do iii=1,2
7042         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7043       enddo
7044       return
7045       end
7046 #endif
7047 C---------------------------------------------------------------------------
7048       subroutine calc_eello(i,j,k,l,jj,kk)
7049 C
7050 C This subroutine computes matrices and vectors needed to calculate
7051 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7052 C
7053       implicit real*8 (a-h,o-z)
7054       include 'DIMENSIONS'
7055       include 'COMMON.IOUNITS'
7056       include 'COMMON.CHAIN'
7057       include 'COMMON.DERIV'
7058       include 'COMMON.INTERACT'
7059       include 'COMMON.CONTACTS'
7060       include 'COMMON.TORSION'
7061       include 'COMMON.VAR'
7062       include 'COMMON.GEO'
7063       include 'COMMON.FFIELD'
7064       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7065      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7066       logical lprn
7067       common /kutas/ lprn
7068 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7069 cd     & ' jj=',jj,' kk=',kk
7070 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7071 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7072 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7073       do iii=1,2
7074         do jjj=1,2
7075           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7076           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7077         enddo
7078       enddo
7079       call transpose2(aa1(1,1),aa1t(1,1))
7080       call transpose2(aa2(1,1),aa2t(1,1))
7081       do kkk=1,5
7082         do lll=1,3
7083           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7084      &      aa1tder(1,1,lll,kkk))
7085           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7086      &      aa2tder(1,1,lll,kkk))
7087         enddo
7088       enddo
7089       if (l.eq.j+1) then
7090 C parallel orientation of the two CA-CA-CA frames.
7091         if (i.gt.1) then
7092           iti=itortyp(itype(i))
7093         else
7094           iti=ntortyp+1
7095         endif
7096         itk1=itortyp(itype(k+1))
7097         itj=itortyp(itype(j))
7098         if (l.lt.nres-1) then
7099           itl1=itortyp(itype(l+1))
7100         else
7101           itl1=ntortyp+1
7102         endif
7103 C A1 kernel(j+1) A2T
7104 cd        do iii=1,2
7105 cd          write (iout,'(3f10.5,5x,3f10.5)')
7106 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7107 cd        enddo
7108         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7109      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7110      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7111 C Following matrices are needed only for 6-th order cumulants
7112         IF (wcorr6.gt.0.0d0) THEN
7113         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7114      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7115      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7116         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7117      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7118      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7119      &   ADtEAderx(1,1,1,1,1,1))
7120         lprn=.false.
7121         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7122      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7123      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7124      &   ADtEA1derx(1,1,1,1,1,1))
7125         ENDIF
7126 C End 6-th order cumulants
7127 cd        lprn=.false.
7128 cd        if (lprn) then
7129 cd        write (2,*) 'In calc_eello6'
7130 cd        do iii=1,2
7131 cd          write (2,*) 'iii=',iii
7132 cd          do kkk=1,5
7133 cd            write (2,*) 'kkk=',kkk
7134 cd            do jjj=1,2
7135 cd              write (2,'(3(2f10.5),5x)')
7136 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7137 cd            enddo
7138 cd          enddo
7139 cd        enddo
7140 cd        endif
7141         call transpose2(EUgder(1,1,k),auxmat(1,1))
7142         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7143         call transpose2(EUg(1,1,k),auxmat(1,1))
7144         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7145         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7146         do iii=1,2
7147           do kkk=1,5
7148             do lll=1,3
7149               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7150      &          EAEAderx(1,1,lll,kkk,iii,1))
7151             enddo
7152           enddo
7153         enddo
7154 C A1T kernel(i+1) A2
7155         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7156      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7157      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7158 C Following matrices are needed only for 6-th order cumulants
7159         IF (wcorr6.gt.0.0d0) THEN
7160         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7161      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7162      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7163         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7164      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7165      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7166      &   ADtEAderx(1,1,1,1,1,2))
7167         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7168      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7169      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7170      &   ADtEA1derx(1,1,1,1,1,2))
7171         ENDIF
7172 C End 6-th order cumulants
7173         call transpose2(EUgder(1,1,l),auxmat(1,1))
7174         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7175         call transpose2(EUg(1,1,l),auxmat(1,1))
7176         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7177         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7178         do iii=1,2
7179           do kkk=1,5
7180             do lll=1,3
7181               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7182      &          EAEAderx(1,1,lll,kkk,iii,2))
7183             enddo
7184           enddo
7185         enddo
7186 C AEAb1 and AEAb2
7187 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7188 C They are needed only when the fifth- or the sixth-order cumulants are
7189 C indluded.
7190         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7191         call transpose2(AEA(1,1,1),auxmat(1,1))
7192         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7193         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7194         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7195         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7196         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7197         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7198         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7199         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7200         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7201         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7202         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7203         call transpose2(AEA(1,1,2),auxmat(1,1))
7204         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7205         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7206         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7207         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7208         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7209         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7210         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7211         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7212         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7213         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7214         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7215 C Calculate the Cartesian derivatives of the vectors.
7216         do iii=1,2
7217           do kkk=1,5
7218             do lll=1,3
7219               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7220               call matvec2(auxmat(1,1),b1(1,iti),
7221      &          AEAb1derx(1,lll,kkk,iii,1,1))
7222               call matvec2(auxmat(1,1),Ub2(1,i),
7223      &          AEAb2derx(1,lll,kkk,iii,1,1))
7224               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7225      &          AEAb1derx(1,lll,kkk,iii,2,1))
7226               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7227      &          AEAb2derx(1,lll,kkk,iii,2,1))
7228               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7229               call matvec2(auxmat(1,1),b1(1,itj),
7230      &          AEAb1derx(1,lll,kkk,iii,1,2))
7231               call matvec2(auxmat(1,1),Ub2(1,j),
7232      &          AEAb2derx(1,lll,kkk,iii,1,2))
7233               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7234      &          AEAb1derx(1,lll,kkk,iii,2,2))
7235               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7236      &          AEAb2derx(1,lll,kkk,iii,2,2))
7237             enddo
7238           enddo
7239         enddo
7240         ENDIF
7241 C End vectors
7242       else
7243 C Antiparallel orientation of the two CA-CA-CA frames.
7244         if (i.gt.1) then
7245           iti=itortyp(itype(i))
7246         else
7247           iti=ntortyp+1
7248         endif
7249         itk1=itortyp(itype(k+1))
7250         itl=itortyp(itype(l))
7251         itj=itortyp(itype(j))
7252         if (j.lt.nres-1) then
7253           itj1=itortyp(itype(j+1))
7254         else
7255           itj1=ntortyp+1
7256         endif
7257 C A2 kernel(j-1)T A1T
7258         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7259      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7260      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7261 C Following matrices are needed only for 6-th order cumulants
7262         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7263      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7264         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7265      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7266      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7267         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7268      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7269      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7270      &   ADtEAderx(1,1,1,1,1,1))
7271         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7272      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7273      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7274      &   ADtEA1derx(1,1,1,1,1,1))
7275         ENDIF
7276 C End 6-th order cumulants
7277         call transpose2(EUgder(1,1,k),auxmat(1,1))
7278         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7279         call transpose2(EUg(1,1,k),auxmat(1,1))
7280         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7281         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7282         do iii=1,2
7283           do kkk=1,5
7284             do lll=1,3
7285               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7286      &          EAEAderx(1,1,lll,kkk,iii,1))
7287             enddo
7288           enddo
7289         enddo
7290 C A2T kernel(i+1)T A1
7291         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7292      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7293      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7294 C Following matrices are needed only for 6-th order cumulants
7295         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7296      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7297         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7298      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7299      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7300         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7301      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7302      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7303      &   ADtEAderx(1,1,1,1,1,2))
7304         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7305      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7306      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7307      &   ADtEA1derx(1,1,1,1,1,2))
7308         ENDIF
7309 C End 6-th order cumulants
7310         call transpose2(EUgder(1,1,j),auxmat(1,1))
7311         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7312         call transpose2(EUg(1,1,j),auxmat(1,1))
7313         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7314         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7315         do iii=1,2
7316           do kkk=1,5
7317             do lll=1,3
7318               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7319      &          EAEAderx(1,1,lll,kkk,iii,2))
7320             enddo
7321           enddo
7322         enddo
7323 C AEAb1 and AEAb2
7324 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7325 C They are needed only when the fifth- or the sixth-order cumulants are
7326 C indluded.
7327         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7328      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7329         call transpose2(AEA(1,1,1),auxmat(1,1))
7330         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7331         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7332         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7333         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7334         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7335         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7336         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7337         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7338         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7339         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7340         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7341         call transpose2(AEA(1,1,2),auxmat(1,1))
7342         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7343         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7344         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7345         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7346         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7347         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7348         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7349         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7350         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7351         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7352         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7353 C Calculate the Cartesian derivatives of the vectors.
7354         do iii=1,2
7355           do kkk=1,5
7356             do lll=1,3
7357               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7358               call matvec2(auxmat(1,1),b1(1,iti),
7359      &          AEAb1derx(1,lll,kkk,iii,1,1))
7360               call matvec2(auxmat(1,1),Ub2(1,i),
7361      &          AEAb2derx(1,lll,kkk,iii,1,1))
7362               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7363      &          AEAb1derx(1,lll,kkk,iii,2,1))
7364               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7365      &          AEAb2derx(1,lll,kkk,iii,2,1))
7366               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7367               call matvec2(auxmat(1,1),b1(1,itl),
7368      &          AEAb1derx(1,lll,kkk,iii,1,2))
7369               call matvec2(auxmat(1,1),Ub2(1,l),
7370      &          AEAb2derx(1,lll,kkk,iii,1,2))
7371               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7372      &          AEAb1derx(1,lll,kkk,iii,2,2))
7373               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7374      &          AEAb2derx(1,lll,kkk,iii,2,2))
7375             enddo
7376           enddo
7377         enddo
7378         ENDIF
7379 C End vectors
7380       endif
7381       return
7382       end
7383 C---------------------------------------------------------------------------
7384       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7385      &  KK,KKderg,AKA,AKAderg,AKAderx)
7386       implicit none
7387       integer nderg
7388       logical transp
7389       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7390      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7391      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7392       integer iii,kkk,lll
7393       integer jjj,mmm
7394       logical lprn
7395       common /kutas/ lprn
7396       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7397       do iii=1,nderg
7398         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7399      &    AKAderg(1,1,iii))
7400       enddo
7401 cd      if (lprn) write (2,*) 'In kernel'
7402       do kkk=1,5
7403 cd        if (lprn) write (2,*) 'kkk=',kkk
7404         do lll=1,3
7405           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7406      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7407 cd          if (lprn) then
7408 cd            write (2,*) 'lll=',lll
7409 cd            write (2,*) 'iii=1'
7410 cd            do jjj=1,2
7411 cd              write (2,'(3(2f10.5),5x)')
7412 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7413 cd            enddo
7414 cd          endif
7415           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7416      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7417 cd          if (lprn) then
7418 cd            write (2,*) 'lll=',lll
7419 cd            write (2,*) 'iii=2'
7420 cd            do jjj=1,2
7421 cd              write (2,'(3(2f10.5),5x)')
7422 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7423 cd            enddo
7424 cd          endif
7425         enddo
7426       enddo
7427       return
7428       end
7429 C---------------------------------------------------------------------------
7430       double precision function eello4(i,j,k,l,jj,kk)
7431       implicit real*8 (a-h,o-z)
7432       include 'DIMENSIONS'
7433       include 'COMMON.IOUNITS'
7434       include 'COMMON.CHAIN'
7435       include 'COMMON.DERIV'
7436       include 'COMMON.INTERACT'
7437       include 'COMMON.CONTACTS'
7438       include 'COMMON.TORSION'
7439       include 'COMMON.VAR'
7440       include 'COMMON.GEO'
7441       double precision pizda(2,2),ggg1(3),ggg2(3)
7442 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7443 cd        eello4=0.0d0
7444 cd        return
7445 cd      endif
7446 cd      print *,'eello4:',i,j,k,l,jj,kk
7447 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7448 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7449 cold      eij=facont_hb(jj,i)
7450 cold      ekl=facont_hb(kk,k)
7451 cold      ekont=eij*ekl
7452       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7453 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7454       gcorr_loc(k-1)=gcorr_loc(k-1)
7455      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7456       if (l.eq.j+1) then
7457         gcorr_loc(l-1)=gcorr_loc(l-1)
7458      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7459       else
7460         gcorr_loc(j-1)=gcorr_loc(j-1)
7461      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7462       endif
7463       do iii=1,2
7464         do kkk=1,5
7465           do lll=1,3
7466             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7467      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7468 cd            derx(lll,kkk,iii)=0.0d0
7469           enddo
7470         enddo
7471       enddo
7472 cd      gcorr_loc(l-1)=0.0d0
7473 cd      gcorr_loc(j-1)=0.0d0
7474 cd      gcorr_loc(k-1)=0.0d0
7475 cd      eel4=1.0d0
7476 cd      write (iout,*)'Contacts have occurred for peptide groups',
7477 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7478 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7479       if (j.lt.nres-1) then
7480         j1=j+1
7481         j2=j-1
7482       else
7483         j1=j-1
7484         j2=j-2
7485       endif
7486       if (l.lt.nres-1) then
7487         l1=l+1
7488         l2=l-1
7489       else
7490         l1=l-1
7491         l2=l-2
7492       endif
7493       do ll=1,3
7494 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7495 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7496         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7497         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7498 cgrad        ghalf=0.5d0*ggg1(ll)
7499         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7500         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7501         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7502         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7503         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7504         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7505 cgrad        ghalf=0.5d0*ggg2(ll)
7506         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7507         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7508         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7509         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7510         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7511         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7512       enddo
7513 cgrad      do m=i+1,j-1
7514 cgrad        do ll=1,3
7515 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7516 cgrad        enddo
7517 cgrad      enddo
7518 cgrad      do m=k+1,l-1
7519 cgrad        do ll=1,3
7520 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7521 cgrad        enddo
7522 cgrad      enddo
7523 cgrad      do m=i+2,j2
7524 cgrad        do ll=1,3
7525 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7526 cgrad        enddo
7527 cgrad      enddo
7528 cgrad      do m=k+2,l2
7529 cgrad        do ll=1,3
7530 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7531 cgrad        enddo
7532 cgrad      enddo
7533 cd      do iii=1,nres-3
7534 cd        write (2,*) iii,gcorr_loc(iii)
7535 cd      enddo
7536       eello4=ekont*eel4
7537 cd      write (2,*) 'ekont',ekont
7538 cd      write (iout,*) 'eello4',ekont*eel4
7539       return
7540       end
7541 C---------------------------------------------------------------------------
7542       double precision function eello5(i,j,k,l,jj,kk)
7543       implicit real*8 (a-h,o-z)
7544       include 'DIMENSIONS'
7545       include 'COMMON.IOUNITS'
7546       include 'COMMON.CHAIN'
7547       include 'COMMON.DERIV'
7548       include 'COMMON.INTERACT'
7549       include 'COMMON.CONTACTS'
7550       include 'COMMON.TORSION'
7551       include 'COMMON.VAR'
7552       include 'COMMON.GEO'
7553       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7554       double precision ggg1(3),ggg2(3)
7555 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7556 C                                                                              C
7557 C                            Parallel chains                                   C
7558 C                                                                              C
7559 C          o             o                   o             o                   C
7560 C         /l\           / \             \   / \           / \   /              C
7561 C        /   \         /   \             \ /   \         /   \ /               C
7562 C       j| o |l1       | 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                            Antiparallel chains                               C
7571 C                                                                              C
7572 C          o             o                   o             o                   C
7573 C         /j\           / \             \   / \           / \   /              C
7574 C        /   \         /   \             \ /   \         /   \ /               C
7575 C      j1| o |l        | o |              o| o |         | o |o                C
7576 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7577 C      \i/   \         /   \ /             /   \         /   \                 C
7578 C       o     k1            o                                                  C
7579 C         (I)          (II)                (III)          (IV)                 C
7580 C                                                                              C
7581 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7582 C                                                                              C
7583 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7584 C                                                                              C
7585 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7586 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7587 cd        eello5=0.0d0
7588 cd        return
7589 cd      endif
7590 cd      write (iout,*)
7591 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7592 cd     &   ' and',k,l
7593       itk=itortyp(itype(k))
7594       itl=itortyp(itype(l))
7595       itj=itortyp(itype(j))
7596       eello5_1=0.0d0
7597       eello5_2=0.0d0
7598       eello5_3=0.0d0
7599       eello5_4=0.0d0
7600 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7601 cd     &   eel5_3_num,eel5_4_num)
7602       do iii=1,2
7603         do kkk=1,5
7604           do lll=1,3
7605             derx(lll,kkk,iii)=0.0d0
7606           enddo
7607         enddo
7608       enddo
7609 cd      eij=facont_hb(jj,i)
7610 cd      ekl=facont_hb(kk,k)
7611 cd      ekont=eij*ekl
7612 cd      write (iout,*)'Contacts have occurred for peptide groups',
7613 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7614 cd      goto 1111
7615 C Contribution from the graph I.
7616 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7617 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7618       call transpose2(EUg(1,1,k),auxmat(1,1))
7619       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7620       vv(1)=pizda(1,1)-pizda(2,2)
7621       vv(2)=pizda(1,2)+pizda(2,1)
7622       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7623      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7624 C Explicit gradient in virtual-dihedral angles.
7625       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7626      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7627      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7628       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7629       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7630       vv(1)=pizda(1,1)-pizda(2,2)
7631       vv(2)=pizda(1,2)+pizda(2,1)
7632       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7633      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7634      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7635       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7636       vv(1)=pizda(1,1)-pizda(2,2)
7637       vv(2)=pizda(1,2)+pizda(2,1)
7638       if (l.eq.j+1) then
7639         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7640      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7641      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7642       else
7643         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7644      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7645      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7646       endif
7647 C Cartesian gradient
7648       do iii=1,2
7649         do kkk=1,5
7650           do lll=1,3
7651             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7652      &        pizda(1,1))
7653             vv(1)=pizda(1,1)-pizda(2,2)
7654             vv(2)=pizda(1,2)+pizda(2,1)
7655             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7656      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7657      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7658           enddo
7659         enddo
7660       enddo
7661 c      goto 1112
7662 c1111  continue
7663 C Contribution from graph II
7664       call transpose2(EE(1,1,itk),auxmat(1,1))
7665       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7666       vv(1)=pizda(1,1)+pizda(2,2)
7667       vv(2)=pizda(2,1)-pizda(1,2)
7668       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7669      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7670 C Explicit gradient in virtual-dihedral angles.
7671       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7672      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7673       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7674       vv(1)=pizda(1,1)+pizda(2,2)
7675       vv(2)=pizda(2,1)-pizda(1,2)
7676       if (l.eq.j+1) then
7677         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7678      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7679      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7680       else
7681         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7682      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7683      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7684       endif
7685 C Cartesian gradient
7686       do iii=1,2
7687         do kkk=1,5
7688           do lll=1,3
7689             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7690      &        pizda(1,1))
7691             vv(1)=pizda(1,1)+pizda(2,2)
7692             vv(2)=pizda(2,1)-pizda(1,2)
7693             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7694      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7695      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7696           enddo
7697         enddo
7698       enddo
7699 cd      goto 1112
7700 cd1111  continue
7701       if (l.eq.j+1) then
7702 cd        goto 1110
7703 C Parallel orientation
7704 C Contribution from graph III
7705         call transpose2(EUg(1,1,l),auxmat(1,1))
7706         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7707         vv(1)=pizda(1,1)-pizda(2,2)
7708         vv(2)=pizda(1,2)+pizda(2,1)
7709         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7710      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7711 C Explicit gradient in virtual-dihedral angles.
7712         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7713      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7714      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7715         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7716         vv(1)=pizda(1,1)-pizda(2,2)
7717         vv(2)=pizda(1,2)+pizda(2,1)
7718         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7719      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7720      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7721         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7722         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7723         vv(1)=pizda(1,1)-pizda(2,2)
7724         vv(2)=pizda(1,2)+pizda(2,1)
7725         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7726      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7727      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7728 C Cartesian gradient
7729         do iii=1,2
7730           do kkk=1,5
7731             do lll=1,3
7732               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7733      &          pizda(1,1))
7734               vv(1)=pizda(1,1)-pizda(2,2)
7735               vv(2)=pizda(1,2)+pizda(2,1)
7736               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7737      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7738      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7739             enddo
7740           enddo
7741         enddo
7742 cd        goto 1112
7743 C Contribution from graph IV
7744 cd1110    continue
7745         call transpose2(EE(1,1,itl),auxmat(1,1))
7746         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7747         vv(1)=pizda(1,1)+pizda(2,2)
7748         vv(2)=pizda(2,1)-pizda(1,2)
7749         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7750      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7751 C Explicit gradient in virtual-dihedral angles.
7752         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7753      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7754         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7755         vv(1)=pizda(1,1)+pizda(2,2)
7756         vv(2)=pizda(2,1)-pizda(1,2)
7757         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7758      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7759      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7760 C Cartesian gradient
7761         do iii=1,2
7762           do kkk=1,5
7763             do lll=1,3
7764               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7765      &          pizda(1,1))
7766               vv(1)=pizda(1,1)+pizda(2,2)
7767               vv(2)=pizda(2,1)-pizda(1,2)
7768               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7769      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7770      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7771             enddo
7772           enddo
7773         enddo
7774       else
7775 C Antiparallel orientation
7776 C Contribution from graph III
7777 c        goto 1110
7778         call transpose2(EUg(1,1,j),auxmat(1,1))
7779         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7780         vv(1)=pizda(1,1)-pizda(2,2)
7781         vv(2)=pizda(1,2)+pizda(2,1)
7782         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7783      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7784 C Explicit gradient in virtual-dihedral angles.
7785         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7786      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7787      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7788         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7789         vv(1)=pizda(1,1)-pizda(2,2)
7790         vv(2)=pizda(1,2)+pizda(2,1)
7791         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7792      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7793      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7794         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7795         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7796         vv(1)=pizda(1,1)-pizda(2,2)
7797         vv(2)=pizda(1,2)+pizda(2,1)
7798         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7799      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7800      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7801 C Cartesian gradient
7802         do iii=1,2
7803           do kkk=1,5
7804             do lll=1,3
7805               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7806      &          pizda(1,1))
7807               vv(1)=pizda(1,1)-pizda(2,2)
7808               vv(2)=pizda(1,2)+pizda(2,1)
7809               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7810      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7811      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7812             enddo
7813           enddo
7814         enddo
7815 cd        goto 1112
7816 C Contribution from graph IV
7817 1110    continue
7818         call transpose2(EE(1,1,itj),auxmat(1,1))
7819         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7820         vv(1)=pizda(1,1)+pizda(2,2)
7821         vv(2)=pizda(2,1)-pizda(1,2)
7822         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7823      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7824 C Explicit gradient in virtual-dihedral angles.
7825         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7826      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7827         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7828         vv(1)=pizda(1,1)+pizda(2,2)
7829         vv(2)=pizda(2,1)-pizda(1,2)
7830         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7831      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7832      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7833 C Cartesian gradient
7834         do iii=1,2
7835           do kkk=1,5
7836             do lll=1,3
7837               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7838      &          pizda(1,1))
7839               vv(1)=pizda(1,1)+pizda(2,2)
7840               vv(2)=pizda(2,1)-pizda(1,2)
7841               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7842      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7843      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7844             enddo
7845           enddo
7846         enddo
7847       endif
7848 1112  continue
7849       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7850 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7851 cd        write (2,*) 'ijkl',i,j,k,l
7852 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7853 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7854 cd      endif
7855 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7856 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7857 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7858 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7859       if (j.lt.nres-1) then
7860         j1=j+1
7861         j2=j-1
7862       else
7863         j1=j-1
7864         j2=j-2
7865       endif
7866       if (l.lt.nres-1) then
7867         l1=l+1
7868         l2=l-1
7869       else
7870         l1=l-1
7871         l2=l-2
7872       endif
7873 cd      eij=1.0d0
7874 cd      ekl=1.0d0
7875 cd      ekont=1.0d0
7876 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7877 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7878 C        summed up outside the subrouine as for the other subroutines
7879 C        handling long-range interactions. The old code is commented out
7880 C        with "cgrad" to keep track of changes.
7881       do ll=1,3
7882 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7883 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7884         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7885         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7886 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7887 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7888 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7889 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7890 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7891 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7892 c     &   gradcorr5ij,
7893 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7894 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7895 cgrad        ghalf=0.5d0*ggg1(ll)
7896 cd        ghalf=0.0d0
7897         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7898         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7899         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7900         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7901         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7902         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7903 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7904 cgrad        ghalf=0.5d0*ggg2(ll)
7905 cd        ghalf=0.0d0
7906         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7907         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7908         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7909         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7910         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7911         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7912       enddo
7913 cd      goto 1112
7914 cgrad      do m=i+1,j-1
7915 cgrad        do ll=1,3
7916 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7917 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7918 cgrad        enddo
7919 cgrad      enddo
7920 cgrad      do m=k+1,l-1
7921 cgrad        do ll=1,3
7922 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7923 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7924 cgrad        enddo
7925 cgrad      enddo
7926 c1112  continue
7927 cgrad      do m=i+2,j2
7928 cgrad        do ll=1,3
7929 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7930 cgrad        enddo
7931 cgrad      enddo
7932 cgrad      do m=k+2,l2
7933 cgrad        do ll=1,3
7934 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7935 cgrad        enddo
7936 cgrad      enddo
7937 cd      do iii=1,nres-3
7938 cd        write (2,*) iii,g_corr5_loc(iii)
7939 cd      enddo
7940       eello5=ekont*eel5
7941 cd      write (2,*) 'ekont',ekont
7942 cd      write (iout,*) 'eello5',ekont*eel5
7943       return
7944       end
7945 c--------------------------------------------------------------------------
7946       double precision function eello6(i,j,k,l,jj,kk)
7947       implicit real*8 (a-h,o-z)
7948       include 'DIMENSIONS'
7949       include 'COMMON.IOUNITS'
7950       include 'COMMON.CHAIN'
7951       include 'COMMON.DERIV'
7952       include 'COMMON.INTERACT'
7953       include 'COMMON.CONTACTS'
7954       include 'COMMON.TORSION'
7955       include 'COMMON.VAR'
7956       include 'COMMON.GEO'
7957       include 'COMMON.FFIELD'
7958       double precision ggg1(3),ggg2(3)
7959 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7960 cd        eello6=0.0d0
7961 cd        return
7962 cd      endif
7963 cd      write (iout,*)
7964 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7965 cd     &   ' and',k,l
7966       eello6_1=0.0d0
7967       eello6_2=0.0d0
7968       eello6_3=0.0d0
7969       eello6_4=0.0d0
7970       eello6_5=0.0d0
7971       eello6_6=0.0d0
7972 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7973 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7974       do iii=1,2
7975         do kkk=1,5
7976           do lll=1,3
7977             derx(lll,kkk,iii)=0.0d0
7978           enddo
7979         enddo
7980       enddo
7981 cd      eij=facont_hb(jj,i)
7982 cd      ekl=facont_hb(kk,k)
7983 cd      ekont=eij*ekl
7984 cd      eij=1.0d0
7985 cd      ekl=1.0d0
7986 cd      ekont=1.0d0
7987       if (l.eq.j+1) then
7988         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7989         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7990         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7991         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7992         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7993         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7994       else
7995         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7996         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7997         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7998         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7999         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8000           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8001         else
8002           eello6_5=0.0d0
8003         endif
8004         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8005       endif
8006 C If turn contributions are considered, they will be handled separately.
8007       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8008 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8009 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8010 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8011 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8012 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8013 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8014 cd      goto 1112
8015       if (j.lt.nres-1) then
8016         j1=j+1
8017         j2=j-1
8018       else
8019         j1=j-1
8020         j2=j-2
8021       endif
8022       if (l.lt.nres-1) then
8023         l1=l+1
8024         l2=l-1
8025       else
8026         l1=l-1
8027         l2=l-2
8028       endif
8029       do ll=1,3
8030 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8031 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8032 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8033 cgrad        ghalf=0.5d0*ggg1(ll)
8034 cd        ghalf=0.0d0
8035         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8036         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8037         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8038         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8039         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8040         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8041         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8042         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8043 cgrad        ghalf=0.5d0*ggg2(ll)
8044 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8045 cd        ghalf=0.0d0
8046         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8047         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8048         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8049         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8050         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8051         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8052       enddo
8053 cd      goto 1112
8054 cgrad      do m=i+1,j-1
8055 cgrad        do ll=1,3
8056 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8057 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8058 cgrad        enddo
8059 cgrad      enddo
8060 cgrad      do m=k+1,l-1
8061 cgrad        do ll=1,3
8062 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8063 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8064 cgrad        enddo
8065 cgrad      enddo
8066 cgrad1112  continue
8067 cgrad      do m=i+2,j2
8068 cgrad        do ll=1,3
8069 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8070 cgrad        enddo
8071 cgrad      enddo
8072 cgrad      do m=k+2,l2
8073 cgrad        do ll=1,3
8074 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8075 cgrad        enddo
8076 cgrad      enddo
8077 cd      do iii=1,nres-3
8078 cd        write (2,*) iii,g_corr6_loc(iii)
8079 cd      enddo
8080       eello6=ekont*eel6
8081 cd      write (2,*) 'ekont',ekont
8082 cd      write (iout,*) 'eello6',ekont*eel6
8083       return
8084       end
8085 c--------------------------------------------------------------------------
8086       double precision function eello6_graph1(i,j,k,l,imat,swap)
8087       implicit real*8 (a-h,o-z)
8088       include 'DIMENSIONS'
8089       include 'COMMON.IOUNITS'
8090       include 'COMMON.CHAIN'
8091       include 'COMMON.DERIV'
8092       include 'COMMON.INTERACT'
8093       include 'COMMON.CONTACTS'
8094       include 'COMMON.TORSION'
8095       include 'COMMON.VAR'
8096       include 'COMMON.GEO'
8097       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8098       logical swap
8099       logical lprn
8100       common /kutas/ lprn
8101 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8102 C
8103 C      Parallel       Antiparallel
8104 C
8105 C          o             o
8106 C         /l\           /j\
8107 C        /   \         /   \
8108 C       /| o |         | o |\
8109 C     \ j|/k\|  /   \  |/k\|l /
8110 C      \ /   \ /     \ /   \ /
8111 C       o     o       o     o
8112 C       i             i
8113 C
8114 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8115       itk=itortyp(itype(k))
8116       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8117       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8118       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8119       call transpose2(EUgC(1,1,k),auxmat(1,1))
8120       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8121       vv1(1)=pizda1(1,1)-pizda1(2,2)
8122       vv1(2)=pizda1(1,2)+pizda1(2,1)
8123       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8124       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8125       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8126       s5=scalar2(vv(1),Dtobr2(1,i))
8127 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8128       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8129       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8130      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8131      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8132      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8133      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8134      & +scalar2(vv(1),Dtobr2der(1,i)))
8135       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8136       vv1(1)=pizda1(1,1)-pizda1(2,2)
8137       vv1(2)=pizda1(1,2)+pizda1(2,1)
8138       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8139       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8140       if (l.eq.j+1) then
8141         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8142      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8143      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8144      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8145      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8146       else
8147         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8148      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8149      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8150      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8151      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8152       endif
8153       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8154       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8155       vv1(1)=pizda1(1,1)-pizda1(2,2)
8156       vv1(2)=pizda1(1,2)+pizda1(2,1)
8157       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8158      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8159      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8160      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8161       do iii=1,2
8162         if (swap) then
8163           ind=3-iii
8164         else
8165           ind=iii
8166         endif
8167         do kkk=1,5
8168           do lll=1,3
8169             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8170             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8171             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8172             call transpose2(EUgC(1,1,k),auxmat(1,1))
8173             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8174      &        pizda1(1,1))
8175             vv1(1)=pizda1(1,1)-pizda1(2,2)
8176             vv1(2)=pizda1(1,2)+pizda1(2,1)
8177             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8178             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8179      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8180             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8181      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8182             s5=scalar2(vv(1),Dtobr2(1,i))
8183             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8184           enddo
8185         enddo
8186       enddo
8187       return
8188       end
8189 c----------------------------------------------------------------------------
8190       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8191       implicit real*8 (a-h,o-z)
8192       include 'DIMENSIONS'
8193       include 'COMMON.IOUNITS'
8194       include 'COMMON.CHAIN'
8195       include 'COMMON.DERIV'
8196       include 'COMMON.INTERACT'
8197       include 'COMMON.CONTACTS'
8198       include 'COMMON.TORSION'
8199       include 'COMMON.VAR'
8200       include 'COMMON.GEO'
8201       logical swap
8202       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8203      & auxvec1(2),auxvec2(1),auxmat1(2,2)
8204       logical lprn
8205       common /kutas/ lprn
8206 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8207 C                                                                              C
8208 C      Parallel       Antiparallel                                             C
8209 C                                                                              C
8210 C          o             o                                                     C
8211 C     \   /l\           /j\   /                                                C
8212 C      \ /   \         /   \ /                                                 C
8213 C       o| o |         | o |o                                                  C
8214 C     \ j|/k\|      \  |/k\|l                                                  C
8215 C      \ /   \       \ /   \                                                   C
8216 C       o             o                                                        C
8217 C       i             i                                                        C
8218 C                                                                              C
8219 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8220 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8221 C AL 7/4/01 s1 would occur in the sixth-order moment,
8222 C           but not in a cluster cumulant
8223 #ifdef MOMENT
8224       s1=dip(1,jj,i)*dip(1,kk,k)
8225 #endif
8226       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8227       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8228       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8229       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8230       call transpose2(EUg(1,1,k),auxmat(1,1))
8231       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8232       vv(1)=pizda(1,1)-pizda(2,2)
8233       vv(2)=pizda(1,2)+pizda(2,1)
8234       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8235 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8236 #ifdef MOMENT
8237       eello6_graph2=-(s1+s2+s3+s4)
8238 #else
8239       eello6_graph2=-(s2+s3+s4)
8240 #endif
8241 c      eello6_graph2=-s3
8242 C Derivatives in gamma(i-1)
8243       if (i.gt.1) then
8244 #ifdef MOMENT
8245         s1=dipderg(1,jj,i)*dip(1,kk,k)
8246 #endif
8247         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8248         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8249         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8250         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8251 #ifdef MOMENT
8252         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8253 #else
8254         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8255 #endif
8256 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8257       endif
8258 C Derivatives in gamma(k-1)
8259 #ifdef MOMENT
8260       s1=dip(1,jj,i)*dipderg(1,kk,k)
8261 #endif
8262       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8263       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8264       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8265       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8266       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8267       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8268       vv(1)=pizda(1,1)-pizda(2,2)
8269       vv(2)=pizda(1,2)+pizda(2,1)
8270       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8271 #ifdef MOMENT
8272       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8273 #else
8274       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8275 #endif
8276 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8277 C Derivatives in gamma(j-1) or gamma(l-1)
8278       if (j.gt.1) then
8279 #ifdef MOMENT
8280         s1=dipderg(3,jj,i)*dip(1,kk,k)
8281 #endif
8282         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8283         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8284         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8285         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8286         vv(1)=pizda(1,1)-pizda(2,2)
8287         vv(2)=pizda(1,2)+pizda(2,1)
8288         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8289 #ifdef MOMENT
8290         if (swap) then
8291           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8292         else
8293           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8294         endif
8295 #endif
8296         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8297 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8298       endif
8299 C Derivatives in gamma(l-1) or gamma(j-1)
8300       if (l.gt.1) then
8301 #ifdef MOMENT
8302         s1=dip(1,jj,i)*dipderg(3,kk,k)
8303 #endif
8304         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8305         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8306         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8307         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8308         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8309         vv(1)=pizda(1,1)-pizda(2,2)
8310         vv(2)=pizda(1,2)+pizda(2,1)
8311         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8312 #ifdef MOMENT
8313         if (swap) then
8314           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8315         else
8316           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8317         endif
8318 #endif
8319         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8320 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8321       endif
8322 C Cartesian derivatives.
8323       if (lprn) then
8324         write (2,*) 'In eello6_graph2'
8325         do iii=1,2
8326           write (2,*) 'iii=',iii
8327           do kkk=1,5
8328             write (2,*) 'kkk=',kkk
8329             do jjj=1,2
8330               write (2,'(3(2f10.5),5x)')
8331      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8332             enddo
8333           enddo
8334         enddo
8335       endif
8336       do iii=1,2
8337         do kkk=1,5
8338           do lll=1,3
8339 #ifdef MOMENT
8340             if (iii.eq.1) then
8341               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8342             else
8343               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8344             endif
8345 #endif
8346             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8347      &        auxvec(1))
8348             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8349             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8350      &        auxvec(1))
8351             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8352             call transpose2(EUg(1,1,k),auxmat(1,1))
8353             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8354      &        pizda(1,1))
8355             vv(1)=pizda(1,1)-pizda(2,2)
8356             vv(2)=pizda(1,2)+pizda(2,1)
8357             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8358 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8359 #ifdef MOMENT
8360             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8361 #else
8362             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8363 #endif
8364             if (swap) then
8365               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8366             else
8367               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8368             endif
8369           enddo
8370         enddo
8371       enddo
8372       return
8373       end
8374 c----------------------------------------------------------------------------
8375       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8376       implicit real*8 (a-h,o-z)
8377       include 'DIMENSIONS'
8378       include 'COMMON.IOUNITS'
8379       include 'COMMON.CHAIN'
8380       include 'COMMON.DERIV'
8381       include 'COMMON.INTERACT'
8382       include 'COMMON.CONTACTS'
8383       include 'COMMON.TORSION'
8384       include 'COMMON.VAR'
8385       include 'COMMON.GEO'
8386       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8387       logical swap
8388 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8389 C                                                                              C
8390 C      Parallel       Antiparallel                                             C
8391 C                                                                              C
8392 C          o             o                                                     C
8393 C         /l\   /   \   /j\                                                    C
8394 C        /   \ /     \ /   \                                                   C
8395 C       /| o |o       o| o |\                                                  C
8396 C       j|/k\|  /      |/k\|l /                                                C
8397 C        /   \ /       /   \ /                                                 C
8398 C       /     o       /     o                                                  C
8399 C       i             i                                                        C
8400 C                                                                              C
8401 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8402 C
8403 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8404 C           energy moment and not to the cluster cumulant.
8405       iti=itortyp(itype(i))
8406       if (j.lt.nres-1) then
8407         itj1=itortyp(itype(j+1))
8408       else
8409         itj1=ntortyp+1
8410       endif
8411       itk=itortyp(itype(k))
8412       itk1=itortyp(itype(k+1))
8413       if (l.lt.nres-1) then
8414         itl1=itortyp(itype(l+1))
8415       else
8416         itl1=ntortyp+1
8417       endif
8418 #ifdef MOMENT
8419       s1=dip(4,jj,i)*dip(4,kk,k)
8420 #endif
8421       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8422       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8423       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8424       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8425       call transpose2(EE(1,1,itk),auxmat(1,1))
8426       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8427       vv(1)=pizda(1,1)+pizda(2,2)
8428       vv(2)=pizda(2,1)-pizda(1,2)
8429       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8430 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8431 cd     & "sum",-(s2+s3+s4)
8432 #ifdef MOMENT
8433       eello6_graph3=-(s1+s2+s3+s4)
8434 #else
8435       eello6_graph3=-(s2+s3+s4)
8436 #endif
8437 c      eello6_graph3=-s4
8438 C Derivatives in gamma(k-1)
8439       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8440       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8441       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8442       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8443 C Derivatives in gamma(l-1)
8444       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8445       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8446       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8447       vv(1)=pizda(1,1)+pizda(2,2)
8448       vv(2)=pizda(2,1)-pizda(1,2)
8449       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8450       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8451 C Cartesian derivatives.
8452       do iii=1,2
8453         do kkk=1,5
8454           do lll=1,3
8455 #ifdef MOMENT
8456             if (iii.eq.1) then
8457               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8458             else
8459               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8460             endif
8461 #endif
8462             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8463      &        auxvec(1))
8464             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8465             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8466      &        auxvec(1))
8467             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8468             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8469      &        pizda(1,1))
8470             vv(1)=pizda(1,1)+pizda(2,2)
8471             vv(2)=pizda(2,1)-pizda(1,2)
8472             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8473 #ifdef MOMENT
8474             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8475 #else
8476             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8477 #endif
8478             if (swap) then
8479               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8480             else
8481               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8482             endif
8483 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8484           enddo
8485         enddo
8486       enddo
8487       return
8488       end
8489 c----------------------------------------------------------------------------
8490       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8491       implicit real*8 (a-h,o-z)
8492       include 'DIMENSIONS'
8493       include 'COMMON.IOUNITS'
8494       include 'COMMON.CHAIN'
8495       include 'COMMON.DERIV'
8496       include 'COMMON.INTERACT'
8497       include 'COMMON.CONTACTS'
8498       include 'COMMON.TORSION'
8499       include 'COMMON.VAR'
8500       include 'COMMON.GEO'
8501       include 'COMMON.FFIELD'
8502       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8503      & auxvec1(2),auxmat1(2,2)
8504       logical swap
8505 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8506 C                                                                              C
8507 C      Parallel       Antiparallel                                             C
8508 C                                                                              C
8509 C          o             o                                                     C
8510 C         /l\   /   \   /j\                                                    C
8511 C        /   \ /     \ /   \                                                   C
8512 C       /| o |o       o| o |\                                                  C
8513 C     \ j|/k\|      \  |/k\|l                                                  C
8514 C      \ /   \       \ /   \                                                   C
8515 C       o     \       o     \                                                  C
8516 C       i             i                                                        C
8517 C                                                                              C
8518 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8519 C
8520 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8521 C           energy moment and not to the cluster cumulant.
8522 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8523       iti=itortyp(itype(i))
8524       itj=itortyp(itype(j))
8525       if (j.lt.nres-1) then
8526         itj1=itortyp(itype(j+1))
8527       else
8528         itj1=ntortyp+1
8529       endif
8530       itk=itortyp(itype(k))
8531       if (k.lt.nres-1) then
8532         itk1=itortyp(itype(k+1))
8533       else
8534         itk1=ntortyp+1
8535       endif
8536       itl=itortyp(itype(l))
8537       if (l.lt.nres-1) then
8538         itl1=itortyp(itype(l+1))
8539       else
8540         itl1=ntortyp+1
8541       endif
8542 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8543 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8544 cd     & ' itl',itl,' itl1',itl1
8545 #ifdef MOMENT
8546       if (imat.eq.1) then
8547         s1=dip(3,jj,i)*dip(3,kk,k)
8548       else
8549         s1=dip(2,jj,j)*dip(2,kk,l)
8550       endif
8551 #endif
8552       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8553       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8554       if (j.eq.l+1) then
8555         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8556         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8557       else
8558         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8559         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8560       endif
8561       call transpose2(EUg(1,1,k),auxmat(1,1))
8562       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8563       vv(1)=pizda(1,1)-pizda(2,2)
8564       vv(2)=pizda(2,1)+pizda(1,2)
8565       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8566 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8567 #ifdef MOMENT
8568       eello6_graph4=-(s1+s2+s3+s4)
8569 #else
8570       eello6_graph4=-(s2+s3+s4)
8571 #endif
8572 C Derivatives in gamma(i-1)
8573       if (i.gt.1) then
8574 #ifdef MOMENT
8575         if (imat.eq.1) then
8576           s1=dipderg(2,jj,i)*dip(3,kk,k)
8577         else
8578           s1=dipderg(4,jj,j)*dip(2,kk,l)
8579         endif
8580 #endif
8581         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8582         if (j.eq.l+1) then
8583           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8584           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8585         else
8586           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8587           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8588         endif
8589         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8590         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8591 cd          write (2,*) 'turn6 derivatives'
8592 #ifdef MOMENT
8593           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8594 #else
8595           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8596 #endif
8597         else
8598 #ifdef MOMENT
8599           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8600 #else
8601           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8602 #endif
8603         endif
8604       endif
8605 C Derivatives in gamma(k-1)
8606 #ifdef MOMENT
8607       if (imat.eq.1) then
8608         s1=dip(3,jj,i)*dipderg(2,kk,k)
8609       else
8610         s1=dip(2,jj,j)*dipderg(4,kk,l)
8611       endif
8612 #endif
8613       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8614       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8615       if (j.eq.l+1) then
8616         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8617         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8618       else
8619         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8620         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8621       endif
8622       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8623       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8624       vv(1)=pizda(1,1)-pizda(2,2)
8625       vv(2)=pizda(2,1)+pizda(1,2)
8626       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8627       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8628 #ifdef MOMENT
8629         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8630 #else
8631         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8632 #endif
8633       else
8634 #ifdef MOMENT
8635         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8636 #else
8637         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8638 #endif
8639       endif
8640 C Derivatives in gamma(j-1) or gamma(l-1)
8641       if (l.eq.j+1 .and. l.gt.1) then
8642         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8643         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8644         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8645         vv(1)=pizda(1,1)-pizda(2,2)
8646         vv(2)=pizda(2,1)+pizda(1,2)
8647         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8648         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8649       else if (j.gt.1) then
8650         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8651         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8652         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8653         vv(1)=pizda(1,1)-pizda(2,2)
8654         vv(2)=pizda(2,1)+pizda(1,2)
8655         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8656         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8657           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8658         else
8659           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8660         endif
8661       endif
8662 C Cartesian derivatives.
8663       do iii=1,2
8664         do kkk=1,5
8665           do lll=1,3
8666 #ifdef MOMENT
8667             if (iii.eq.1) then
8668               if (imat.eq.1) then
8669                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8670               else
8671                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8672               endif
8673             else
8674               if (imat.eq.1) then
8675                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8676               else
8677                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8678               endif
8679             endif
8680 #endif
8681             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8682      &        auxvec(1))
8683             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8684             if (j.eq.l+1) then
8685               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8686      &          b1(1,itj1),auxvec(1))
8687               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8688             else
8689               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8690      &          b1(1,itl1),auxvec(1))
8691               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8692             endif
8693             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8694      &        pizda(1,1))
8695             vv(1)=pizda(1,1)-pizda(2,2)
8696             vv(2)=pizda(2,1)+pizda(1,2)
8697             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8698             if (swap) then
8699               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8700 #ifdef MOMENT
8701                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8702      &             -(s1+s2+s4)
8703 #else
8704                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8705      &             -(s2+s4)
8706 #endif
8707                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8708               else
8709 #ifdef MOMENT
8710                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8711 #else
8712                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8713 #endif
8714                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8715               endif
8716             else
8717 #ifdef MOMENT
8718               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8719 #else
8720               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8721 #endif
8722               if (l.eq.j+1) then
8723                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8724               else
8725                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8726               endif
8727             endif
8728           enddo
8729         enddo
8730       enddo
8731       return
8732       end
8733 c----------------------------------------------------------------------------
8734       double precision function eello_turn6(i,jj,kk)
8735       implicit real*8 (a-h,o-z)
8736       include 'DIMENSIONS'
8737       include 'COMMON.IOUNITS'
8738       include 'COMMON.CHAIN'
8739       include 'COMMON.DERIV'
8740       include 'COMMON.INTERACT'
8741       include 'COMMON.CONTACTS'
8742       include 'COMMON.TORSION'
8743       include 'COMMON.VAR'
8744       include 'COMMON.GEO'
8745       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8746      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8747      &  ggg1(3),ggg2(3)
8748       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8749      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8750 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8751 C           the respective energy moment and not to the cluster cumulant.
8752       s1=0.0d0
8753       s8=0.0d0
8754       s13=0.0d0
8755 c
8756       eello_turn6=0.0d0
8757       j=i+4
8758       k=i+1
8759       l=i+3
8760       iti=itortyp(itype(i))
8761       itk=itortyp(itype(k))
8762       itk1=itortyp(itype(k+1))
8763       itl=itortyp(itype(l))
8764       itj=itortyp(itype(j))
8765 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8766 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8767 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8768 cd        eello6=0.0d0
8769 cd        return
8770 cd      endif
8771 cd      write (iout,*)
8772 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8773 cd     &   ' and',k,l
8774 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8775       do iii=1,2
8776         do kkk=1,5
8777           do lll=1,3
8778             derx_turn(lll,kkk,iii)=0.0d0
8779           enddo
8780         enddo
8781       enddo
8782 cd      eij=1.0d0
8783 cd      ekl=1.0d0
8784 cd      ekont=1.0d0
8785       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8786 cd      eello6_5=0.0d0
8787 cd      write (2,*) 'eello6_5',eello6_5
8788 #ifdef MOMENT
8789       call transpose2(AEA(1,1,1),auxmat(1,1))
8790       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8791       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8792       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8793 #endif
8794       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8795       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8796       s2 = scalar2(b1(1,itk),vtemp1(1))
8797 #ifdef MOMENT
8798       call transpose2(AEA(1,1,2),atemp(1,1))
8799       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8800       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8801       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8802 #endif
8803       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8804       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8805       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8806 #ifdef MOMENT
8807       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8808       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8809       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8810       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8811       ss13 = scalar2(b1(1,itk),vtemp4(1))
8812       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8813 #endif
8814 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8815 c      s1=0.0d0
8816 c      s2=0.0d0
8817 c      s8=0.0d0
8818 c      s12=0.0d0
8819 c      s13=0.0d0
8820       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8821 C Derivatives in gamma(i+2)
8822       s1d =0.0d0
8823       s8d =0.0d0
8824 #ifdef MOMENT
8825       call transpose2(AEA(1,1,1),auxmatd(1,1))
8826       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8827       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8828       call transpose2(AEAderg(1,1,2),atempd(1,1))
8829       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8830       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8831 #endif
8832       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8833       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8834       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8835 c      s1d=0.0d0
8836 c      s2d=0.0d0
8837 c      s8d=0.0d0
8838 c      s12d=0.0d0
8839 c      s13d=0.0d0
8840       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8841 C Derivatives in gamma(i+3)
8842 #ifdef MOMENT
8843       call transpose2(AEA(1,1,1),auxmatd(1,1))
8844       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8845       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8846       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8847 #endif
8848       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8849       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8850       s2d = scalar2(b1(1,itk),vtemp1d(1))
8851 #ifdef MOMENT
8852       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8853       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8854 #endif
8855       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8856 #ifdef MOMENT
8857       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8858       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8859       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8860 #endif
8861 c      s1d=0.0d0
8862 c      s2d=0.0d0
8863 c      s8d=0.0d0
8864 c      s12d=0.0d0
8865 c      s13d=0.0d0
8866 #ifdef MOMENT
8867       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8868      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8869 #else
8870       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8871      &               -0.5d0*ekont*(s2d+s12d)
8872 #endif
8873 C Derivatives in gamma(i+4)
8874       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8875       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8876       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8877 #ifdef MOMENT
8878       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8879       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8880       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8881 #endif
8882 c      s1d=0.0d0
8883 c      s2d=0.0d0
8884 c      s8d=0.0d0
8885 C      s12d=0.0d0
8886 c      s13d=0.0d0
8887 #ifdef MOMENT
8888       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8889 #else
8890       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8891 #endif
8892 C Derivatives in gamma(i+5)
8893 #ifdef MOMENT
8894       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8895       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8896       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8897 #endif
8898       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8899       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8900       s2d = scalar2(b1(1,itk),vtemp1d(1))
8901 #ifdef MOMENT
8902       call transpose2(AEA(1,1,2),atempd(1,1))
8903       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8904       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8905 #endif
8906       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8907       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8908 #ifdef MOMENT
8909       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8910       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8911       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8912 #endif
8913 c      s1d=0.0d0
8914 c      s2d=0.0d0
8915 c      s8d=0.0d0
8916 c      s12d=0.0d0
8917 c      s13d=0.0d0
8918 #ifdef MOMENT
8919       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8920      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8921 #else
8922       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8923      &               -0.5d0*ekont*(s2d+s12d)
8924 #endif
8925 C Cartesian derivatives
8926       do iii=1,2
8927         do kkk=1,5
8928           do lll=1,3
8929 #ifdef MOMENT
8930             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8931             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8932             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8933 #endif
8934             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8935             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8936      &          vtemp1d(1))
8937             s2d = scalar2(b1(1,itk),vtemp1d(1))
8938 #ifdef MOMENT
8939             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8940             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8941             s8d = -(atempd(1,1)+atempd(2,2))*
8942      &           scalar2(cc(1,1,itl),vtemp2(1))
8943 #endif
8944             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8945      &           auxmatd(1,1))
8946             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8947             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8948 c      s1d=0.0d0
8949 c      s2d=0.0d0
8950 c      s8d=0.0d0
8951 c      s12d=0.0d0
8952 c      s13d=0.0d0
8953 #ifdef MOMENT
8954             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8955      &        - 0.5d0*(s1d+s2d)
8956 #else
8957             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8958      &        - 0.5d0*s2d
8959 #endif
8960 #ifdef MOMENT
8961             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8962      &        - 0.5d0*(s8d+s12d)
8963 #else
8964             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8965      &        - 0.5d0*s12d
8966 #endif
8967           enddo
8968         enddo
8969       enddo
8970 #ifdef MOMENT
8971       do kkk=1,5
8972         do lll=1,3
8973           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8974      &      achuj_tempd(1,1))
8975           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8976           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8977           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8978           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8979           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8980      &      vtemp4d(1))
8981           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8982           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8983           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8984         enddo
8985       enddo
8986 #endif
8987 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8988 cd     &  16*eel_turn6_num
8989 cd      goto 1112
8990       if (j.lt.nres-1) then
8991         j1=j+1
8992         j2=j-1
8993       else
8994         j1=j-1
8995         j2=j-2
8996       endif
8997       if (l.lt.nres-1) then
8998         l1=l+1
8999         l2=l-1
9000       else
9001         l1=l-1
9002         l2=l-2
9003       endif
9004       do ll=1,3
9005 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9006 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9007 cgrad        ghalf=0.5d0*ggg1(ll)
9008 cd        ghalf=0.0d0
9009         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9010         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9011         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9012      &    +ekont*derx_turn(ll,2,1)
9013         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9014         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9015      &    +ekont*derx_turn(ll,4,1)
9016         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9017         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9018         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9019 cgrad        ghalf=0.5d0*ggg2(ll)
9020 cd        ghalf=0.0d0
9021         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9022      &    +ekont*derx_turn(ll,2,2)
9023         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9024         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9025      &    +ekont*derx_turn(ll,4,2)
9026         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9027         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9028         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9029       enddo
9030 cd      goto 1112
9031 cgrad      do m=i+1,j-1
9032 cgrad        do ll=1,3
9033 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9034 cgrad        enddo
9035 cgrad      enddo
9036 cgrad      do m=k+1,l-1
9037 cgrad        do ll=1,3
9038 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9039 cgrad        enddo
9040 cgrad      enddo
9041 cgrad1112  continue
9042 cgrad      do m=i+2,j2
9043 cgrad        do ll=1,3
9044 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9045 cgrad        enddo
9046 cgrad      enddo
9047 cgrad      do m=k+2,l2
9048 cgrad        do ll=1,3
9049 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9050 cgrad        enddo
9051 cgrad      enddo
9052 cd      do iii=1,nres-3
9053 cd        write (2,*) iii,g_corr6_loc(iii)
9054 cd      enddo
9055       eello_turn6=ekont*eel_turn6
9056 cd      write (2,*) 'ekont',ekont
9057 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9058       return
9059       end
9060
9061 C-----------------------------------------------------------------------------
9062       double precision function scalar(u,v)
9063 !DIR$ INLINEALWAYS scalar
9064 #ifndef OSF
9065 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9066 #endif
9067       implicit none
9068       double precision u(3),v(3)
9069 cd      double precision sc
9070 cd      integer i
9071 cd      sc=0.0d0
9072 cd      do i=1,3
9073 cd        sc=sc+u(i)*v(i)
9074 cd      enddo
9075 cd      scalar=sc
9076
9077       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9078       return
9079       end
9080 crc-------------------------------------------------
9081       SUBROUTINE MATVEC2(A1,V1,V2)
9082 !DIR$ INLINEALWAYS MATVEC2
9083 #ifndef OSF
9084 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9085 #endif
9086       implicit real*8 (a-h,o-z)
9087       include 'DIMENSIONS'
9088       DIMENSION A1(2,2),V1(2),V2(2)
9089 c      DO 1 I=1,2
9090 c        VI=0.0
9091 c        DO 3 K=1,2
9092 c    3     VI=VI+A1(I,K)*V1(K)
9093 c        Vaux(I)=VI
9094 c    1 CONTINUE
9095
9096       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9097       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9098
9099       v2(1)=vaux1
9100       v2(2)=vaux2
9101       END
9102 C---------------------------------------
9103       SUBROUTINE MATMAT2(A1,A2,A3)
9104 #ifndef OSF
9105 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9106 #endif
9107       implicit real*8 (a-h,o-z)
9108       include 'DIMENSIONS'
9109       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9110 c      DIMENSION AI3(2,2)
9111 c        DO  J=1,2
9112 c          A3IJ=0.0
9113 c          DO K=1,2
9114 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9115 c          enddo
9116 c          A3(I,J)=A3IJ
9117 c       enddo
9118 c      enddo
9119
9120       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9121       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9122       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9123       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9124
9125       A3(1,1)=AI3_11
9126       A3(2,1)=AI3_21
9127       A3(1,2)=AI3_12
9128       A3(2,2)=AI3_22
9129       END
9130
9131 c-------------------------------------------------------------------------
9132       double precision function scalar2(u,v)
9133 !DIR$ INLINEALWAYS scalar2
9134       implicit none
9135       double precision u(2),v(2)
9136       double precision sc
9137       integer i
9138       scalar2=u(1)*v(1)+u(2)*v(2)
9139       return
9140       end
9141
9142 C-----------------------------------------------------------------------------
9143
9144       subroutine transpose2(a,at)
9145 !DIR$ INLINEALWAYS transpose2
9146 #ifndef OSF
9147 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9148 #endif
9149       implicit none
9150       double precision a(2,2),at(2,2)
9151       at(1,1)=a(1,1)
9152       at(1,2)=a(2,1)
9153       at(2,1)=a(1,2)
9154       at(2,2)=a(2,2)
9155       return
9156       end
9157 c--------------------------------------------------------------------------
9158       subroutine transpose(n,a,at)
9159       implicit none
9160       integer n,i,j
9161       double precision a(n,n),at(n,n)
9162       do i=1,n
9163         do j=1,n
9164           at(j,i)=a(i,j)
9165         enddo
9166       enddo
9167       return
9168       end
9169 C---------------------------------------------------------------------------
9170       subroutine prodmat3(a1,a2,kk,transp,prod)
9171 !DIR$ INLINEALWAYS prodmat3
9172 #ifndef OSF
9173 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9174 #endif
9175       implicit none
9176       integer i,j
9177       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9178       logical transp
9179 crc      double precision auxmat(2,2),prod_(2,2)
9180
9181       if (transp) then
9182 crc        call transpose2(kk(1,1),auxmat(1,1))
9183 crc        call matmat2(a1(1,1),auxmat(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(1,2))*a2(1,1)
9187      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9188            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9189      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9190            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9191      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9192            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9193      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9194
9195       else
9196 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9197 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9198
9199            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9200      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9201            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9202      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9203            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9204      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9205            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9206      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9207
9208       endif
9209 c      call transpose2(a2(1,1),a2t(1,1))
9210
9211 crc      print *,transp
9212 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9213 crc      print *,((prod(i,j),i=1,2),j=1,2)
9214
9215       return
9216       end
9217