source/unres/src_MIN/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         time00=MPI_Wtime()
  32 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  33         if (fg_rank.eq.0) then
  34           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  35 c          print *,"Processor",myrank," BROADCAST iorder"
  36 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  37 C FG slaves as WEIGHTS array.
  38           weights_(1)=wsc
  39           weights_(2)=wscp
  40           weights_(3)=welec
  41           weights_(4)=wcorr
  42           weights_(5)=wcorr5
  43           weights_(6)=wcorr6
  44           weights_(7)=wel_loc
  45           weights_(8)=wturn3
  46           weights_(9)=wturn4
  47           weights_(10)=wturn6
  48           weights_(11)=wang
  49           weights_(12)=wscloc
  50           weights_(13)=wtor
  51           weights_(14)=wtor_d
  52           weights_(15)=wstrain
  53           weights_(16)=wvdwpp
  54           weights_(17)=wbond
  55           weights_(18)=scal14
  56           weights_(21)=wsccor
  57           weights_(22)=wsct
  58 C FG Master broadcasts the WEIGHTS_ array
  59           call MPI_Bcast(weights_(1),n_ene,
  60      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  61         else
  62 C FG slaves receive the WEIGHTS array
  63           call MPI_Bcast(weights(1),n_ene,
  64      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  65           wsc=weights(1)
  66           wscp=weights(2)
  67           welec=weights(3)
  68           wcorr=weights(4)
  69           wcorr5=weights(5)
  70           wcorr6=weights(6)
  71           wel_loc=weights(7)
  72           wturn3=weights(8)
  73           wturn4=weights(9)
  74           wturn6=weights(10)
  75           wang=weights(11)
  76           wscloc=weights(12)
  77           wtor=weights(13)
  78           wtor_d=weights(14)
  79           wstrain=weights(15)
  80           wvdwpp=weights(16)
  81           wbond=weights(17)
  82           scal14=weights(18)
  83           wsccor=weights(21)
  84           wsct=weights(22)
  85         endif
  86         time_Bcast=time_Bcast+MPI_Wtime()-time00
  87         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  88 c        call chainbuild_cart
  89       endif
  90 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
  91 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  92 #else
  93 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  94 c        call int_from_cart1(.false.)
  95 c      endif
  96 #endif
  97 #ifdef TIMING
  98       time00=MPI_Wtime()
  99 #endif
 100 C
 101 C Compute the side-chain and electrostatic interaction energy
 102 C
 103       goto (101,102,103,104,105,106) ipot
 104 C Lennard-Jones potential.
 105   101 call elj(evdw,evdw_p,evdw_m)
 106 cd    print '(a)','Exit ELJ'
 107       goto 107
 108 C Lennard-Jones-Kihara potential (shifted).
 109   102 call eljk(evdw,evdw_p,evdw_m)
 110       goto 107
 111 C Berne-Pechukas potential (dilated LJ, angular dependence).
 112   103 call ebp(evdw,evdw_p,evdw_m)
 113       goto 107
 114 C Gay-Berne potential (shifted LJ, angular dependence).
 115   104 call egb(evdw,evdw_p,evdw_m)
 116       goto 107
 117 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 118   105 call egbv(evdw,evdw_p,evdw_m)
 119       goto 107
 120 C Soft-sphere potential
 121   106 call e_softsphere(evdw)
 122 C
 123 C Calculate electrostatic (H-bonding) energy of the main chain.
 124 C
 125   107 continue
 126 c      print *,"Processor",myrank," computed USCSC"
 127 #ifdef TIMING
 128       time01=MPI_Wtime()
 129 #endif
 130       call vec_and_deriv
 131 #ifdef TIMING
 132       time_vec=time_vec+MPI_Wtime()-time01
 133 #endif
 134 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 135       if (ipot.lt.6) then
 136 #ifdef SPLITELE
 137          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 138      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 139      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 140      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 141 #else
 142          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 143      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 144      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 145      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 146 #endif
 147             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 148          else
 149             ees=0.0d0
 150             evdw1=0.0d0
 151             eel_loc=0.0d0
 152             eello_turn3=0.0d0
 153             eello_turn4=0.0d0
 154          endif
 155       else
 156 c        write (iout,*) "Soft-spheer ELEC potential"
 157         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 158      &   eello_turn4)
 159       endif
 160 c      print *,"Processor",myrank," computed UELEC"
 161 C
 162 C Calculate excluded-volume interaction energy between peptide groups
 163 C and side chains.
 164 C
 165       if (ipot.lt.6) then
 166        if(wscp.gt.0d0) then
 167         call escp(evdw2,evdw2_14)
 168        else
 169         evdw2=0
 170         evdw2_14=0
 171        endif
 172       else
 173 c        write (iout,*) "Soft-sphere SCP potential"
 174         call escp_soft_sphere(evdw2,evdw2_14)
 175       endif
 176 c
 177 c Calculate the bond-stretching energy
 178 c
 179       call ebond(estr)
 180 C
 181 C Calculate the disulfide-bridge and other energy and the contributions
 182 C from other distance constraints.
 183 cd    print *,'Calling EHPB'
 184       call edis(ehpb)
 185 cd    print *,'EHPB exitted succesfully.'
 186 C
 187 C Calculate the virtual-bond-angle energy.
 188 C
 189       if (wang.gt.0d0) then
 190         call ebend(ebe)
 191       else
 192         ebe=0
 193       endif
 194 c      print *,"Processor",myrank," computed UB"
 195 C
 196 C Calculate the SC local energy.
 197 C
 198       call esc(escloc)
 199 c      print *,"Processor",myrank," computed USC"
 200 C
 201 C Calculate the virtual-bond torsional energy.
 202 C
 203 cd    print *,'nterm=',nterm
 204       if (wtor.gt.0) then
 205        call etor(etors,edihcnstr)
 206       else
 207        etors=0
 208        edihcnstr=0
 209       endif
 210 c      print *,"Processor",myrank," computed Utor"
 211 C
 212 C 6/23/01 Calculate double-torsional energy
 213 C
 214       if (wtor_d.gt.0) then
 215        call etor_d(etors_d)
 216       else
 217        etors_d=0
 218       endif
 219 c      print *,"Processor",myrank," computed Utord"
 220 C
 221 C 21/5/07 Calculate local sicdechain correlation energy
 222 C
 223       if (wsccor.gt.0.0d0) then
 224         call eback_sc_corr(esccor)
 225       else
 226         esccor=0.0d0
 227       endif
 228 c      print *,"Processor",myrank," computed Usccorr"
 229 C
 230 C 12/1/95 Multi-body terms
 231 C
 232       n_corr=0
 233       n_corr1=0
 234       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 235      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 236          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 237 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 238 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 239       else
 240          ecorr=0.0d0
 241          ecorr5=0.0d0
 242          ecorr6=0.0d0
 243          eturn6=0.0d0
 244       endif
 245       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 246          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 247 cd         write (iout,*) "multibody_hb ecorr",ecorr
 248       endif
 249 c      print *,"Processor",myrank," computed Ucorr"
 250 C
 251 C If performing constraint dynamics, call the constraint energy
 252 C  after the equilibration time
 253       if(usampl.and.totT.gt.eq_time) then
 254 c         call EconstrQ
 255          call Econstr_back
 256       else
 257          Uconst=0.0d0
 258          Uconst_back=0.0d0
 259       endif
 260 #ifdef TIMING
 261       time_enecalc=time_enecalc+MPI_Wtime()-time00
 262 #endif
 263 c      print *,"Processor",myrank," computed Uconstr"
 264 #ifdef TIMING
 265       time00=MPI_Wtime()
 266 #endif
 267 c
 268 C Sum the energies
 269 C
 270       energia(1)=evdw
 271 #ifdef SCP14
 272       energia(2)=evdw2-evdw2_14
 273       energia(18)=evdw2_14
 274 #else
 275       energia(2)=evdw2
 276       energia(18)=0.0d0
 277 #endif
 278 #ifdef SPLITELE
 279       energia(3)=ees
 280       energia(16)=evdw1
 281 #else
 282       energia(3)=ees+evdw1
 283       energia(16)=0.0d0
 284 #endif
 285       energia(4)=ecorr
 286       energia(5)=ecorr5
 287       energia(6)=ecorr6
 288       energia(7)=eel_loc
 289       energia(8)=eello_turn3
 290       energia(9)=eello_turn4
 291       energia(10)=eturn6
 292       energia(11)=ebe
 293       energia(12)=escloc
 294       energia(13)=etors
 295       energia(14)=etors_d
 296       energia(15)=ehpb
 297       energia(19)=edihcnstr
 298       energia(17)=estr
 299       energia(20)=Uconst+Uconst_back
 300       energia(21)=esccor
 301       energia(22)=evdw_p
 302       energia(23)=evdw_m
 303 c      print *," Processor",myrank," calls SUM_ENERGY"
 304       call sum_energy(energia,.true.)
 305 c      print *," Processor",myrank," left SUM_ENERGY"
 306 #ifdef TIMING
 307       time_sumene=time_sumene+MPI_Wtime()-time00
 308 #endif
 309       return
 310       end
 311 c-------------------------------------------------------------------------------
 312       subroutine sum_energy(energia,reduce)
 313       implicit real*8 (a-h,o-z)
 314       include 'DIMENSIONS'
 315 #ifndef ISNAN
 316       external proc_proc
 317 #ifdef WINPGI
 318 cMS$ATTRIBUTES C ::  proc_proc
 319 #endif
 320 #endif
 321 #ifdef MPI
 322       include "mpif.h"
 323 #endif
 324       include 'COMMON.SETUP'
 325       include 'COMMON.IOUNITS'
 326       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 327       include 'COMMON.FFIELD'
 328       include 'COMMON.DERIV'
 329       include 'COMMON.INTERACT'
 330       include 'COMMON.SBRIDGE'
 331       include 'COMMON.CHAIN'
 332       include 'COMMON.VAR'
 333       include 'COMMON.CONTROL'
 334       include 'COMMON.TIME1'
 335       logical reduce
 336 #ifdef MPI
 337       if (nfgtasks.gt.1 .and. reduce) then
 338 #ifdef DEBUG
 339         write (iout,*) "energies before REDUCE"
 340         call enerprint(energia)
 341         call flush(iout)
 342 #endif
 343         do i=0,n_ene
 344           enebuff(i)=energia(i)
 345         enddo
 346         time00=MPI_Wtime()
 347         call MPI_Barrier(FG_COMM,IERR)
 348         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 349         time00=MPI_Wtime()
 350         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 351      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 352 #ifdef DEBUG
 353         write (iout,*) "energies after REDUCE"
 354         call enerprint(energia)
 355         call flush(iout)
 356 #endif
 357         time_Reduce=time_Reduce+MPI_Wtime()-time00
 358       endif
 359       if (fg_rank.eq.0) then
 360 #endif
 361 #ifdef TSCSC
 362       evdw=energia(22)+wsct*energia(23)
 363 #else
 364       evdw=energia(1)
 365 #endif
 366 #ifdef SCP14
 367       evdw2=energia(2)+energia(18)
 368       evdw2_14=energia(18)
 369 #else
 370       evdw2=energia(2)
 371 #endif
 372 #ifdef SPLITELE
 373       ees=energia(3)
 374       evdw1=energia(16)
 375 #else
 376       ees=energia(3)
 377       evdw1=0.0d0
 378 #endif
 379       ecorr=energia(4)
 380       ecorr5=energia(5)
 381       ecorr6=energia(6)
 382       eel_loc=energia(7)
 383       eello_turn3=energia(8)
 384       eello_turn4=energia(9)
 385       eturn6=energia(10)
 386       ebe=energia(11)
 387       escloc=energia(12)
 388       etors=energia(13)
 389       etors_d=energia(14)
 390       ehpb=energia(15)
 391       edihcnstr=energia(19)
 392       estr=energia(17)
 393       Uconst=energia(20)
 394       esccor=energia(21)
 395 #ifdef SPLITELE
 396       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 397      & +wang*ebe+wtor*etors+wscloc*escloc
 398      & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5
 399      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 400      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 401      & +wbond*estr+Uconst+wsccor*esccor
 402 #else
 403       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 404      & +wang*ebe+wtor*etors+wscloc*escloc
 405      & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5
 406      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 407      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 408      & +wbond*estr+Uconst+wsccor*esccor
 409 #endif
 410       energia(0)=etot
 411 c detecting NaNQ
 412 #ifdef ISNAN
 413 #ifdef AIX
 414       if (isnan(etot).ne.0) energia(0)=1.0d+99
 415 #else
 416       if (isnan(etot)) energia(0)=1.0d+99
 417 #endif
 418 #else
 419       i=0
 420 #ifdef WINPGI
 421       idumm=proc_proc(etot,i)
 422 #else
 423       call proc_proc(etot,i)
 424 #endif
 425       if(i.eq.1)energia(0)=1.0d+99
 426 #endif
 427 #ifdef MPI
 428       endif
 429 #endif
 430       return
 431       end
 432 c-------------------------------------------------------------------------------
 433       subroutine sum_gradient
 434       implicit real*8 (a-h,o-z)
 435       include 'DIMENSIONS'
 436 #ifndef ISNAN
 437       external proc_proc
 438 #ifdef WINPGI
 439 cMS$ATTRIBUTES C ::  proc_proc
 440 #endif
 441 #endif
 442 #ifdef MPI
 443       include 'mpif.h'
 444 #endif
 445       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 446      &  glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres)
 447       include 'COMMON.SETUP'
 448       include 'COMMON.IOUNITS'
 449       include 'COMMON.FFIELD'
 450       include 'COMMON.DERIV'
 451       include 'COMMON.INTERACT'
 452       include 'COMMON.SBRIDGE'
 453       include 'COMMON.CHAIN'
 454       include 'COMMON.VAR'
 455       include 'COMMON.CONTROL'
 456       include 'COMMON.TIME1'
 457       include 'COMMON.MAXGRAD'
 458       include 'COMMON.SCCOR'
 459 #ifdef TIMING
 460 #ifdef MPI
 461       time01=MPI_Wtime()
 462 #else
 463       time01=tcpu()
 464 #endif
 465 #endif
 466 #ifdef DEBUG
 467       write (iout,*) "sum_gradient gvdwc, gvdwx"
 468       do i=1,nres
 469         write (iout,'(i3,3f10.5,5x,3f10.5,5x,3f10.5,5x,3f10.5)')
 470      &   i,(gvdwx(j,i),j=1,3),(gvdwcT(j,i),j=1,3),(gvdwc(j,i),j=1,3),
 471      &   (gvdwcT(j,i),j=1,3)
 472       enddo
 473       call flush(iout)
 474 #endif
 475 #ifdef MPI
 476 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 477         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 478      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 479 #endif
 480 C
 481 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 482 C            in virtual-bond-vector coordinates
 483 C
 484 #ifdef DEBUG
 485 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 486 c      do i=1,nres-1
 487 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 488 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 489 c      enddo
 490 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 491 c      do i=1,nres-1
 492 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 493 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 494 c      enddo
 495       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 496       do i=1,nres
 497         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 498      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 499      &   g_corr5_loc(i)
 500       enddo
 501       call flush(iout)
 502 #endif
 503 #ifdef SPLITELE
 504 #ifdef TSCSC
 505       do i=1,nct
 506         do j=1,3
 507           gradbufc(j,i)=wsc*gvdwc(j,i)+wsc*wscT*gvdwcT(j,i)+
 508      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 509      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 510      &                wel_loc*gel_loc_long(j,i)+
 511      &                wcorr*gradcorr_long(j,i)+
 512      &                wcorr5*gradcorr5_long(j,i)+
 513      &                wcorr6*gradcorr6_long(j,i)+
 514      &                wturn6*gcorr6_turn_long(j,i)+
 515      &                wstrain*ghpbc(j,i)
 516         enddo
 517       enddo
 518 #else
 519       do i=1,nct
 520         do j=1,3
 521           gradbufc(j,i)=wsc*gvdwc(j,i)+
 522      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 523      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 524      &                wel_loc*gel_loc_long(j,i)+
 525      &                wcorr*gradcorr_long(j,i)+
 526      &                wcorr5*gradcorr5_long(j,i)+
 527      &                wcorr6*gradcorr6_long(j,i)+
 528      &                wturn6*gcorr6_turn_long(j,i)+
 529      &                wstrain*ghpbc(j,i)
 530         enddo
 531       enddo
 532 #endif
 533 #else
 534       do i=1,nct
 535         do j=1,3
 536           gradbufc(j,i)=wsc*gvdwc(j,i)+
 537      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 538      &                welec*gelc_long(j,i)+
 539      &                wbond*gradb(j,i)+
 540      &                wel_loc*gel_loc_long(j,i)+
 541      &                wcorr*gradcorr_long(j,i)+
 542      &                wcorr5*gradcorr5_long(j,i)+
 543      &                wcorr6*gradcorr6_long(j,i)+
 544      &                wturn6*gcorr6_turn_long(j,i)+
 545      &                wstrain*ghpbc(j,i)
 546         enddo
 547       enddo
 548 #endif
 549 #ifdef MPI
 550       if (nfgtasks.gt.1) then
 551       time00=MPI_Wtime()
 552 #ifdef DEBUG
 553       write (iout,*) "gradbufc before allreduce"
 554       do i=1,nres
 555         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 556       enddo
 557       call flush(iout)
 558 #endif
 559       do i=1,nres
 560         do j=1,3
 561           gradbufc_sum(j,i)=gradbufc(j,i)
 562         enddo
 563       enddo
 564 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 565 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 566 c      time_reduce=time_reduce+MPI_Wtime()-time00
 567 #ifdef DEBUG
 568 c      write (iout,*) "gradbufc_sum after allreduce"
 569 c      do i=1,nres
 570 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 571 c      enddo
 572 c      call flush(iout)
 573 #endif
 574 #ifdef TIMING
 575 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 576 #endif
 577       do i=nnt,nres
 578         do k=1,3
 579           gradbufc(k,i)=0.0d0
 580         enddo
 581       enddo
 582 #ifdef DEBUG
 583       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 584       write (iout,*) (i," jgrad_start",jgrad_start(i),
 585      &                  " jgrad_end  ",jgrad_end(i),
 586      &                  i=igrad_start,igrad_end)
 587 #endif
 588 c
 589 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 590 c do not parallelize this part.
 591 c
 592 c      do i=igrad_start,igrad_end
 593 c        do j=jgrad_start(i),jgrad_end(i)
 594 c          do k=1,3
 595 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 596 c          enddo
 597 c        enddo
 598 c      enddo
 599       do j=1,3
 600         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 601       enddo
 602       do i=nres-2,nnt,-1
 603         do j=1,3
 604           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 605         enddo
 606       enddo
 607 #ifdef DEBUG
 608       write (iout,*) "gradbufc after summing"
 609       do i=1,nres
 610         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 611       enddo
 612       call flush(iout)
 613 #endif
 614       else
 615 #endif
 616 #ifdef DEBUG
 617       write (iout,*) "gradbufc"
 618       do i=1,nres
 619         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 620       enddo
 621       call flush(iout)
 622 #endif
 623       do i=1,nres
 624         do j=1,3
 625           gradbufc_sum(j,i)=gradbufc(j,i)
 626           gradbufc(j,i)=0.0d0
 627         enddo
 628       enddo
 629       do j=1,3
 630         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 631       enddo
 632       do i=nres-2,nnt,-1
 633         do j=1,3
 634           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 635         enddo
 636       enddo
 637 c      do i=nnt,nres-1
 638 c        do k=1,3
 639 c          gradbufc(k,i)=0.0d0
 640 c        enddo
 641 c        do j=i+1,nres
 642 c          do k=1,3
 643 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 644 c          enddo
 645 c        enddo
 646 c      enddo
 647 #ifdef DEBUG
 648       write (iout,*) "gradbufc after summing"
 649       do i=1,nres
 650         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 651       enddo
 652       call flush(iout)
 653 #endif
 654 #ifdef MPI
 655       endif
 656 #endif
 657       do k=1,3
 658         gradbufc(k,nres)=0.0d0
 659       enddo
 660       do i=1,nct
 661         do j=1,3
 662 #ifdef SPLITELE
 663           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 664      &                wel_loc*gel_loc(j,i)+
 665      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 666      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 667      &                wel_loc*gel_loc_long(j,i)+
 668      &                wcorr*gradcorr_long(j,i)+
 669      &                wcorr5*gradcorr5_long(j,i)+
 670      &                wcorr6*gradcorr6_long(j,i)+
 671      &                wturn6*gcorr6_turn_long(j,i))+
 672      &                wbond*gradb(j,i)+
 673      &                wcorr*gradcorr(j,i)+
 674      &                wturn3*gcorr3_turn(j,i)+
 675      &                wturn4*gcorr4_turn(j,i)+
 676      &                wcorr5*gradcorr5(j,i)+
 677      &                wcorr6*gradcorr6(j,i)+
 678      &                wturn6*gcorr6_turn(j,i)+
 679      &                wsccor*gsccorc(j,i)
 680      &               +wscloc*gscloc(j,i)
 681 #else
 682           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 683      &                wel_loc*gel_loc(j,i)+
 684      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 685      &                welec*gelc_long(j,i)+
 686      &                wel_loc*gel_loc_long(j,i)+
 687      &                wcorr*gcorr_long(j,i)+
 688      &                wcorr5*gradcorr5_long(j,i)+
 689      &                wcorr6*gradcorr6_long(j,i)+
 690      &                wturn6*gcorr6_turn_long(j,i))+
 691      &                wbond*gradb(j,i)+
 692      &                wcorr*gradcorr(j,i)+
 693      &                wturn3*gcorr3_turn(j,i)+
 694      &                wturn4*gcorr4_turn(j,i)+
 695      &                wcorr5*gradcorr5(j,i)+
 696      &                wcorr6*gradcorr6(j,i)+
 697      &                wturn6*gcorr6_turn(j,i)+
 698      &                wsccor*gsccorc(j,i)
 699      &               +wscloc*gscloc(j,i)
 700 #endif
 701 #ifdef TSCSC
 702           gradx(j,i,icg)=wsc*gvdwx(j,i)+wsc*wscT*gvdwxT(j,i)+
 703      &                  wscp*gradx_scp(j,i)+
 704      &                  wbond*gradbx(j,i)+
 705      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 706      &                  wsccor*gsccorx(j,i)
 707      &                 +wscloc*gsclocx(j,i)
 708 #else
 709           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 710      &                  wbond*gradbx(j,i)+
 711      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 712      &                  wsccor*gsccorx(j,i)
 713      &                 +wscloc*gsclocx(j,i)
 714 #endif
 715         enddo
 716       enddo
 717 #ifdef DEBUG
 718       write (iout,*) "gloc before adding corr"
 719       do i=1,4*nres
 720         write (iout,*) i,gloc(i,icg)
 721       enddo
 722 #endif
 723       do i=1,nres-3
 724         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 725      &   +wcorr5*g_corr5_loc(i)
 726      &   +wcorr6*g_corr6_loc(i)
 727      &   +wturn4*gel_loc_turn4(i)
 728      &   +wturn3*gel_loc_turn3(i)
 729      &   +wturn6*gel_loc_turn6(i)
 730      &   +wel_loc*gel_loc_loc(i)
 731       enddo
 732 #ifdef DEBUG
 733       write (iout,*) "gloc after adding corr"
 734       do i=1,4*nres
 735         write (iout,*) i,gloc(i,icg)
 736       enddo
 737 #endif
 738 #ifdef MPI
 739       if (nfgtasks.gt.1) then
 740         do j=1,3
 741           do i=1,nres
 742             gradbufc(j,i)=gradc(j,i,icg)
 743             gradbufx(j,i)=gradx(j,i,icg)
 744           enddo
 745         enddo
 746         do i=1,4*nres
 747           glocbuf(i)=gloc(i,icg)
 748         enddo
 749 #ifdef DEBUG
 750       write (iout,*) "gloc_sc before reduce"
 751       do i=1,nres
 752        do j=1,3
 753         write (iout,*) i,j,gloc_sc(j,i,icg)
 754        enddo
 755       enddo
 756 #endif
 757         do i=1,nres
 758          do j=1,3
 759           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 760          enddo
 761         enddo
 762         time00=MPI_Wtime()
 763         call MPI_Barrier(FG_COMM,IERR)
 764         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 765         time00=MPI_Wtime()
 766         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 767      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 768         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 769      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 770         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 771      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 772         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 773      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 774         time_reduce=time_reduce+MPI_Wtime()-time00
 775 #ifdef DEBUG
 776       write (iout,*) "gloc_sc after reduce"
 777       do i=1,nres
 778        do j=1,3
 779         write (iout,*) i,j,gloc_sc(j,i,icg)
 780        enddo
 781       enddo
 782 #endif
 783 #ifdef DEBUG
 784       write (iout,*) "gloc after reduce"
 785       do i=1,4*nres
 786         write (iout,*) i,gloc(i,icg)
 787       enddo
 788 #endif
 789       endif
 790 #endif
 791       if (gnorm_check) then
 792 c
 793 c Compute the maximum elements of the gradient
 794 c
 795       gvdwc_max=0.0d0
 796       gvdwc_scp_max=0.0d0
 797       gelc_max=0.0d0
 798       gvdwpp_max=0.0d0
 799       gradb_max=0.0d0
 800       ghpbc_max=0.0d0
 801       gradcorr_max=0.0d0
 802       gel_loc_max=0.0d0
 803       gcorr3_turn_max=0.0d0
 804       gcorr4_turn_max=0.0d0
 805       gradcorr5_max=0.0d0
 806       gradcorr6_max=0.0d0
 807       gcorr6_turn_max=0.0d0
 808       gsccorc_max=0.0d0
 809       gscloc_max=0.0d0
 810       gvdwx_max=0.0d0
 811       gradx_scp_max=0.0d0
 812       ghpbx_max=0.0d0
 813       gradxorr_max=0.0d0
 814       gsccorx_max=0.0d0
 815       gsclocx_max=0.0d0
 816       do i=1,nct
 817         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 818         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 819 #ifdef TSCSC
 820         gvdwc_norm=dsqrt(scalar(gvdwcT(1,i),gvdwcT(1,i)))
 821         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 822 #endif
 823         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 824         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 825      &   gvdwc_scp_max=gvdwc_scp_norm
 826         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 827         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 828         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 829         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 830         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 831         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 832         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 833         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 834         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 835         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 836         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 837         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 838         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 839      &    gcorr3_turn(1,i)))
 840         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 841      &    gcorr3_turn_max=gcorr3_turn_norm
 842         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 843      &    gcorr4_turn(1,i)))
 844         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 845      &    gcorr4_turn_max=gcorr4_turn_norm
 846         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 847         if (gradcorr5_norm.gt.gradcorr5_max)
 848      &    gradcorr5_max=gradcorr5_norm
 849         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 850         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 851         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 852      &    gcorr6_turn(1,i)))
 853         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 854      &    gcorr6_turn_max=gcorr6_turn_norm
 855         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 856         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 857         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 858         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 859         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 860         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 861 #ifdef TSCSC
 862         gvdwx_norm=dsqrt(scalar(gvdwxT(1,i),gvdwxT(1,i)))
 863         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 864 #endif
 865         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 866         if (gradx_scp_norm.gt.gradx_scp_max)
 867      &    gradx_scp_max=gradx_scp_norm
 868         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 869         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 870         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 871         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 872         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 873         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 874         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 875         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 876       enddo
 877       if (gradout) then
 878 #ifdef AIX
 879         open(istat,file=statname,position="append")
 880 #else
 881         open(istat,file=statname,access="append")
 882 #endif
 883         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 884      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 885      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 886      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 887      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 888      &     gsccorx_max,gsclocx_max
 889         close(istat)
 890         if (gvdwc_max.gt.1.0d4) then
 891           write (iout,*) "gvdwc gvdwx gradb gradbx"
 892           do i=nnt,nct
 893             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 894      &        gradb(j,i),gradbx(j,i),j=1,3)
 895           enddo
 896           call pdbout(0.0d0,'cipiszcze',iout)
 897           call flush(iout)
 898         endif
 899       endif
 900       endif
 901 #ifdef DEBUG
 902       write (iout,*) "gradc gradx gloc"
 903       do i=1,nres
 904         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 905      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 906       enddo
 907 #endif
 908 #ifdef TIMING
 909 #ifdef MPI
 910       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 911 #else
 912       time_sumgradient=time_sumgradient+tcpu()-time01
 913 #endif
 914 #endif
 915       return
 916       end
 917 c-------------------------------------------------------------------------------
 918       subroutine rescale_weights(t_bath)
 919       implicit real*8 (a-h,o-z)
 920       include 'DIMENSIONS'
 921       include 'COMMON.IOUNITS'
 922       include 'COMMON.FFIELD'
 923       include 'COMMON.SBRIDGE'
 924       double precision kfac /2.4d0/
 925       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 926 c      facT=temp0/t_bath
 927 c      facT=2*temp0/(t_bath+temp0)
 928       if (rescale_mode.eq.0) then
 929         facT=1.0d0
 930         facT2=1.0d0
 931         facT3=1.0d0
 932         facT4=1.0d0
 933         facT5=1.0d0
 934       else if (rescale_mode.eq.1) then
 935         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 936         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 937         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 938         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 939         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 940       else if (rescale_mode.eq.2) then
 941         x=t_bath/temp0
 942         x2=x*x
 943         x3=x2*x
 944         x4=x3*x
 945         x5=x4*x
 946         facT=licznik/dlog(dexp(x)+dexp(-x))
 947         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 948         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 949         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 950         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 951       else
 952         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 953         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 954 #ifdef MPI
 955        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 956 #endif
 957        stop 555
 958       endif
 959       welec=weights(3)*fact
 960       wcorr=weights(4)*fact3
 961       wcorr5=weights(5)*fact4
 962       wcorr6=weights(6)*fact5
 963       wel_loc=weights(7)*fact2
 964       wturn3=weights(8)*fact2
 965       wturn4=weights(9)*fact3
 966       wturn6=weights(10)*fact5
 967       wtor=weights(13)*fact
 968       wtor_d=weights(14)*fact2
 969       wsccor=weights(21)*fact
 970 #ifdef TSCSC
 971 c      wsct=t_bath/temp0
 972       wsct=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
 973 #endif
 974       return
 975       end
 976 C------------------------------------------------------------------------
 977       subroutine enerprint(energia)
 978       implicit real*8 (a-h,o-z)
 979       include 'DIMENSIONS'
 980       include 'COMMON.IOUNITS'
 981       include 'COMMON.FFIELD'
 982       include 'COMMON.SBRIDGE'
 983       include 'COMMON.MD_'
 984       double precision energia(0:n_ene)
 985       etot=energia(0)
 986 #ifdef TSCSC
 987       evdw=energia(22)+wsct*energia(23)
 988 #else
 989       evdw=energia(1)
 990 #endif
 991       evdw2=energia(2)
 992 #ifdef SCP14
 993       evdw2=energia(2)+energia(18)
 994 #else
 995       evdw2=energia(2)
 996 #endif
 997       ees=energia(3)
 998 #ifdef SPLITELE
 999       evdw1=energia(16)
1000 #endif
1001       ecorr=energia(4)
1002       ecorr5=energia(5)
1003       ecorr6=energia(6)
1004       eel_loc=energia(7)
1005       eello_turn3=energia(8)
1006       eello_turn4=energia(9)
1007       eello_turn6=energia(10)
1008       ebe=energia(11)
1009       escloc=energia(12)
1010       etors=energia(13)
1011       etors_d=energia(14)
1012       ehpb=energia(15)
1013       edihcnstr=energia(19)
1014       estr=energia(17)
1015       Uconst=energia(20)
1016       esccor=energia(21)
1017 #ifdef SPLITELE
1018       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1019      &  estr,wbond,ebe,wang,
1020      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1021      &  ecorr,wcorr,
1022      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1023      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
1024      &  edihcnstr,ebr*nss,
1025      &  Uconst,etot
1026    10 format (/'Virtual-chain energies:'//
1027      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
1028      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
1029      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
1030      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pE16.6,' (p-p VDW)'/
1031      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
1032      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
1033      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
1034      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
1035      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
1036      & 'EHPB=  ',1pE16.6,' WEIGHT=',1pE16.6,
1037      & ' (SS bridges & dist. cnstr.)'/
1038      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1039      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1040      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1041      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
1042      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
1043      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
1044      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
1045      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
1046      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1047      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1048      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1049      & 'ETOT=  ',1pE16.6,' (total)')
1050 #else
1051       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
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,wsccro,edihcnstr,
1057      &  ebr*nss,Uconst,etot
1058    10 format (/'Virtual-chain energies:'//
1059      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1060      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1061      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1062      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1063      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1064      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1065      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1066      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1067      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1068      & ' (SS bridges & dist. cnstr.)'/
1069      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1070      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1071      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1072      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1073      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1074      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1075      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1076      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1077      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1078      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1079      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1080      & 'ETOT=  ',1pE16.6,' (total)')
1081 #endif
1082       return
1083       end
1084 C-----------------------------------------------------------------------
1085       subroutine elj(evdw,evdw_p,evdw_m)
1086 C
1087 C This subroutine calculates the interaction energy of nonbonded side chains
1088 C assuming the LJ potential of interaction.
1089 C
1090       implicit real*8 (a-h,o-z)
1091       include 'DIMENSIONS'
1092       parameter (accur=1.0d-10)
1093       include 'COMMON.GEO'
1094       include 'COMMON.VAR'
1095       include 'COMMON.LOCAL'
1096       include 'COMMON.CHAIN'
1097       include 'COMMON.DERIV'
1098       include 'COMMON.INTERACT'
1099       include 'COMMON.TORSION'
1100       include 'COMMON.SBRIDGE'
1101       include 'COMMON.NAMES'
1102       include 'COMMON.IOUNITS'
1103       include 'COMMON.CONTACTS'
1104       dimension gg(3)
1105 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1106       evdw=0.0D0
1107       do i=iatsc_s,iatsc_e
1108         itypi=itype(i)
1109         itypi1=itype(i+1)
1110         xi=c(1,nres+i)
1111         yi=c(2,nres+i)
1112         zi=c(3,nres+i)
1113 C Change 12/1/95
1114         num_conti=0
1115 C
1116 C Calculate SC interaction energy.
1117 C
1118         do iint=1,nint_gr(i)
1119 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1120 cd   &                  'iend=',iend(i,iint)
1121           do j=istart(i,iint),iend(i,iint)
1122             itypj=itype(j)
1123             xj=c(1,nres+j)-xi
1124             yj=c(2,nres+j)-yi
1125             zj=c(3,nres+j)-zi
1126 C Change 12/1/95 to calculate four-body interactions
1127             rij=xj*xj+yj*yj+zj*zj
1128             rrij=1.0D0/rij
1129 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1130             eps0ij=eps(itypi,itypj)
1131             fac=rrij**expon2
1132             e1=fac*fac*aa(itypi,itypj)
1133             e2=fac*bb(itypi,itypj)
1134             evdwij=e1+e2
1135 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1136 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1137 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1138 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1139 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1140 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1141 #ifdef TSCSC
1142             if (bb(itypi,itypj).gt.0) then
1143                evdw_p=evdw_p+evdwij
1144             else
1145                evdw_m=evdw_m+evdwij
1146             endif
1147 #else
1148             evdw=evdw+evdwij
1149 #endif
1150 C
1151 C Calculate the components of the gradient in DC and X
1152 C
1153             fac=-rrij*(e1+evdwij)
1154             gg(1)=xj*fac
1155             gg(2)=yj*fac
1156             gg(3)=zj*fac
1157 #ifdef TSCSC
1158             if (bb(itypi,itypj).gt.0.0d0) then
1159               do k=1,3
1160                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1161                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1162                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1163                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1164               enddo
1165             else
1166               do k=1,3
1167                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1168                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1169                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1170                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1171               enddo
1172             endif
1173 #else
1174             do k=1,3
1175               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1176               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1177               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1178               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1179             enddo
1180 #endif
1181 cgrad            do k=i,j-1
1182 cgrad              do l=1,3
1183 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1184 cgrad              enddo
1185 cgrad            enddo
1186 C
1187 C 12/1/95, revised on 5/20/97
1188 C
1189 C Calculate the contact function. The ith column of the array JCONT will
1190 C contain the numbers of atoms that make contacts with the atom I (of numbers
1191 C greater than I). The arrays FACONT and GACONT will contain the values of
1192 C the contact function and its derivative.
1193 C
1194 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1195 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1196 C Uncomment next line, if the correlation interactions are contact function only
1197             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1198               rij=dsqrt(rij)
1199               sigij=sigma(itypi,itypj)
1200               r0ij=rs0(itypi,itypj)
1201 C
1202 C Check whether the SC's are not too far to make a contact.
1203 C
1204               rcut=1.5d0*r0ij
1205               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1206 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1207 C
1208               if (fcont.gt.0.0D0) then
1209 C If the SC-SC distance if close to sigma, apply spline.
1210 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1211 cAdam &             fcont1,fprimcont1)
1212 cAdam           fcont1=1.0d0-fcont1
1213 cAdam           if (fcont1.gt.0.0d0) then
1214 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1215 cAdam             fcont=fcont*fcont1
1216 cAdam           endif
1217 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1218 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1219 cga             do k=1,3
1220 cga               gg(k)=gg(k)*eps0ij
1221 cga             enddo
1222 cga             eps0ij=-evdwij*eps0ij
1223 C Uncomment for AL's type of SC correlation interactions.
1224 cadam           eps0ij=-evdwij
1225                 num_conti=num_conti+1
1226                 jcont(num_conti,i)=j
1227                 facont(num_conti,i)=fcont*eps0ij
1228                 fprimcont=eps0ij*fprimcont/rij
1229                 fcont=expon*fcont
1230 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1231 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1232 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1233 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1234                 gacont(1,num_conti,i)=-fprimcont*xj
1235                 gacont(2,num_conti,i)=-fprimcont*yj
1236                 gacont(3,num_conti,i)=-fprimcont*zj
1237 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1238 cd              write (iout,'(2i3,3f10.5)')
1239 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1240               endif
1241             endif
1242           enddo      ! j
1243         enddo        ! iint
1244 C Change 12/1/95
1245         num_cont(i)=num_conti
1246       enddo          ! i
1247       do i=1,nct
1248         do j=1,3
1249           gvdwc(j,i)=expon*gvdwc(j,i)
1250           gvdwx(j,i)=expon*gvdwx(j,i)
1251         enddo
1252       enddo
1253 C******************************************************************************
1254 C
1255 C                              N O T E !!!
1256 C
1257 C To save time, the factor of EXPON has been extracted from ALL components
1258 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1259 C use!
1260 C
1261 C******************************************************************************
1262       return
1263       end
1264 C-----------------------------------------------------------------------------
1265       subroutine eljk(evdw,evdw_p,evdw_m)
1266 C
1267 C This subroutine calculates the interaction energy of nonbonded side chains
1268 C assuming the LJK potential of interaction.
1269 C
1270       implicit real*8 (a-h,o-z)
1271       include 'DIMENSIONS'
1272       include 'COMMON.GEO'
1273       include 'COMMON.VAR'
1274       include 'COMMON.LOCAL'
1275       include 'COMMON.CHAIN'
1276       include 'COMMON.DERIV'
1277       include 'COMMON.INTERACT'
1278       include 'COMMON.IOUNITS'
1279       include 'COMMON.NAMES'
1280       dimension gg(3)
1281       logical scheck
1282 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1283       evdw=0.0D0
1284       do i=iatsc_s,iatsc_e
1285         itypi=itype(i)
1286         itypi1=itype(i+1)
1287         xi=c(1,nres+i)
1288         yi=c(2,nres+i)
1289         zi=c(3,nres+i)
1290 C
1291 C Calculate SC interaction energy.
1292 C
1293         do iint=1,nint_gr(i)
1294           do j=istart(i,iint),iend(i,iint)
1295             itypj=itype(j)
1296             xj=c(1,nres+j)-xi
1297             yj=c(2,nres+j)-yi
1298             zj=c(3,nres+j)-zi
1299             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1300             fac_augm=rrij**expon
1301             e_augm=augm(itypi,itypj)*fac_augm
1302             r_inv_ij=dsqrt(rrij)
1303             rij=1.0D0/r_inv_ij
1304             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1305             fac=r_shift_inv**expon
1306             e1=fac*fac*aa(itypi,itypj)
1307             e2=fac*bb(itypi,itypj)
1308             evdwij=e_augm+e1+e2
1309 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1310 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1311 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1312 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1313 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1314 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1315 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1316 #ifdef TSCSC
1317             if (bb(itypi,itypj).gt.0) then
1318                evdw_p=evdw_p+evdwij
1319             else
1320                evdw_m=evdw_m+evdwij
1321             endif
1322 #else
1323             evdw=evdw+evdwij
1324 #endif
1325 C
1326 C Calculate the components of the gradient in DC and X
1327 C
1328             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1329             gg(1)=xj*fac
1330             gg(2)=yj*fac
1331             gg(3)=zj*fac
1332 #ifdef TSCSC
1333             if (bb(itypi,itypj).gt.0.0d0) then
1334               do k=1,3
1335                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1336                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1337                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1338                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1339               enddo
1340             else
1341               do k=1,3
1342                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1343                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1344                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1345                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1346               enddo
1347             endif
1348 #else
1349             do k=1,3
1350               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1351               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1352               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1353               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1354             enddo
1355 #endif
1356 cgrad            do k=i,j-1
1357 cgrad              do l=1,3
1358 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1359 cgrad              enddo
1360 cgrad            enddo
1361           enddo      ! j
1362         enddo        ! iint
1363       enddo          ! i
1364       do i=1,nct
1365         do j=1,3
1366           gvdwc(j,i)=expon*gvdwc(j,i)
1367           gvdwx(j,i)=expon*gvdwx(j,i)
1368         enddo
1369       enddo
1370       return
1371       end
1372 C-----------------------------------------------------------------------------
1373       subroutine ebp(evdw,evdw_p,evdw_m)
1374 C
1375 C This subroutine calculates the interaction energy of nonbonded side chains
1376 C assuming the Berne-Pechukas potential of interaction.
1377 C
1378       implicit real*8 (a-h,o-z)
1379       include 'DIMENSIONS'
1380       include 'COMMON.GEO'
1381       include 'COMMON.VAR'
1382       include 'COMMON.LOCAL'
1383       include 'COMMON.CHAIN'
1384       include 'COMMON.DERIV'
1385       include 'COMMON.NAMES'
1386       include 'COMMON.INTERACT'
1387       include 'COMMON.IOUNITS'
1388       include 'COMMON.CALC'
1389       common /srutu/ icall
1390 c     double precision rrsave(maxdim)
1391       logical lprn
1392       evdw=0.0D0
1393 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1394       evdw=0.0D0
1395 c     if (icall.eq.0) then
1396 c       lprn=.true.
1397 c     else
1398         lprn=.false.
1399 c     endif
1400       ind=0
1401       do i=iatsc_s,iatsc_e
1402         itypi=itype(i)
1403         itypi1=itype(i+1)
1404         xi=c(1,nres+i)
1405         yi=c(2,nres+i)
1406         zi=c(3,nres+i)
1407         dxi=dc_norm(1,nres+i)
1408         dyi=dc_norm(2,nres+i)
1409         dzi=dc_norm(3,nres+i)
1410 c        dsci_inv=dsc_inv(itypi)
1411         dsci_inv=vbld_inv(i+nres)
1412 C
1413 C Calculate SC interaction energy.
1414 C
1415         do iint=1,nint_gr(i)
1416           do j=istart(i,iint),iend(i,iint)
1417             ind=ind+1
1418             itypj=itype(j)
1419 c            dscj_inv=dsc_inv(itypj)
1420             dscj_inv=vbld_inv(j+nres)
1421             chi1=chi(itypi,itypj)
1422             chi2=chi(itypj,itypi)
1423             chi12=chi1*chi2
1424             chip1=chip(itypi)
1425             chip2=chip(itypj)
1426             chip12=chip1*chip2
1427             alf1=alp(itypi)
1428             alf2=alp(itypj)
1429             alf12=0.5D0*(alf1+alf2)
1430 C For diagnostics only!!!
1431 c           chi1=0.0D0
1432 c           chi2=0.0D0
1433 c           chi12=0.0D0
1434 c           chip1=0.0D0
1435 c           chip2=0.0D0
1436 c           chip12=0.0D0
1437 c           alf1=0.0D0
1438 c           alf2=0.0D0
1439 c           alf12=0.0D0
1440             xj=c(1,nres+j)-xi
1441             yj=c(2,nres+j)-yi
1442             zj=c(3,nres+j)-zi
1443             dxj=dc_norm(1,nres+j)
1444             dyj=dc_norm(2,nres+j)
1445             dzj=dc_norm(3,nres+j)
1446             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1447 cd          if (icall.eq.0) then
1448 cd            rrsave(ind)=rrij
1449 cd          else
1450 cd            rrij=rrsave(ind)
1451 cd          endif
1452             rij=dsqrt(rrij)
1453 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1454             call sc_angular
1455 C Calculate whole angle-dependent part of epsilon and contributions
1456 C to its derivatives
1457             fac=(rrij*sigsq)**expon2
1458             e1=fac*fac*aa(itypi,itypj)
1459             e2=fac*bb(itypi,itypj)
1460             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1461             eps2der=evdwij*eps3rt
1462             eps3der=evdwij*eps2rt
1463             evdwij=evdwij*eps2rt*eps3rt
1464 #ifdef TSCSC
1465             if (bb(itypi,itypj).gt.0) then
1466                evdw_p=evdw_p+evdwij
1467             else
1468                evdw_m=evdw_m+evdwij
1469             endif
1470 #else
1471             evdw=evdw+evdwij
1472 #endif
1473             if (lprn) then
1474             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1475             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1476 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1477 cd     &        restyp(itypi),i,restyp(itypj),j,
1478 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1479 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1480 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1481 cd     &        evdwij
1482             endif
1483 C Calculate gradient components.
1484             e1=e1*eps1*eps2rt**2*eps3rt**2
1485             fac=-expon*(e1+evdwij)
1486             sigder=fac/sigsq
1487             fac=rrij*fac
1488 C Calculate radial part of the gradient
1489             gg(1)=xj*fac
1490             gg(2)=yj*fac
1491             gg(3)=zj*fac
1492 C Calculate the angular part of the gradient and sum add the contributions
1493 C to the appropriate components of the Cartesian gradient.
1494 #ifdef TSCSC
1495             if (bb(itypi,itypj).gt.0) then
1496                call sc_grad
1497             else
1498                call sc_grad_T
1499             endif
1500 #else
1501             call sc_grad
1502 #endif
1503           enddo      ! j
1504         enddo        ! iint
1505       enddo          ! i
1506 c     stop
1507       return
1508       end
1509 C-----------------------------------------------------------------------------
1510       subroutine egb(evdw,evdw_p,evdw_m)
1511 C
1512 C This subroutine calculates the interaction energy of nonbonded side chains
1513 C assuming the Gay-Berne potential of interaction.
1514 C
1515       implicit real*8 (a-h,o-z)
1516       include 'DIMENSIONS'
1517       include 'COMMON.GEO'
1518       include 'COMMON.VAR'
1519       include 'COMMON.LOCAL'
1520       include 'COMMON.CHAIN'
1521       include 'COMMON.DERIV'
1522       include 'COMMON.NAMES'
1523       include 'COMMON.INTERACT'
1524       include 'COMMON.IOUNITS'
1525       include 'COMMON.CALC'
1526       include 'COMMON.CONTROL'
1527       logical lprn
1528       evdw=0.0D0
1529 ccccc      energy_dec=.false.
1530 c      write(iout,*) 'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1531       evdw=0.0D0
1532       evdw_p=0.0D0
1533       evdw_m=0.0D0
1534       lprn=.false.
1535 c     if (icall.eq.0) lprn=.false.
1536       ind=0
1537       do i=iatsc_s,iatsc_e
1538         itypi=itype(i)
1539         itypi1=itype(i+1)
1540         xi=c(1,nres+i)
1541         yi=c(2,nres+i)
1542         zi=c(3,nres+i)
1543         dxi=dc_norm(1,nres+i)
1544         dyi=dc_norm(2,nres+i)
1545         dzi=dc_norm(3,nres+i)
1546 c        dsci_inv=dsc_inv(itypi)
1547         dsci_inv=vbld_inv(i+nres)
1548 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1549 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1550 C
1551 C Calculate SC interaction energy.
1552 C
1553         do iint=1,nint_gr(i)
1554           do j=istart(i,iint),iend(i,iint)
1555             ind=ind+1
1556             itypj=itype(j)
1557 c            dscj_inv=dsc_inv(itypj)
1558             dscj_inv=vbld_inv(j+nres)
1559 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1560 c     &       1.0d0/vbld(j+nres)
1561 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1562             sig0ij=sigma(itypi,itypj)
1563             chi1=chi(itypi,itypj)
1564             chi2=chi(itypj,itypi)
1565             chi12=chi1*chi2
1566             chip1=chip(itypi)
1567             chip2=chip(itypj)
1568             chip12=chip1*chip2
1569             alf1=alp(itypi)
1570             alf2=alp(itypj)
1571             alf12=0.5D0*(alf1+alf2)
1572 C For diagnostics only!!!
1573 c           chi1=0.0D0
1574 c           chi2=0.0D0
1575 c           chi12=0.0D0
1576 c           chip1=0.0D0
1577 c           chip2=0.0D0
1578 c           chip12=0.0D0
1579 c           alf1=0.0D0
1580 c           alf2=0.0D0
1581 c           alf12=0.0D0
1582             xj=c(1,nres+j)-xi
1583             yj=c(2,nres+j)-yi
1584             zj=c(3,nres+j)-zi
1585             dxj=dc_norm(1,nres+j)
1586             dyj=dc_norm(2,nres+j)
1587             dzj=dc_norm(3,nres+j)
1588 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1589 c            write (iout,*) "j",j," dc_norm",
1590 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1591             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1592             rij=dsqrt(rrij)
1593 C Calculate angle-dependent terms of energy and contributions to their
1594 C derivatives.
1595             call sc_angular
1596             sigsq=1.0D0/sigsq
1597             sig=sig0ij*dsqrt(sigsq)
1598             rij_shift=1.0D0/rij-sig+sig0ij
1599 c for diagnostics; uncomment
1600 c            rij_shift=1.2*sig0ij
1601 C I hate to put IF's in the loops, but here don't have another choice!!!!
1602             if (rij_shift.le.0.0D0) then
1603               evdw=1.0D20
1604 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1605 cd     &        restyp(itypi),i,restyp(itypj),j,
1606 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1607               return
1608             endif
1609             sigder=-sig*sigsq
1610 c---------------------------------------------------------------
1611             rij_shift=1.0D0/rij_shift
1612             fac=rij_shift**expon
1613             e1=fac*fac*aa(itypi,itypj)
1614             e2=fac*bb(itypi,itypj)
1615             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1616             eps2der=evdwij*eps3rt
1617             eps3der=evdwij*eps2rt
1618 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1619 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1620             evdwij=evdwij*eps2rt*eps3rt
1621 #ifdef TSCSC
1622             if (bb(itypi,itypj).gt.0) then
1623                evdw_p=evdw_p+evdwij
1624             else
1625                evdw_m=evdw_m+evdwij
1626             endif
1627 #else
1628             evdw=evdw+evdwij
1629 #endif
1630             if (lprn) then
1631             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1632             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1633             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1634      &        restyp(itypi),i,restyp(itypj),j,
1635      &        epsi,sigm,chi1,chi2,chip1,chip2,
1636      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1637      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1638      &        evdwij
1639             endif
1640
1641             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1642      &                        'evdw',i,j,evdwij
1643
1644 C Calculate gradient components.
1645             e1=e1*eps1*eps2rt**2*eps3rt**2
1646             fac=-expon*(e1+evdwij)*rij_shift
1647             sigder=fac*sigder
1648             fac=rij*fac
1649 c            fac=0.0d0
1650 C Calculate the radial part of the gradient
1651             gg(1)=xj*fac
1652             gg(2)=yj*fac
1653             gg(3)=zj*fac
1654 C Calculate angular part of the gradient.
1655 #ifdef TSCSC
1656             if (bb(itypi,itypj).gt.0) then
1657                call sc_grad
1658             else
1659                call sc_grad_T
1660             endif
1661 #else
1662             call sc_grad
1663 #endif
1664           enddo      ! j
1665         enddo        ! iint
1666       enddo          ! i
1667 c      write (iout,*) "Number of loop steps in EGB:",ind
1668 cccc      energy_dec=.false.
1669       return
1670       end
1671 C-----------------------------------------------------------------------------
1672       subroutine egbv(evdw,evdw_p,evdw_m)
1673 C
1674 C This subroutine calculates the interaction energy of nonbonded side chains
1675 C assuming the Gay-Berne-Vorobjev potential of interaction.
1676 C
1677       implicit real*8 (a-h,o-z)
1678       include 'DIMENSIONS'
1679       include 'COMMON.GEO'
1680       include 'COMMON.VAR'
1681       include 'COMMON.LOCAL'
1682       include 'COMMON.CHAIN'
1683       include 'COMMON.DERIV'
1684       include 'COMMON.NAMES'
1685       include 'COMMON.INTERACT'
1686       include 'COMMON.IOUNITS'
1687       include 'COMMON.CALC'
1688       common /srutu/ icall
1689       logical lprn
1690       evdw=0.0D0
1691 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1692       evdw=0.0D0
1693       lprn=.false.
1694 c     if (icall.eq.0) lprn=.true.
1695       ind=0
1696       do i=iatsc_s,iatsc_e
1697         itypi=itype(i)
1698         itypi1=itype(i+1)
1699         xi=c(1,nres+i)
1700         yi=c(2,nres+i)
1701         zi=c(3,nres+i)
1702         dxi=dc_norm(1,nres+i)
1703         dyi=dc_norm(2,nres+i)
1704         dzi=dc_norm(3,nres+i)
1705 c        dsci_inv=dsc_inv(itypi)
1706         dsci_inv=vbld_inv(i+nres)
1707 C
1708 C Calculate SC interaction energy.
1709 C
1710         do iint=1,nint_gr(i)
1711           do j=istart(i,iint),iend(i,iint)
1712             ind=ind+1
1713             itypj=itype(j)
1714 c            dscj_inv=dsc_inv(itypj)
1715             dscj_inv=vbld_inv(j+nres)
1716             sig0ij=sigma(itypi,itypj)
1717             r0ij=r0(itypi,itypj)
1718             chi1=chi(itypi,itypj)
1719             chi2=chi(itypj,itypi)
1720             chi12=chi1*chi2
1721             chip1=chip(itypi)
1722             chip2=chip(itypj)
1723             chip12=chip1*chip2
1724             alf1=alp(itypi)
1725             alf2=alp(itypj)
1726             alf12=0.5D0*(alf1+alf2)
1727 C For diagnostics only!!!
1728 c           chi1=0.0D0
1729 c           chi2=0.0D0
1730 c           chi12=0.0D0
1731 c           chip1=0.0D0
1732 c           chip2=0.0D0
1733 c           chip12=0.0D0
1734 c           alf1=0.0D0
1735 c           alf2=0.0D0
1736 c           alf12=0.0D0
1737             xj=c(1,nres+j)-xi
1738             yj=c(2,nres+j)-yi
1739             zj=c(3,nres+j)-zi
1740             dxj=dc_norm(1,nres+j)
1741             dyj=dc_norm(2,nres+j)
1742             dzj=dc_norm(3,nres+j)
1743             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1744             rij=dsqrt(rrij)
1745 C Calculate angle-dependent terms of energy and contributions to their
1746 C derivatives.
1747             call sc_angular
1748             sigsq=1.0D0/sigsq
1749             sig=sig0ij*dsqrt(sigsq)
1750             rij_shift=1.0D0/rij-sig+r0ij
1751 C I hate to put IF's in the loops, but here don't have another choice!!!!
1752             if (rij_shift.le.0.0D0) then
1753               evdw=1.0D20
1754               return
1755             endif
1756             sigder=-sig*sigsq
1757 c---------------------------------------------------------------
1758             rij_shift=1.0D0/rij_shift
1759             fac=rij_shift**expon
1760             e1=fac*fac*aa(itypi,itypj)
1761             e2=fac*bb(itypi,itypj)
1762             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1763             eps2der=evdwij*eps3rt
1764             eps3der=evdwij*eps2rt
1765             fac_augm=rrij**expon
1766             e_augm=augm(itypi,itypj)*fac_augm
1767             evdwij=evdwij*eps2rt*eps3rt
1768 #ifdef TSCSC
1769             if (bb(itypi,itypj).gt.0) then
1770                evdw_p=evdw_p+evdwij+e_augm
1771             else
1772                evdw_m=evdw_m+evdwij+e_augm
1773             endif
1774 #else
1775             evdw=evdw+evdwij+e_augm
1776 #endif
1777             if (lprn) then
1778             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1779             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1780             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1781      &        restyp(itypi),i,restyp(itypj),j,
1782      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1783      &        chi1,chi2,chip1,chip2,
1784      &        eps1,eps2rt**2,eps3rt**2,
1785      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1786      &        evdwij+e_augm
1787             endif
1788 C Calculate gradient components.
1789             e1=e1*eps1*eps2rt**2*eps3rt**2
1790             fac=-expon*(e1+evdwij)*rij_shift
1791             sigder=fac*sigder
1792             fac=rij*fac-2*expon*rrij*e_augm
1793 C Calculate the radial part of the gradient
1794             gg(1)=xj*fac
1795             gg(2)=yj*fac
1796             gg(3)=zj*fac
1797 C Calculate angular part of the gradient.
1798 #ifdef TSCSC
1799             if (bb(itypi,itypj).gt.0) then
1800                call sc_grad
1801             else
1802                call sc_grad_T
1803             endif
1804 #else
1805             call sc_grad
1806 #endif
1807           enddo      ! j
1808         enddo        ! iint
1809       enddo          ! i
1810       end
1811 C-----------------------------------------------------------------------------
1812       subroutine sc_angular
1813 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1814 C om12. Called by ebp, egb, and egbv.
1815       implicit none
1816       include 'COMMON.CALC'
1817       include 'COMMON.IOUNITS'
1818       erij(1)=xj*rij
1819       erij(2)=yj*rij
1820       erij(3)=zj*rij
1821       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1822       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1823       om12=dxi*dxj+dyi*dyj+dzi*dzj
1824       chiom12=chi12*om12
1825 C Calculate eps1(om12) and its derivative in om12
1826       faceps1=1.0D0-om12*chiom12
1827       faceps1_inv=1.0D0/faceps1
1828       eps1=dsqrt(faceps1_inv)
1829 C Following variable is eps1*deps1/dom12
1830       eps1_om12=faceps1_inv*chiom12
1831 c diagnostics only
1832 c      faceps1_inv=om12
1833 c      eps1=om12
1834 c      eps1_om12=1.0d0
1835 c      write (iout,*) "om12",om12," eps1",eps1
1836 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1837 C and om12.
1838       om1om2=om1*om2
1839       chiom1=chi1*om1
1840       chiom2=chi2*om2
1841       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1842       sigsq=1.0D0-facsig*faceps1_inv
1843       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1844       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1845       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1846 c diagnostics only
1847 c      sigsq=1.0d0
1848 c      sigsq_om1=0.0d0
1849 c      sigsq_om2=0.0d0
1850 c      sigsq_om12=0.0d0
1851 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1852 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1853 c     &    " eps1",eps1
1854 C Calculate eps2 and its derivatives in om1, om2, and om12.
1855       chipom1=chip1*om1
1856       chipom2=chip2*om2
1857       chipom12=chip12*om12
1858       facp=1.0D0-om12*chipom12
1859       facp_inv=1.0D0/facp
1860       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1861 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1862 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1863 C Following variable is the square root of eps2
1864       eps2rt=1.0D0-facp1*facp_inv
1865 C Following three variables are the derivatives of the square root of eps
1866 C in om1, om2, and om12.
1867       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1868       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1869       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1870 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1871       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1872 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1873 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1874 c     &  " eps2rt_om12",eps2rt_om12
1875 C Calculate whole angle-dependent part of epsilon and contributions
1876 C to its derivatives
1877       return
1878       end
1879
1880 C----------------------------------------------------------------------------
1881       subroutine sc_grad_T
1882       implicit real*8 (a-h,o-z)
1883       include 'DIMENSIONS'
1884       include 'COMMON.CHAIN'
1885       include 'COMMON.DERIV'
1886       include 'COMMON.CALC'
1887       include 'COMMON.IOUNITS'
1888       double precision dcosom1(3),dcosom2(3)
1889       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1890       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1891       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1892      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1893 c diagnostics only
1894 c      eom1=0.0d0
1895 c      eom2=0.0d0
1896 c      eom12=evdwij*eps1_om12
1897 c end diagnostics
1898 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1899 c     &  " sigder",sigder
1900 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1901 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1902       do k=1,3
1903         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1904         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1905       enddo
1906       do k=1,3
1907         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1908       enddo
1909 c      write (iout,*) "gg",(gg(k),k=1,3)
1910       do k=1,3
1911         gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1912      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1913      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1914         gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1915      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1916      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1917 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1918 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1919 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1920 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1921       enddo
1922 C
1923 C Calculate the components of the gradient in DC and X
1924 C
1925 cgrad      do k=i,j-1
1926 cgrad        do l=1,3
1927 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1928 cgrad        enddo
1929 cgrad      enddo
1930       do l=1,3
1931         gvdwcT(l,i)=gvdwcT(l,i)-gg(l)
1932         gvdwcT(l,j)=gvdwcT(l,j)+gg(l)
1933       enddo
1934       return
1935       end
1936
1937 C----------------------------------------------------------------------------
1938       subroutine sc_grad
1939       implicit real*8 (a-h,o-z)
1940       include 'DIMENSIONS'
1941       include 'COMMON.CHAIN'
1942       include 'COMMON.DERIV'
1943       include 'COMMON.CALC'
1944       include 'COMMON.IOUNITS'
1945       double precision dcosom1(3),dcosom2(3)
1946       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1947       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1948       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1949      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1950 c diagnostics only
1951 c      eom1=0.0d0
1952 c      eom2=0.0d0
1953 c      eom12=evdwij*eps1_om12
1954 c end diagnostics
1955 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1956 c     &  " sigder",sigder
1957 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1958 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1959       do k=1,3
1960         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1961         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1962       enddo
1963       do k=1,3
1964         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1965       enddo
1966 c      write (iout,*) "gg",(gg(k),k=1,3)
1967       do k=1,3
1968         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1969      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1970      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1971         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1972      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1973      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1974 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1975 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1976 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1977 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1978       enddo
1979 C
1980 C Calculate the components of the gradient in DC and X
1981 C
1982 cgrad      do k=i,j-1
1983 cgrad        do l=1,3
1984 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1985 cgrad        enddo
1986 cgrad      enddo
1987       do l=1,3
1988         gvdwc(l,i)=gvdwc(l,i)-gg(l)
1989         gvdwc(l,j)=gvdwc(l,j)+gg(l)
1990       enddo
1991       return
1992       end
1993 C-----------------------------------------------------------------------
1994       subroutine e_softsphere(evdw)
1995 C
1996 C This subroutine calculates the interaction energy of nonbonded side chains
1997 C assuming the LJ potential of interaction.
1998 C
1999       implicit real*8 (a-h,o-z)
2000       include 'DIMENSIONS'
2001       parameter (accur=1.0d-10)
2002       include 'COMMON.GEO'
2003       include 'COMMON.VAR'
2004       include 'COMMON.LOCAL'
2005       include 'COMMON.CHAIN'
2006       include 'COMMON.DERIV'
2007       include 'COMMON.INTERACT'
2008       include 'COMMON.TORSION'
2009       include 'COMMON.SBRIDGE'
2010       include 'COMMON.NAMES'
2011       include 'COMMON.IOUNITS'
2012       include 'COMMON.CONTACTS'
2013       dimension gg(3)
2014 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2015       evdw=0.0D0
2016       do i=iatsc_s,iatsc_e
2017         itypi=itype(i)
2018         itypi1=itype(i+1)
2019         xi=c(1,nres+i)
2020         yi=c(2,nres+i)
2021         zi=c(3,nres+i)
2022 C
2023 C Calculate SC interaction energy.
2024 C
2025         do iint=1,nint_gr(i)
2026 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2027 cd   &                  'iend=',iend(i,iint)
2028           do j=istart(i,iint),iend(i,iint)
2029             itypj=itype(j)
2030             xj=c(1,nres+j)-xi
2031             yj=c(2,nres+j)-yi
2032             zj=c(3,nres+j)-zi
2033             rij=xj*xj+yj*yj+zj*zj
2034 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2035             r0ij=r0(itypi,itypj)
2036             r0ijsq=r0ij*r0ij
2037 c            print *,i,j,r0ij,dsqrt(rij)
2038             if (rij.lt.r0ijsq) then
2039               evdwij=0.25d0*(rij-r0ijsq)**2
2040               fac=rij-r0ijsq
2041             else
2042               evdwij=0.0d0
2043               fac=0.0d0
2044             endif
2045             evdw=evdw+evdwij
2046 C
2047 C Calculate the components of the gradient in DC and X
2048 C
2049             gg(1)=xj*fac
2050             gg(2)=yj*fac
2051             gg(3)=zj*fac
2052             do k=1,3
2053               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2054               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2055               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2056               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2057             enddo
2058 cgrad            do k=i,j-1
2059 cgrad              do l=1,3
2060 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2061 cgrad              enddo
2062 cgrad            enddo
2063           enddo ! j
2064         enddo ! iint
2065       enddo ! i
2066       return
2067       end
2068 C--------------------------------------------------------------------------
2069       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2070      &              eello_turn4)
2071 C
2072 C Soft-sphere potential of p-p interaction
2073 C
2074       implicit real*8 (a-h,o-z)
2075       include 'DIMENSIONS'
2076       include 'COMMON.CONTROL'
2077       include 'COMMON.IOUNITS'
2078       include 'COMMON.GEO'
2079       include 'COMMON.VAR'
2080       include 'COMMON.LOCAL'
2081       include 'COMMON.CHAIN'
2082       include 'COMMON.DERIV'
2083       include 'COMMON.INTERACT'
2084       include 'COMMON.CONTACTS'
2085       include 'COMMON.TORSION'
2086       include 'COMMON.VECTORS'
2087       include 'COMMON.FFIELD'
2088       dimension ggg(3)
2089 cd      write(iout,*) 'In EELEC_soft_sphere'
2090       ees=0.0D0
2091       evdw1=0.0D0
2092       eel_loc=0.0d0
2093       eello_turn3=0.0d0
2094       eello_turn4=0.0d0
2095       ind=0
2096       do i=iatel_s,iatel_e
2097         dxi=dc(1,i)
2098         dyi=dc(2,i)
2099         dzi=dc(3,i)
2100         xmedi=c(1,i)+0.5d0*dxi
2101         ymedi=c(2,i)+0.5d0*dyi
2102         zmedi=c(3,i)+0.5d0*dzi
2103         num_conti=0
2104 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2105         do j=ielstart(i),ielend(i)
2106           ind=ind+1
2107           iteli=itel(i)
2108           itelj=itel(j)
2109           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2110           r0ij=rpp(iteli,itelj)
2111           r0ijsq=r0ij*r0ij
2112           dxj=dc(1,j)
2113           dyj=dc(2,j)
2114           dzj=dc(3,j)
2115           xj=c(1,j)+0.5D0*dxj-xmedi
2116           yj=c(2,j)+0.5D0*dyj-ymedi
2117           zj=c(3,j)+0.5D0*dzj-zmedi
2118           rij=xj*xj+yj*yj+zj*zj
2119           if (rij.lt.r0ijsq) then
2120             evdw1ij=0.25d0*(rij-r0ijsq)**2
2121             fac=rij-r0ijsq
2122           else
2123             evdw1ij=0.0d0
2124             fac=0.0d0
2125           endif
2126           evdw1=evdw1+evdw1ij
2127 C
2128 C Calculate contributions to the Cartesian gradient.
2129 C
2130           ggg(1)=fac*xj
2131           ggg(2)=fac*yj
2132           ggg(3)=fac*zj
2133           do k=1,3
2134             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2135             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2136           enddo
2137 *
2138 * Loop over residues i+1 thru j-1.
2139 *
2140 cgrad          do k=i+1,j-1
2141 cgrad            do l=1,3
2142 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2143 cgrad            enddo
2144 cgrad          enddo
2145         enddo ! j
2146       enddo   ! i
2147 cgrad      do i=nnt,nct-1
2148 cgrad        do k=1,3
2149 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2150 cgrad        enddo
2151 cgrad        do j=i+1,nct-1
2152 cgrad          do k=1,3
2153 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2154 cgrad          enddo
2155 cgrad        enddo
2156 cgrad      enddo
2157       return
2158       end
2159 c------------------------------------------------------------------------------
2160       subroutine vec_and_deriv
2161       implicit real*8 (a-h,o-z)
2162       include 'DIMENSIONS'
2163 #ifdef MPI
2164       include 'mpif.h'
2165 #endif
2166       include 'COMMON.IOUNITS'
2167       include 'COMMON.GEO'
2168       include 'COMMON.VAR'
2169       include 'COMMON.LOCAL'
2170       include 'COMMON.CHAIN'
2171       include 'COMMON.VECTORS'
2172       include 'COMMON.SETUP'
2173       include 'COMMON.TIME1'
2174       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2175 C Compute the local reference systems. For reference system (i), the
2176 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2177 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2178 #ifdef PARVEC
2179       do i=ivec_start,ivec_end
2180 #else
2181       do i=1,nres-1
2182 #endif
2183           if (i.eq.nres-1) then
2184 C Case of the last full residue
2185 C Compute the Z-axis
2186             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2187             costh=dcos(pi-theta(nres))
2188             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2189             do k=1,3
2190               uz(k,i)=fac*uz(k,i)
2191             enddo
2192 C Compute the derivatives of uz
2193             uzder(1,1,1)= 0.0d0
2194             uzder(2,1,1)=-dc_norm(3,i-1)
2195             uzder(3,1,1)= dc_norm(2,i-1)
2196             uzder(1,2,1)= dc_norm(3,i-1)
2197             uzder(2,2,1)= 0.0d0
2198             uzder(3,2,1)=-dc_norm(1,i-1)
2199             uzder(1,3,1)=-dc_norm(2,i-1)
2200             uzder(2,3,1)= dc_norm(1,i-1)
2201             uzder(3,3,1)= 0.0d0
2202             uzder(1,1,2)= 0.0d0
2203             uzder(2,1,2)= dc_norm(3,i)
2204             uzder(3,1,2)=-dc_norm(2,i)
2205             uzder(1,2,2)=-dc_norm(3,i)
2206             uzder(2,2,2)= 0.0d0
2207             uzder(3,2,2)= dc_norm(1,i)
2208             uzder(1,3,2)= dc_norm(2,i)
2209             uzder(2,3,2)=-dc_norm(1,i)
2210             uzder(3,3,2)= 0.0d0
2211 C Compute the Y-axis
2212             facy=fac
2213             do k=1,3
2214               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2215             enddo
2216 C Compute the derivatives of uy
2217             do j=1,3
2218               do k=1,3
2219                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2220      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2221                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2222               enddo
2223               uyder(j,j,1)=uyder(j,j,1)-costh
2224               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2225             enddo
2226             do j=1,2
2227               do k=1,3
2228                 do l=1,3
2229                   uygrad(l,k,j,i)=uyder(l,k,j)
2230                   uzgrad(l,k,j,i)=uzder(l,k,j)
2231                 enddo
2232               enddo
2233             enddo
2234             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2235             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2236             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2237             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2238           else
2239 C Other residues
2240 C Compute the Z-axis
2241             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2242             costh=dcos(pi-theta(i+2))
2243             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2244             do k=1,3
2245               uz(k,i)=fac*uz(k,i)
2246             enddo
2247 C Compute the derivatives of uz
2248             uzder(1,1,1)= 0.0d0
2249             uzder(2,1,1)=-dc_norm(3,i+1)
2250             uzder(3,1,1)= dc_norm(2,i+1)
2251             uzder(1,2,1)= dc_norm(3,i+1)
2252             uzder(2,2,1)= 0.0d0
2253             uzder(3,2,1)=-dc_norm(1,i+1)
2254             uzder(1,3,1)=-dc_norm(2,i+1)
2255             uzder(2,3,1)= dc_norm(1,i+1)
2256             uzder(3,3,1)= 0.0d0
2257             uzder(1,1,2)= 0.0d0
2258             uzder(2,1,2)= dc_norm(3,i)
2259             uzder(3,1,2)=-dc_norm(2,i)
2260             uzder(1,2,2)=-dc_norm(3,i)
2261             uzder(2,2,2)= 0.0d0
2262             uzder(3,2,2)= dc_norm(1,i)
2263             uzder(1,3,2)= dc_norm(2,i)
2264             uzder(2,3,2)=-dc_norm(1,i)
2265             uzder(3,3,2)= 0.0d0
2266 C Compute the Y-axis
2267             facy=fac
2268             do k=1,3
2269               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2270             enddo
2271 C Compute the derivatives of uy
2272             do j=1,3
2273               do k=1,3
2274                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2275      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2276                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2277               enddo
2278               uyder(j,j,1)=uyder(j,j,1)-costh
2279               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2280             enddo
2281             do j=1,2
2282               do k=1,3
2283                 do l=1,3
2284                   uygrad(l,k,j,i)=uyder(l,k,j)
2285                   uzgrad(l,k,j,i)=uzder(l,k,j)
2286                 enddo
2287               enddo
2288             enddo
2289             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2290             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2291             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2292             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2293           endif
2294       enddo
2295       do i=1,nres-1
2296         vbld_inv_temp(1)=vbld_inv(i+1)
2297         if (i.lt.nres-1) then
2298           vbld_inv_temp(2)=vbld_inv(i+2)
2299           else
2300           vbld_inv_temp(2)=vbld_inv(i)
2301           endif
2302         do j=1,2
2303           do k=1,3
2304             do l=1,3
2305               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2306               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2307             enddo
2308           enddo
2309         enddo
2310       enddo
2311 #if defined(PARVEC) && defined(MPI)
2312       if (nfgtasks1.gt.1) then
2313         time00=MPI_Wtime()
2314 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2315 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2316 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2317         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2318      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2319      &   FG_COMM1,IERR)
2320         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2321      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2322      &   FG_COMM1,IERR)
2323         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2324      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2325      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2326         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2327      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2328      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2329         time_gather=time_gather+MPI_Wtime()-time00
2330       endif
2331 c      if (fg_rank.eq.0) then
2332 c        write (iout,*) "Arrays UY and UZ"
2333 c        do i=1,nres-1
2334 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2335 c     &     (uz(k,i),k=1,3)
2336 c        enddo
2337 c      endif
2338 #endif
2339       return
2340       end
2341 C-----------------------------------------------------------------------------
2342       subroutine check_vecgrad
2343       implicit real*8 (a-h,o-z)
2344       include 'DIMENSIONS'
2345       include 'COMMON.IOUNITS'
2346       include 'COMMON.GEO'
2347       include 'COMMON.VAR'
2348       include 'COMMON.LOCAL'
2349       include 'COMMON.CHAIN'
2350       include 'COMMON.VECTORS'
2351       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2352       dimension uyt(3,maxres),uzt(3,maxres)
2353       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2354       double precision delta /1.0d-7/
2355       call vec_and_deriv
2356 cd      do i=1,nres
2357 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2358 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2359 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2360 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2361 cd     &     (dc_norm(if90,i),if90=1,3)
2362 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2363 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2364 cd          write(iout,'(a)')
2365 cd      enddo
2366       do i=1,nres
2367         do j=1,2
2368           do k=1,3
2369             do l=1,3
2370               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2371               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2372             enddo
2373           enddo
2374         enddo
2375       enddo
2376       call vec_and_deriv
2377       do i=1,nres
2378         do j=1,3
2379           uyt(j,i)=uy(j,i)
2380           uzt(j,i)=uz(j,i)
2381         enddo
2382       enddo
2383       do i=1,nres
2384 cd        write (iout,*) 'i=',i
2385         do k=1,3
2386           erij(k)=dc_norm(k,i)
2387         enddo
2388         do j=1,3
2389           do k=1,3
2390             dc_norm(k,i)=erij(k)
2391           enddo
2392           dc_norm(j,i)=dc_norm(j,i)+delta
2393 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2394 c          do k=1,3
2395 c            dc_norm(k,i)=dc_norm(k,i)/fac
2396 c          enddo
2397 c          write (iout,*) (dc_norm(k,i),k=1,3)
2398 c          write (iout,*) (erij(k),k=1,3)
2399           call vec_and_deriv
2400           do k=1,3
2401             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2402             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2403             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2404             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2405           enddo
2406 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2407 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2408 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2409         enddo
2410         do k=1,3
2411           dc_norm(k,i)=erij(k)
2412         enddo
2413 cd        do k=1,3
2414 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2415 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2416 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2417 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2418 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2419 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2420 cd          write (iout,'(a)')
2421 cd        enddo
2422       enddo
2423       return
2424       end
2425 C--------------------------------------------------------------------------
2426       subroutine set_matrices
2427       implicit real*8 (a-h,o-z)
2428       include 'DIMENSIONS'
2429 #ifdef MPI
2430       include "mpif.h"
2431       include "COMMON.SETUP"
2432       integer IERR
2433       integer status(MPI_STATUS_SIZE)
2434 #endif
2435       include 'COMMON.IOUNITS'
2436       include 'COMMON.GEO'
2437       include 'COMMON.VAR'
2438       include 'COMMON.LOCAL'
2439       include 'COMMON.CHAIN'
2440       include 'COMMON.DERIV'
2441       include 'COMMON.INTERACT'
2442       include 'COMMON.CONTACTS'
2443       include 'COMMON.TORSION'
2444       include 'COMMON.VECTORS'
2445       include 'COMMON.FFIELD'
2446       double precision auxvec(2),auxmat(2,2)
2447 C
2448 C Compute the virtual-bond-torsional-angle dependent quantities needed
2449 C to calculate the el-loc multibody terms of various order.
2450 C
2451 #ifdef PARMAT
2452       do i=ivec_start+2,ivec_end+2
2453 #else
2454       do i=3,nres+1
2455 #endif
2456         if (i .lt. nres+1) then
2457           sin1=dsin(phi(i))
2458           cos1=dcos(phi(i))
2459           sintab(i-2)=sin1
2460           costab(i-2)=cos1
2461           obrot(1,i-2)=cos1
2462           obrot(2,i-2)=sin1
2463           sin2=dsin(2*phi(i))
2464           cos2=dcos(2*phi(i))
2465           sintab2(i-2)=sin2
2466           costab2(i-2)=cos2
2467           obrot2(1,i-2)=cos2
2468           obrot2(2,i-2)=sin2
2469           Ug(1,1,i-2)=-cos1
2470           Ug(1,2,i-2)=-sin1
2471           Ug(2,1,i-2)=-sin1
2472           Ug(2,2,i-2)= cos1
2473           Ug2(1,1,i-2)=-cos2
2474           Ug2(1,2,i-2)=-sin2
2475           Ug2(2,1,i-2)=-sin2
2476           Ug2(2,2,i-2)= cos2
2477         else
2478           costab(i-2)=1.0d0
2479           sintab(i-2)=0.0d0
2480           obrot(1,i-2)=1.0d0
2481           obrot(2,i-2)=0.0d0
2482           obrot2(1,i-2)=0.0d0
2483           obrot2(2,i-2)=0.0d0
2484           Ug(1,1,i-2)=1.0d0
2485           Ug(1,2,i-2)=0.0d0
2486           Ug(2,1,i-2)=0.0d0
2487           Ug(2,2,i-2)=1.0d0
2488           Ug2(1,1,i-2)=0.0d0
2489           Ug2(1,2,i-2)=0.0d0
2490           Ug2(2,1,i-2)=0.0d0
2491           Ug2(2,2,i-2)=0.0d0
2492         endif
2493         if (i .gt. 3 .and. i .lt. nres+1) then
2494           obrot_der(1,i-2)=-sin1
2495           obrot_der(2,i-2)= cos1
2496           Ugder(1,1,i-2)= sin1
2497           Ugder(1,2,i-2)=-cos1
2498           Ugder(2,1,i-2)=-cos1
2499           Ugder(2,2,i-2)=-sin1
2500           dwacos2=cos2+cos2
2501           dwasin2=sin2+sin2
2502           obrot2_der(1,i-2)=-dwasin2
2503           obrot2_der(2,i-2)= dwacos2
2504           Ug2der(1,1,i-2)= dwasin2
2505           Ug2der(1,2,i-2)=-dwacos2
2506           Ug2der(2,1,i-2)=-dwacos2
2507           Ug2der(2,2,i-2)=-dwasin2
2508         else
2509           obrot_der(1,i-2)=0.0d0
2510           obrot_der(2,i-2)=0.0d0
2511           Ugder(1,1,i-2)=0.0d0
2512           Ugder(1,2,i-2)=0.0d0
2513           Ugder(2,1,i-2)=0.0d0
2514           Ugder(2,2,i-2)=0.0d0
2515           obrot2_der(1,i-2)=0.0d0
2516           obrot2_der(2,i-2)=0.0d0
2517           Ug2der(1,1,i-2)=0.0d0
2518           Ug2der(1,2,i-2)=0.0d0
2519           Ug2der(2,1,i-2)=0.0d0
2520           Ug2der(2,2,i-2)=0.0d0
2521         endif
2522 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2523         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2524           iti = itortyp(itype(i-2))
2525         else
2526           iti=ntortyp+1
2527         endif
2528 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2529         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2530           iti1 = itortyp(itype(i-1))
2531         else
2532           iti1=ntortyp+1
2533         endif
2534 cd        write (iout,*) '*******i',i,' iti1',iti
2535 cd        write (iout,*) 'b1',b1(:,iti)
2536 cd        write (iout,*) 'b2',b2(:,iti)
2537 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2538 c        if (i .gt. iatel_s+2) then
2539         if (i .gt. nnt+2) then
2540           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2541           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2542           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2543      &    then
2544           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2545           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2546           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2547           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2548           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2549           endif
2550         else
2551           do k=1,2
2552             Ub2(k,i-2)=0.0d0
2553             Ctobr(k,i-2)=0.0d0
2554             Dtobr2(k,i-2)=0.0d0
2555             do l=1,2
2556               EUg(l,k,i-2)=0.0d0
2557               CUg(l,k,i-2)=0.0d0
2558               DUg(l,k,i-2)=0.0d0
2559               DtUg2(l,k,i-2)=0.0d0
2560             enddo
2561           enddo
2562         endif
2563         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2564         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2565         do k=1,2
2566           muder(k,i-2)=Ub2der(k,i-2)
2567         enddo
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         do k=1,2
2575           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2576         enddo
2577 cd        write (iout,*) 'mu ',mu(:,i-2)
2578 cd        write (iout,*) 'mu1',mu1(:,i-2)
2579 cd        write (iout,*) 'mu2',mu2(:,i-2)
2580         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2581      &  then
2582         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2583         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2584         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2585         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2586         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2587 C Vectors and matrices dependent on a single virtual-bond dihedral.
2588         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2589         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2590         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2591         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2592         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2593         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2594         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2595         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2596         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2597         endif
2598       enddo
2599 C Matrices dependent on two consecutive virtual-bond dihedrals.
2600 C The order of matrices is from left to right.
2601       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2602      &then
2603 c      do i=max0(ivec_start,2),ivec_end
2604       do i=2,nres-1
2605         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2606         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2607         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2608         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2609         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2610         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2611         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2612         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2613       enddo
2614       endif
2615 #if defined(MPI) && defined(PARMAT)
2616 #ifdef DEBUG
2617 c      if (fg_rank.eq.0) then
2618         write (iout,*) "Arrays UG and UGDER before GATHER"
2619         do i=1,nres-1
2620           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2621      &     ((ug(l,k,i),l=1,2),k=1,2),
2622      &     ((ugder(l,k,i),l=1,2),k=1,2)
2623         enddo
2624         write (iout,*) "Arrays UG2 and UG2DER"
2625         do i=1,nres-1
2626           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2627      &     ((ug2(l,k,i),l=1,2),k=1,2),
2628      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2629         enddo
2630         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2631         do i=1,nres-1
2632           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2633      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2634      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2635         enddo
2636         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2637         do i=1,nres-1
2638           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2639      &     costab(i),sintab(i),costab2(i),sintab2(i)
2640         enddo
2641         write (iout,*) "Array MUDER"
2642         do i=1,nres-1
2643           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2644         enddo
2645 c      endif
2646 #endif
2647       if (nfgtasks.gt.1) then
2648         time00=MPI_Wtime()
2649 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2650 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2651 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2652 #ifdef MATGATHER
2653         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2654      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2655      &   FG_COMM1,IERR)
2656         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2657      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2658      &   FG_COMM1,IERR)
2659         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2660      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2661      &   FG_COMM1,IERR)
2662         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2663      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2664      &   FG_COMM1,IERR)
2665         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2666      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2667      &   FG_COMM1,IERR)
2668         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2669      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2670      &   FG_COMM1,IERR)
2671         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2672      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2673      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2674         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2675      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2676      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2677         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2678      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2679      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2680         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2681      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2682      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2683         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2684      &  then
2685         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2686      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2687      &   FG_COMM1,IERR)
2688         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2689      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2690      &   FG_COMM1,IERR)
2691         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2692      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2693      &   FG_COMM1,IERR)
2694        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2695      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2696      &   FG_COMM1,IERR)
2697         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2698      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2699      &   FG_COMM1,IERR)
2700         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2701      &   ivec_count(fg_rank1),
2702      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2703      &   FG_COMM1,IERR)
2704         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2705      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2706      &   FG_COMM1,IERR)
2707         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2708      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2709      &   FG_COMM1,IERR)
2710         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2711      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2712      &   FG_COMM1,IERR)
2713         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2714      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2715      &   FG_COMM1,IERR)
2716         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2717      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2718      &   FG_COMM1,IERR)
2719         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2720      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2721      &   FG_COMM1,IERR)
2722         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2723      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2724      &   FG_COMM1,IERR)
2725         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2726      &   ivec_count(fg_rank1),
2727      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2728      &   FG_COMM1,IERR)
2729         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2730      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2731      &   FG_COMM1,IERR)
2732        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2733      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2734      &   FG_COMM1,IERR)
2735         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2736      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2737      &   FG_COMM1,IERR)
2738        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2739      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2740      &   FG_COMM1,IERR)
2741         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2742      &   ivec_count(fg_rank1),
2743      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2744      &   FG_COMM1,IERR)
2745         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2746      &   ivec_count(fg_rank1),
2747      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2748      &   FG_COMM1,IERR)
2749         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2750      &   ivec_count(fg_rank1),
2751      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2752      &   MPI_MAT2,FG_COMM1,IERR)
2753         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2754      &   ivec_count(fg_rank1),
2755      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2756      &   MPI_MAT2,FG_COMM1,IERR)
2757         endif
2758 #else
2759 c Passes matrix info through the ring
2760       isend=fg_rank1
2761       irecv=fg_rank1-1
2762       if (irecv.lt.0) irecv=nfgtasks1-1
2763       iprev=irecv
2764       inext=fg_rank1+1
2765       if (inext.ge.nfgtasks1) inext=0
2766       do i=1,nfgtasks1-1
2767 c        write (iout,*) "isend",isend," irecv",irecv
2768 c        call flush(iout)
2769         lensend=lentyp(isend)
2770         lenrecv=lentyp(irecv)
2771 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2772 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2773 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2774 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2775 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2776 c        write (iout,*) "Gather ROTAT1"
2777 c        call flush(iout)
2778 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2779 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2780 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2781 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2782 c        write (iout,*) "Gather ROTAT2"
2783 c        call flush(iout)
2784         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2785      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2786      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2787      &   iprev,4400+irecv,FG_COMM,status,IERR)
2788 c        write (iout,*) "Gather ROTAT_OLD"
2789 c        call flush(iout)
2790         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2791      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2792      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2793      &   iprev,5500+irecv,FG_COMM,status,IERR)
2794 c        write (iout,*) "Gather PRECOMP11"
2795 c        call flush(iout)
2796         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2797      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2798      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2799      &   iprev,6600+irecv,FG_COMM,status,IERR)
2800 c        write (iout,*) "Gather PRECOMP12"
2801 c        call flush(iout)
2802         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2803      &  then
2804         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2805      &   MPI_ROTAT2(lensend),inext,7700+isend,
2806      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2807      &   iprev,7700+irecv,FG_COMM,status,IERR)
2808 c        write (iout,*) "Gather PRECOMP21"
2809 c        call flush(iout)
2810         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2811      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2812      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2813      &   iprev,8800+irecv,FG_COMM,status,IERR)
2814 c        write (iout,*) "Gather PRECOMP22"
2815 c        call flush(iout)
2816         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2817      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2818      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2819      &   MPI_PRECOMP23(lenrecv),
2820      &   iprev,9900+irecv,FG_COMM,status,IERR)
2821 c        write (iout,*) "Gather PRECOMP23"
2822 c        call flush(iout)
2823         endif
2824         isend=irecv
2825         irecv=irecv-1
2826         if (irecv.lt.0) irecv=nfgtasks1-1
2827       enddo
2828 #endif
2829         time_gather=time_gather+MPI_Wtime()-time00
2830       endif
2831 #ifdef DEBUG
2832 c      if (fg_rank.eq.0) then
2833         write (iout,*) "Arrays UG and UGDER"
2834         do i=1,nres-1
2835           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2836      &     ((ug(l,k,i),l=1,2),k=1,2),
2837      &     ((ugder(l,k,i),l=1,2),k=1,2)
2838         enddo
2839         write (iout,*) "Arrays UG2 and UG2DER"
2840         do i=1,nres-1
2841           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2842      &     ((ug2(l,k,i),l=1,2),k=1,2),
2843      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2844         enddo
2845         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2846         do i=1,nres-1
2847           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2848      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2849      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2850         enddo
2851         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2852         do i=1,nres-1
2853           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2854      &     costab(i),sintab(i),costab2(i),sintab2(i)
2855         enddo
2856         write (iout,*) "Array MUDER"
2857         do i=1,nres-1
2858           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2859         enddo
2860 c      endif
2861 #endif
2862 #endif
2863 cd      do i=1,nres
2864 cd        iti = itortyp(itype(i))
2865 cd        write (iout,*) i
2866 cd        do j=1,2
2867 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2868 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2869 cd        enddo
2870 cd      enddo
2871       return
2872       end
2873 C--------------------------------------------------------------------------
2874       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2875 C
2876 C This subroutine calculates the average interaction energy and its gradient
2877 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2878 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2879 C The potential depends both on the distance of peptide-group centers and on
2880 C the orientation of the CA-CA virtual bonds.
2881 C
2882       implicit real*8 (a-h,o-z)
2883 #ifdef MPI
2884       include 'mpif.h'
2885 #endif
2886       include 'DIMENSIONS'
2887       include 'COMMON.CONTROL'
2888       include 'COMMON.SETUP'
2889       include 'COMMON.IOUNITS'
2890       include 'COMMON.GEO'
2891       include 'COMMON.VAR'
2892       include 'COMMON.LOCAL'
2893       include 'COMMON.CHAIN'
2894       include 'COMMON.DERIV'
2895       include 'COMMON.INTERACT'
2896       include 'COMMON.CONTACTS'
2897       include 'COMMON.TORSION'
2898       include 'COMMON.VECTORS'
2899       include 'COMMON.FFIELD'
2900       include 'COMMON.TIME1'
2901       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2902      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2903       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2904      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2905       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2906      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2907      &    num_conti,j1,j2
2908 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2909 #ifdef MOMENT
2910       double precision scal_el /1.0d0/
2911 #else
2912       double precision scal_el /0.5d0/
2913 #endif
2914 C 12/13/98
2915 C 13-go grudnia roku pamietnego...
2916       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2917      &                   0.0d0,1.0d0,0.0d0,
2918      &                   0.0d0,0.0d0,1.0d0/
2919 cd      write(iout,*) 'In EELEC'
2920 cd      do i=1,nloctyp
2921 cd        write(iout,*) 'Type',i
2922 cd        write(iout,*) 'B1',B1(:,i)
2923 cd        write(iout,*) 'B2',B2(:,i)
2924 cd        write(iout,*) 'CC',CC(:,:,i)
2925 cd        write(iout,*) 'DD',DD(:,:,i)
2926 cd        write(iout,*) 'EE',EE(:,:,i)
2927 cd      enddo
2928 cd      call check_vecgrad
2929 cd      stop
2930       if (icheckgrad.eq.1) then
2931         do i=1,nres-1
2932           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2933           do k=1,3
2934             dc_norm(k,i)=dc(k,i)*fac
2935           enddo
2936 c          write (iout,*) 'i',i,' fac',fac
2937         enddo
2938       endif
2939       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2940      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2941      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2942 c        call vec_and_deriv
2943 #ifdef TIMING
2944         time01=MPI_Wtime()
2945 #endif
2946         call set_matrices
2947 #ifdef TIMING
2948         time_mat=time_mat+MPI_Wtime()-time01
2949 #endif
2950       endif
2951 cd      do i=1,nres-1
2952 cd        write (iout,*) 'i=',i
2953 cd        do k=1,3
2954 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2955 cd        enddo
2956 cd        do k=1,3
2957 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2958 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2959 cd        enddo
2960 cd      enddo
2961       t_eelecij=0.0d0
2962       ees=0.0D0
2963       evdw1=0.0D0
2964       eel_loc=0.0d0
2965       eello_turn3=0.0d0
2966       eello_turn4=0.0d0
2967       ind=0
2968       do i=1,nres
2969         num_cont_hb(i)=0
2970       enddo
2971 cd      print '(a)','Enter EELEC'
2972 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2973       do i=1,nres
2974         gel_loc_loc(i)=0.0d0
2975         gcorr_loc(i)=0.0d0
2976       enddo
2977 c
2978 c
2979 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2980 C
2981 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2982 C
2983       do i=iturn3_start,iturn3_end
2984         dxi=dc(1,i)
2985         dyi=dc(2,i)
2986         dzi=dc(3,i)
2987         dx_normi=dc_norm(1,i)
2988         dy_normi=dc_norm(2,i)
2989         dz_normi=dc_norm(3,i)
2990         xmedi=c(1,i)+0.5d0*dxi
2991         ymedi=c(2,i)+0.5d0*dyi
2992         zmedi=c(3,i)+0.5d0*dzi
2993         num_conti=0
2994         call eelecij(i,i+2,ees,evdw1,eel_loc)
2995         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2996         num_cont_hb(i)=num_conti
2997       enddo
2998       do i=iturn4_start,iturn4_end
2999         dxi=dc(1,i)
3000         dyi=dc(2,i)
3001         dzi=dc(3,i)
3002         dx_normi=dc_norm(1,i)
3003         dy_normi=dc_norm(2,i)
3004         dz_normi=dc_norm(3,i)
3005         xmedi=c(1,i)+0.5d0*dxi
3006         ymedi=c(2,i)+0.5d0*dyi
3007         zmedi=c(3,i)+0.5d0*dzi
3008         num_conti=num_cont_hb(i)
3009         call eelecij(i,i+3,ees,evdw1,eel_loc)
3010         if (wturn4.gt.0.0d0) call eturn4(i,eello_turn4)
3011         num_cont_hb(i)=num_conti
3012       enddo   ! i
3013 c
3014 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3015 c
3016       do i=iatel_s,iatel_e
3017         dxi=dc(1,i)
3018         dyi=dc(2,i)
3019         dzi=dc(3,i)
3020         dx_normi=dc_norm(1,i)
3021         dy_normi=dc_norm(2,i)
3022         dz_normi=dc_norm(3,i)
3023         xmedi=c(1,i)+0.5d0*dxi
3024         ymedi=c(2,i)+0.5d0*dyi
3025         zmedi=c(3,i)+0.5d0*dzi
3026 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3027         num_conti=num_cont_hb(i)
3028         do j=ielstart(i),ielend(i)
3029           call eelecij(i,j,ees,evdw1,eel_loc)
3030         enddo ! j
3031         num_cont_hb(i)=num_conti
3032       enddo   ! i
3033 c      write (iout,*) "Number of loop steps in EELEC:",ind
3034 cd      do i=1,nres
3035 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3036 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3037 cd      enddo
3038 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3039 ccc      eel_loc=eel_loc+eello_turn3
3040 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3041       return
3042       end
3043 C-------------------------------------------------------------------------------
3044       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3045       implicit real*8 (a-h,o-z)
3046       include 'DIMENSIONS'
3047 #ifdef MPI
3048       include "mpif.h"
3049 #endif
3050       include 'COMMON.CONTROL'
3051       include 'COMMON.IOUNITS'
3052       include 'COMMON.GEO'
3053       include 'COMMON.VAR'
3054       include 'COMMON.LOCAL'
3055       include 'COMMON.CHAIN'
3056       include 'COMMON.DERIV'
3057       include 'COMMON.INTERACT'
3058       include 'COMMON.CONTACTS'
3059       include 'COMMON.TORSION'
3060       include 'COMMON.VECTORS'
3061       include 'COMMON.FFIELD'
3062       include 'COMMON.TIME1'
3063       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3064      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3065       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3066      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3067       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3068      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3069      &    num_conti,j1,j2
3070 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3071 #ifdef MOMENT
3072       double precision scal_el /1.0d0/
3073 #else
3074       double precision scal_el /0.5d0/
3075 #endif
3076 C 12/13/98
3077 C 13-go grudnia roku pamietnego...
3078       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3079      &                   0.0d0,1.0d0,0.0d0,
3080      &                   0.0d0,0.0d0,1.0d0/
3081 c          time00=MPI_Wtime()
3082 cd      write (iout,*) "eelecij",i,j
3083 c          ind=ind+1
3084           iteli=itel(i)
3085           itelj=itel(j)
3086           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3087           aaa=app(iteli,itelj)
3088           bbb=bpp(iteli,itelj)
3089           ael6i=ael6(iteli,itelj)
3090           ael3i=ael3(iteli,itelj)
3091           dxj=dc(1,j)
3092           dyj=dc(2,j)
3093           dzj=dc(3,j)
3094           dx_normj=dc_norm(1,j)
3095           dy_normj=dc_norm(2,j)
3096           dz_normj=dc_norm(3,j)
3097           xj=c(1,j)+0.5D0*dxj-xmedi
3098           yj=c(2,j)+0.5D0*dyj-ymedi
3099           zj=c(3,j)+0.5D0*dzj-zmedi
3100           rij=xj*xj+yj*yj+zj*zj
3101           rrmij=1.0D0/rij
3102           rij=dsqrt(rij)
3103           rmij=1.0D0/rij
3104           r3ij=rrmij*rmij
3105           r6ij=r3ij*r3ij
3106           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3107           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3108           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3109           fac=cosa-3.0D0*cosb*cosg
3110           ev1=aaa*r6ij*r6ij
3111 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3112           if (j.eq.i+2) ev1=scal_el*ev1
3113           ev2=bbb*r6ij
3114           fac3=ael6i*r6ij
3115           fac4=ael3i*r3ij
3116           evdwij=ev1+ev2
3117           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3118           el2=fac4*fac
3119           eesij=el1+el2
3120 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3121           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3122           ees=ees+eesij
3123           evdw1=evdw1+evdwij
3124 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3125 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3126 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3127 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3128
3129           if (energy_dec) then
3130               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3131               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3132           endif
3133
3134 C
3135 C Calculate contributions to the Cartesian gradient.
3136 C
3137 #ifdef SPLITELE
3138           facvdw=-6*rrmij*(ev1+evdwij)
3139           facel=-3*rrmij*(el1+eesij)
3140           fac1=fac
3141           erij(1)=xj*rmij
3142           erij(2)=yj*rmij
3143           erij(3)=zj*rmij
3144 *
3145 * Radial derivatives. First process both termini of the fragment (i,j)
3146 *
3147           ggg(1)=facel*xj
3148           ggg(2)=facel*yj
3149           ggg(3)=facel*zj
3150 c          do k=1,3
3151 c            ghalf=0.5D0*ggg(k)
3152 c            gelc(k,i)=gelc(k,i)+ghalf
3153 c            gelc(k,j)=gelc(k,j)+ghalf
3154 c          enddo
3155 c 9/28/08 AL Gradient compotents will be summed only at the end
3156           do k=1,3
3157             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3158             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3159           enddo
3160 *
3161 * Loop over residues i+1 thru j-1.
3162 *
3163 cgrad          do k=i+1,j-1
3164 cgrad            do l=1,3
3165 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3166 cgrad            enddo
3167 cgrad          enddo
3168           ggg(1)=facvdw*xj
3169           ggg(2)=facvdw*yj
3170           ggg(3)=facvdw*zj
3171 c          do k=1,3
3172 c            ghalf=0.5D0*ggg(k)
3173 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3174 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3175 c          enddo
3176 c 9/28/08 AL Gradient compotents will be summed only at the end
3177           do k=1,3
3178             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3179             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3180           enddo
3181 *
3182 * Loop over residues i+1 thru j-1.
3183 *
3184 cgrad          do k=i+1,j-1
3185 cgrad            do l=1,3
3186 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3187 cgrad            enddo
3188 cgrad          enddo
3189 #else
3190           facvdw=ev1+evdwij
3191           facel=el1+eesij
3192           fac1=fac
3193           fac=-3*rrmij*(facvdw+facvdw+facel)
3194           erij(1)=xj*rmij
3195           erij(2)=yj*rmij
3196           erij(3)=zj*rmij
3197 *
3198 * Radial derivatives. First process both termini of the fragment (i,j)
3199 *
3200           ggg(1)=fac*xj
3201           ggg(2)=fac*yj
3202           ggg(3)=fac*zj
3203 c          do k=1,3
3204 c            ghalf=0.5D0*ggg(k)
3205 c            gelc(k,i)=gelc(k,i)+ghalf
3206 c            gelc(k,j)=gelc(k,j)+ghalf
3207 c          enddo
3208 c 9/28/08 AL Gradient compotents will be summed only at the end
3209           do k=1,3
3210             gelc_long(k,j)=gelc(k,j)+ggg(k)
3211             gelc_long(k,i)=gelc(k,i)-ggg(k)
3212           enddo
3213 *
3214 * Loop over residues i+1 thru j-1.
3215 *
3216 cgrad          do k=i+1,j-1
3217 cgrad            do l=1,3
3218 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3219 cgrad            enddo
3220 cgrad          enddo
3221 c 9/28/08 AL Gradient compotents will be summed only at the end
3222           ggg(1)=facvdw*xj
3223           ggg(2)=facvdw*yj
3224           ggg(3)=facvdw*zj
3225           do k=1,3
3226             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3227             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3228           enddo
3229 #endif
3230 *
3231 * Angular part
3232 *
3233           ecosa=2.0D0*fac3*fac1+fac4
3234           fac4=-3.0D0*fac4
3235           fac3=-6.0D0*fac3
3236           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3237           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3238           do k=1,3
3239             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3240             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3241           enddo
3242 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3243 cd   &          (dcosg(k),k=1,3)
3244           do k=1,3
3245             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3246           enddo
3247 c          do k=1,3
3248 c            ghalf=0.5D0*ggg(k)
3249 c            gelc(k,i)=gelc(k,i)+ghalf
3250 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3251 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3252 c            gelc(k,j)=gelc(k,j)+ghalf
3253 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3254 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3255 c          enddo
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           do k=1,3
3262             gelc(k,i)=gelc(k,i)
3263      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3264      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3265             gelc(k,j)=gelc(k,j)
3266      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3267      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3268             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3269             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3270           enddo
3271           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3272      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3273      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3274 C
3275 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3276 C   energy of a peptide unit is assumed in the form of a second-order
3277 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3278 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3279 C   are computed for EVERY pair of non-contiguous peptide groups.
3280 C
3281           if (j.lt.nres-1) then
3282             j1=j+1
3283             j2=j-1
3284           else
3285             j1=j-1
3286             j2=j-2
3287           endif
3288           kkk=0
3289           do k=1,2
3290             do l=1,2
3291               kkk=kkk+1
3292               muij(kkk)=mu(k,i)*mu(l,j)
3293             enddo
3294           enddo
3295 cd         write (iout,*) 'EELEC: i',i,' j',j
3296 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3297 cd          write(iout,*) 'muij',muij
3298           ury=scalar(uy(1,i),erij)
3299           urz=scalar(uz(1,i),erij)
3300           vry=scalar(uy(1,j),erij)
3301           vrz=scalar(uz(1,j),erij)
3302           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3303           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3304           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3305           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3306           fac=dsqrt(-ael6i)*r3ij
3307           a22=a22*fac
3308           a23=a23*fac
3309           a32=a32*fac
3310           a33=a33*fac
3311 cd          write (iout,'(4i5,4f10.5)')
3312 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3313 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3314 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3315 cd     &      uy(:,j),uz(:,j)
3316 cd          write (iout,'(4f10.5)')
3317 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3318 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3319 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3320 cd           write (iout,'(9f10.5/)')
3321 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3322 C Derivatives of the elements of A in virtual-bond vectors
3323           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3324           do k=1,3
3325             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3326             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3327             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3328             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3329             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3330             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3331             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3332             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3333             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3334             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3335             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3336             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3337           enddo
3338 C Compute radial contributions to the gradient
3339           facr=-3.0d0*rrmij
3340           a22der=a22*facr
3341           a23der=a23*facr
3342           a32der=a32*facr
3343           a33der=a33*facr
3344           agg(1,1)=a22der*xj
3345           agg(2,1)=a22der*yj
3346           agg(3,1)=a22der*zj
3347           agg(1,2)=a23der*xj
3348           agg(2,2)=a23der*yj
3349           agg(3,2)=a23der*zj
3350           agg(1,3)=a32der*xj
3351           agg(2,3)=a32der*yj
3352           agg(3,3)=a32der*zj
3353           agg(1,4)=a33der*xj
3354           agg(2,4)=a33der*yj
3355           agg(3,4)=a33der*zj
3356 C Add the contributions coming from er
3357           fac3=-3.0d0*fac
3358           do k=1,3
3359             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3360             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3361             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3362             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3363           enddo
3364           do k=1,3
3365 C Derivatives in DC(i)
3366 cgrad            ghalf1=0.5d0*agg(k,1)
3367 cgrad            ghalf2=0.5d0*agg(k,2)
3368 cgrad            ghalf3=0.5d0*agg(k,3)
3369 cgrad            ghalf4=0.5d0*agg(k,4)
3370             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3371      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3372             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3373      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3374             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3375      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3376             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3377      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3378 C Derivatives in DC(i+1)
3379             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3380      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3381             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3382      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3383             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3384      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3385             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3386      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3387 C Derivatives in DC(j)
3388             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3389      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3390             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3391      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3392             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3393      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3394             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3395      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3396 C Derivatives in DC(j+1) or DC(nres-1)
3397             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3398      &      -3.0d0*vryg(k,3)*ury)
3399             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3400      &      -3.0d0*vrzg(k,3)*ury)
3401             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3402      &      -3.0d0*vryg(k,3)*urz)
3403             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3404      &      -3.0d0*vrzg(k,3)*urz)
3405 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3406 cgrad              do l=1,4
3407 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3408 cgrad              enddo
3409 cgrad            endif
3410           enddo
3411           acipa(1,1)=a22
3412           acipa(1,2)=a23
3413           acipa(2,1)=a32
3414           acipa(2,2)=a33
3415           a22=-a22
3416           a23=-a23
3417           do l=1,2
3418             do k=1,3
3419               agg(k,l)=-agg(k,l)
3420               aggi(k,l)=-aggi(k,l)
3421               aggi1(k,l)=-aggi1(k,l)
3422               aggj(k,l)=-aggj(k,l)
3423               aggj1(k,l)=-aggj1(k,l)
3424             enddo
3425           enddo
3426           if (j.lt.nres-1) then
3427             a22=-a22
3428             a32=-a32
3429             do l=1,3,2
3430               do k=1,3
3431                 agg(k,l)=-agg(k,l)
3432                 aggi(k,l)=-aggi(k,l)
3433                 aggi1(k,l)=-aggi1(k,l)
3434                 aggj(k,l)=-aggj(k,l)
3435                 aggj1(k,l)=-aggj1(k,l)
3436               enddo
3437             enddo
3438           else
3439             a22=-a22
3440             a23=-a23
3441             a32=-a32
3442             a33=-a33
3443             do l=1,4
3444               do k=1,3
3445                 agg(k,l)=-agg(k,l)
3446                 aggi(k,l)=-aggi(k,l)
3447                 aggi1(k,l)=-aggi1(k,l)
3448                 aggj(k,l)=-aggj(k,l)
3449                 aggj1(k,l)=-aggj1(k,l)
3450               enddo
3451             enddo
3452           endif
3453           ENDIF ! WCORR
3454           IF (wel_loc.gt.0.0d0) THEN
3455 C Contribution to the local-electrostatic energy coming from the i-j pair
3456           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3457      &     +a33*muij(4)
3458 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3459
3460           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3461      &            'eelloc',i,j,eel_loc_ij
3462
3463           eel_loc=eel_loc+eel_loc_ij
3464 C Partial derivatives in virtual-bond dihedral angles gamma
3465           if (i.gt.1)
3466      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3467      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3468      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3469           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3470      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3471      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3472 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3473           do l=1,3
3474             ggg(l)=agg(l,1)*muij(1)+
3475      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3476             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3477             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3478 cgrad            ghalf=0.5d0*ggg(l)
3479 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3480 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3481           enddo
3482 cgrad          do k=i+1,j2
3483 cgrad            do l=1,3
3484 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3485 cgrad            enddo
3486 cgrad          enddo
3487 C Remaining derivatives of eello
3488           do l=1,3
3489             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3490      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3491             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3492      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3493             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3494      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3495             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3496      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3497           enddo
3498           ENDIF
3499 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3500 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3501           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3502      &       .and. num_conti.le.maxconts) then
3503 c            write (iout,*) i,j," entered corr"
3504 C
3505 C Calculate the contact function. The ith column of the array JCONT will
3506 C contain the numbers of atoms that make contacts with the atom I (of numbers
3507 C greater than I). The arrays FACONT and GACONT will contain the values of
3508 C the contact function and its derivative.
3509 c           r0ij=1.02D0*rpp(iteli,itelj)
3510 c           r0ij=1.11D0*rpp(iteli,itelj)
3511             r0ij=2.20D0*rpp(iteli,itelj)
3512 c           r0ij=1.55D0*rpp(iteli,itelj)
3513             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3514             if (fcont.gt.0.0D0) then
3515               num_conti=num_conti+1
3516               if (num_conti.gt.maxconts) then
3517                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3518      &                         ' will skip next contacts for this conf.'
3519               else
3520                 jcont_hb(num_conti,i)=j
3521 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3522 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3523                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3524      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3525 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3526 C  terms.
3527                 d_cont(num_conti,i)=rij
3528 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3529 C     --- Electrostatic-interaction matrix ---
3530                 a_chuj(1,1,num_conti,i)=a22
3531                 a_chuj(1,2,num_conti,i)=a23
3532                 a_chuj(2,1,num_conti,i)=a32
3533                 a_chuj(2,2,num_conti,i)=a33
3534 C     --- Gradient of rij
3535                 do kkk=1,3
3536                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3537                 enddo
3538                 kkll=0
3539                 do k=1,2
3540                   do l=1,2
3541                     kkll=kkll+1
3542                     do m=1,3
3543                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3544                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3545                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3546                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3547                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3548                     enddo
3549                   enddo
3550                 enddo
3551                 ENDIF
3552                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3553 C Calculate contact energies
3554                 cosa4=4.0D0*cosa
3555                 wij=cosa-3.0D0*cosb*cosg
3556                 cosbg1=cosb+cosg
3557                 cosbg2=cosb-cosg
3558 c               fac3=dsqrt(-ael6i)/r0ij**3
3559                 fac3=dsqrt(-ael6i)*r3ij
3560 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3561                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3562                 if (ees0tmp.gt.0) then
3563                   ees0pij=dsqrt(ees0tmp)
3564                 else
3565                   ees0pij=0
3566                 endif
3567 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3568                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3569                 if (ees0tmp.gt.0) then
3570                   ees0mij=dsqrt(ees0tmp)
3571                 else
3572                   ees0mij=0
3573                 endif
3574 c               ees0mij=0.0D0
3575                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3576                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3577 C Diagnostics. Comment out or remove after debugging!
3578 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3579 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3580 c               ees0m(num_conti,i)=0.0D0
3581 C End diagnostics.
3582 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3583 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3584 C Angular derivatives of the contact function
3585                 ees0pij1=fac3/ees0pij
3586                 ees0mij1=fac3/ees0mij
3587                 fac3p=-3.0D0*fac3*rrmij
3588                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3589                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3590 c               ees0mij1=0.0D0
3591                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3592                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3593                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3594                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3595                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3596                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3597                 ecosap=ecosa1+ecosa2
3598                 ecosbp=ecosb1+ecosb2
3599                 ecosgp=ecosg1+ecosg2
3600                 ecosam=ecosa1-ecosa2
3601                 ecosbm=ecosb1-ecosb2
3602                 ecosgm=ecosg1-ecosg2
3603 C Diagnostics
3604 c               ecosap=ecosa1
3605 c               ecosbp=ecosb1
3606 c               ecosgp=ecosg1
3607 c               ecosam=0.0D0
3608 c               ecosbm=0.0D0
3609 c               ecosgm=0.0D0
3610 C End diagnostics
3611                 facont_hb(num_conti,i)=fcont
3612                 fprimcont=fprimcont/rij
3613 cd              facont_hb(num_conti,i)=1.0D0
3614 C Following line is for diagnostics.
3615 cd              fprimcont=0.0D0
3616                 do k=1,3
3617                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3618                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3619                 enddo
3620                 do k=1,3
3621                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3622                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3623                 enddo
3624                 gggp(1)=gggp(1)+ees0pijp*xj
3625                 gggp(2)=gggp(2)+ees0pijp*yj
3626                 gggp(3)=gggp(3)+ees0pijp*zj
3627                 gggm(1)=gggm(1)+ees0mijp*xj
3628                 gggm(2)=gggm(2)+ees0mijp*yj
3629                 gggm(3)=gggm(3)+ees0mijp*zj
3630 C Derivatives due to the contact function
3631                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3632                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3633                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3634                 do k=1,3
3635 c
3636 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3637 c          following the change of gradient-summation algorithm.
3638 c
3639 cgrad                  ghalfp=0.5D0*gggp(k)
3640 cgrad                  ghalfm=0.5D0*gggm(k)
3641                   gacontp_hb1(k,num_conti,i)=!ghalfp
3642      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3643      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3644                   gacontp_hb2(k,num_conti,i)=!ghalfp
3645      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3646      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3647                   gacontp_hb3(k,num_conti,i)=gggp(k)
3648                   gacontm_hb1(k,num_conti,i)=!ghalfm
3649      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3650      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3651                   gacontm_hb2(k,num_conti,i)=!ghalfm
3652      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3653      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3654                   gacontm_hb3(k,num_conti,i)=gggm(k)
3655                 enddo
3656 C Diagnostics. Comment out or remove after debugging!
3657 cdiag           do k=1,3
3658 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3659 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3660 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3661 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3662 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3663 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3664 cdiag           enddo
3665               ENDIF ! wcorr
3666               endif  ! num_conti.le.maxconts
3667             endif  ! fcont.gt.0
3668           endif    ! j.gt.i+1
3669           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3670             do k=1,4
3671               do l=1,3
3672                 ghalf=0.5d0*agg(l,k)
3673                 aggi(l,k)=aggi(l,k)+ghalf
3674                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3675                 aggj(l,k)=aggj(l,k)+ghalf
3676               enddo
3677             enddo
3678             if (j.eq.nres-1 .and. i.lt.j-2) then
3679               do k=1,4
3680                 do l=1,3
3681                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3682                 enddo
3683               enddo
3684             endif
3685           endif
3686 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3687       return
3688       end
3689 C-----------------------------------------------------------------------------
3690       subroutine eturn3(i,eello_turn3)
3691 C Third- and fourth-order contributions from turns
3692       implicit real*8 (a-h,o-z)
3693       include 'DIMENSIONS'
3694       include 'COMMON.IOUNITS'
3695       include 'COMMON.GEO'
3696       include 'COMMON.VAR'
3697       include 'COMMON.LOCAL'
3698       include 'COMMON.CHAIN'
3699       include 'COMMON.DERIV'
3700       include 'COMMON.INTERACT'
3701       include 'COMMON.CONTACTS'
3702       include 'COMMON.TORSION'
3703       include 'COMMON.VECTORS'
3704       include 'COMMON.FFIELD'
3705       include 'COMMON.CONTROL'
3706       dimension ggg(3)
3707       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3708      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3709      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3710       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3711      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3712       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3713      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3714      &    num_conti,j1,j2
3715       j=i+2
3716 c      write (iout,*) "eturn3",i,j,j1,j2
3717       a_temp(1,1)=a22
3718       a_temp(1,2)=a23
3719       a_temp(2,1)=a32
3720       a_temp(2,2)=a33
3721 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3722 C
3723 C               Third-order contributions
3724 C
3725 C                 (i+2)o----(i+3)
3726 C                      | |
3727 C                      | |
3728 C                 (i+1)o----i
3729 C
3730 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3731 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3732         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3733         call transpose2(auxmat(1,1),auxmat1(1,1))
3734         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3735         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3736         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3737      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3738 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3739 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3740 cd     &    ' eello_turn3_num',4*eello_turn3_num
3741 C Derivatives in gamma(i)
3742         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3743         call transpose2(auxmat2(1,1),auxmat3(1,1))
3744         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3745         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3746 C Derivatives in gamma(i+1)
3747         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3748         call transpose2(auxmat2(1,1),auxmat3(1,1))
3749         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3750         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3751      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3752 C Cartesian derivatives
3753         do l=1,3
3754 c            ghalf1=0.5d0*agg(l,1)
3755 c            ghalf2=0.5d0*agg(l,2)
3756 c            ghalf3=0.5d0*agg(l,3)
3757 c            ghalf4=0.5d0*agg(l,4)
3758           a_temp(1,1)=aggi(l,1)!+ghalf1
3759           a_temp(1,2)=aggi(l,2)!+ghalf2
3760           a_temp(2,1)=aggi(l,3)!+ghalf3
3761           a_temp(2,2)=aggi(l,4)!+ghalf4
3762           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3763           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3764      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3765           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3766           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3767           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3768           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3769           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3770           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3771      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3772           a_temp(1,1)=aggj(l,1)!+ghalf1
3773           a_temp(1,2)=aggj(l,2)!+ghalf2
3774           a_temp(2,1)=aggj(l,3)!+ghalf3
3775           a_temp(2,2)=aggj(l,4)!+ghalf4
3776           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3777           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3778      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3779           a_temp(1,1)=aggj1(l,1)
3780           a_temp(1,2)=aggj1(l,2)
3781           a_temp(2,1)=aggj1(l,3)
3782           a_temp(2,2)=aggj1(l,4)
3783           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3784           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3785      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3786         enddo
3787       return
3788       end
3789 C-------------------------------------------------------------------------------
3790       subroutine eturn4(i,eello_turn4)
3791 C Third- and fourth-order contributions from turns
3792       implicit real*8 (a-h,o-z)
3793       include 'DIMENSIONS'
3794       include 'COMMON.IOUNITS'
3795       include 'COMMON.GEO'
3796       include 'COMMON.VAR'
3797       include 'COMMON.LOCAL'
3798       include 'COMMON.CHAIN'
3799       include 'COMMON.DERIV'
3800       include 'COMMON.INTERACT'
3801       include 'COMMON.CONTACTS'
3802       include 'COMMON.TORSION'
3803       include 'COMMON.VECTORS'
3804       include 'COMMON.FFIELD'
3805       include 'COMMON.CONTROL'
3806       dimension ggg(3)
3807       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3808      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3809      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3810       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3811      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3812       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3813      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3814      &    num_conti,j1,j2
3815       j=i+3
3816 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3817 C
3818 C               Fourth-order contributions
3819 C
3820 C                 (i+3)o----(i+4)
3821 C                     /  |
3822 C               (i+2)o   |
3823 C                     \  |
3824 C                 (i+1)o----i
3825 C
3826 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3827 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3828 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3829         a_temp(1,1)=a22
3830         a_temp(1,2)=a23
3831         a_temp(2,1)=a32
3832         a_temp(2,2)=a33
3833         iti1=itortyp(itype(i+1))
3834         iti2=itortyp(itype(i+2))
3835         iti3=itortyp(itype(i+3))
3836 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3837         call transpose2(EUg(1,1,i+1),e1t(1,1))
3838         call transpose2(Eug(1,1,i+2),e2t(1,1))
3839         call transpose2(Eug(1,1,i+3),e3t(1,1))
3840         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3841         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3842         s1=scalar2(b1(1,iti2),auxvec(1))
3843         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3844         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3845         s2=scalar2(b1(1,iti1),auxvec(1))
3846         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3847         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3848         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3849         eello_turn4=eello_turn4-(s1+s2+s3)
3850         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3851      &      'eturn4',i,j,-(s1+s2+s3)
3852 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3853 cd     &    ' eello_turn4_num',8*eello_turn4_num
3854 C Derivatives in gamma(i)
3855         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3856         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3857         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3858         s1=scalar2(b1(1,iti2),auxvec(1))
3859         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3860         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3861         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3862 C Derivatives in gamma(i+1)
3863         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3864         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3865         s2=scalar2(b1(1,iti1),auxvec(1))
3866         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3867         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3868         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3869         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3870 C Derivatives in gamma(i+2)
3871         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3872         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3873         s1=scalar2(b1(1,iti2),auxvec(1))
3874         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3875         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3876         s2=scalar2(b1(1,iti1),auxvec(1))
3877         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3878         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3879         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3880         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3881 C Cartesian derivatives
3882 C Derivatives of this turn contributions in DC(i+2)
3883         if (j.lt.nres-1) then
3884           do l=1,3
3885             a_temp(1,1)=agg(l,1)
3886             a_temp(1,2)=agg(l,2)
3887             a_temp(2,1)=agg(l,3)
3888             a_temp(2,2)=agg(l,4)
3889             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3890             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3891             s1=scalar2(b1(1,iti2),auxvec(1))
3892             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3893             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3894             s2=scalar2(b1(1,iti1),auxvec(1))
3895             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3896             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3897             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3898             ggg(l)=-(s1+s2+s3)
3899             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3900           enddo
3901         endif
3902 C Remaining derivatives of this turn contribution
3903         do l=1,3
3904           a_temp(1,1)=aggi(l,1)
3905           a_temp(1,2)=aggi(l,2)
3906           a_temp(2,1)=aggi(l,3)
3907           a_temp(2,2)=aggi(l,4)
3908           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3909           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3910           s1=scalar2(b1(1,iti2),auxvec(1))
3911           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3912           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3913           s2=scalar2(b1(1,iti1),auxvec(1))
3914           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3915           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3916           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3917           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3918           a_temp(1,1)=aggi1(l,1)
3919           a_temp(1,2)=aggi1(l,2)
3920           a_temp(2,1)=aggi1(l,3)
3921           a_temp(2,2)=aggi1(l,4)
3922           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3923           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3924           s1=scalar2(b1(1,iti2),auxvec(1))
3925           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3926           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3927           s2=scalar2(b1(1,iti1),auxvec(1))
3928           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3929           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3930           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3931           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3932           a_temp(1,1)=aggj(l,1)
3933           a_temp(1,2)=aggj(l,2)
3934           a_temp(2,1)=aggj(l,3)
3935           a_temp(2,2)=aggj(l,4)
3936           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3937           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3938           s1=scalar2(b1(1,iti2),auxvec(1))
3939           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3940           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3941           s2=scalar2(b1(1,iti1),auxvec(1))
3942           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3943           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3944           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3945           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3946           a_temp(1,1)=aggj1(l,1)
3947           a_temp(1,2)=aggj1(l,2)
3948           a_temp(2,1)=aggj1(l,3)
3949           a_temp(2,2)=aggj1(l,4)
3950           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3951           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3952           s1=scalar2(b1(1,iti2),auxvec(1))
3953           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3954           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3955           s2=scalar2(b1(1,iti1),auxvec(1))
3956           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3957           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3958           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3959 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3960           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3961         enddo
3962       return
3963       end
3964 C-----------------------------------------------------------------------------
3965       subroutine vecpr(u,v,w)
3966       implicit real*8(a-h,o-z)
3967       dimension u(3),v(3),w(3)
3968       w(1)=u(2)*v(3)-u(3)*v(2)
3969       w(2)=-u(1)*v(3)+u(3)*v(1)
3970       w(3)=u(1)*v(2)-u(2)*v(1)
3971       return
3972       end
3973 C-----------------------------------------------------------------------------
3974       subroutine unormderiv(u,ugrad,unorm,ungrad)
3975 C This subroutine computes the derivatives of a normalized vector u, given
3976 C the derivatives computed without normalization conditions, ugrad. Returns
3977 C ungrad.
3978       implicit none
3979       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3980       double precision vec(3)
3981       double precision scalar
3982       integer i,j
3983 c      write (2,*) 'ugrad',ugrad
3984 c      write (2,*) 'u',u
3985       do i=1,3
3986         vec(i)=scalar(ugrad(1,i),u(1))
3987       enddo
3988 c      write (2,*) 'vec',vec
3989       do i=1,3
3990         do j=1,3
3991           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3992         enddo
3993       enddo
3994 c      write (2,*) 'ungrad',ungrad
3995       return
3996       end
3997 C-----------------------------------------------------------------------------
3998       subroutine escp_soft_sphere(evdw2,evdw2_14)
3999 C
4000 C This subroutine calculates the excluded-volume interaction energy between
4001 C peptide-group centers and side chains and its gradient in virtual-bond and
4002 C side-chain vectors.
4003 C
4004       implicit real*8 (a-h,o-z)
4005       include 'DIMENSIONS'
4006       include 'COMMON.GEO'
4007       include 'COMMON.VAR'
4008       include 'COMMON.LOCAL'
4009       include 'COMMON.CHAIN'
4010       include 'COMMON.DERIV'
4011       include 'COMMON.INTERACT'
4012       include 'COMMON.FFIELD'
4013       include 'COMMON.IOUNITS'
4014       include 'COMMON.CONTROL'
4015       dimension ggg(3)
4016       evdw2=0.0D0
4017       evdw2_14=0.0d0
4018       r0_scp=4.5d0
4019 cd    print '(a)','Enter ESCP'
4020 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4021       do i=iatscp_s,iatscp_e
4022         iteli=itel(i)
4023         xi=0.5D0*(c(1,i)+c(1,i+1))
4024         yi=0.5D0*(c(2,i)+c(2,i+1))
4025         zi=0.5D0*(c(3,i)+c(3,i+1))
4026
4027         do iint=1,nscp_gr(i)
4028
4029         do j=iscpstart(i,iint),iscpend(i,iint)
4030           itypj=itype(j)
4031 C Uncomment following three lines for SC-p interactions
4032 c         xj=c(1,nres+j)-xi
4033 c         yj=c(2,nres+j)-yi
4034 c         zj=c(3,nres+j)-zi
4035 C Uncomment following three lines for Ca-p interactions
4036           xj=c(1,j)-xi
4037           yj=c(2,j)-yi
4038           zj=c(3,j)-zi
4039           rij=xj*xj+yj*yj+zj*zj
4040           r0ij=r0_scp
4041           r0ijsq=r0ij*r0ij
4042           if (rij.lt.r0ijsq) then
4043             evdwij=0.25d0*(rij-r0ijsq)**2
4044             fac=rij-r0ijsq
4045           else
4046             evdwij=0.0d0
4047             fac=0.0d0
4048           endif
4049           evdw2=evdw2+evdwij
4050 C
4051 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4052 C
4053           ggg(1)=xj*fac
4054           ggg(2)=yj*fac
4055           ggg(3)=zj*fac
4056 cgrad          if (j.lt.i) then
4057 cd          write (iout,*) 'j<i'
4058 C Uncomment following three lines for SC-p interactions
4059 c           do k=1,3
4060 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4061 c           enddo
4062 cgrad          else
4063 cd          write (iout,*) 'j>i'
4064 cgrad            do k=1,3
4065 cgrad              ggg(k)=-ggg(k)
4066 C Uncomment following line for SC-p interactions
4067 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4068 cgrad            enddo
4069 cgrad          endif
4070 cgrad          do k=1,3
4071 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4072 cgrad          enddo
4073 cgrad          kstart=min0(i+1,j)
4074 cgrad          kend=max0(i-1,j-1)
4075 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4076 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4077 cgrad          do k=kstart,kend
4078 cgrad            do l=1,3
4079 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4080 cgrad            enddo
4081 cgrad          enddo
4082           do k=1,3
4083             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4084             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4085           enddo
4086         enddo
4087
4088         enddo ! iint
4089       enddo ! i
4090       return
4091       end
4092 C-----------------------------------------------------------------------------
4093       subroutine escp(evdw2,evdw2_14)
4094 C
4095 C This subroutine calculates the excluded-volume interaction energy between
4096 C peptide-group centers and side chains and its gradient in virtual-bond and
4097 C side-chain vectors.
4098 C
4099       implicit real*8 (a-h,o-z)
4100       include 'DIMENSIONS'
4101       include 'COMMON.GEO'
4102       include 'COMMON.VAR'
4103       include 'COMMON.LOCAL'
4104       include 'COMMON.CHAIN'
4105       include 'COMMON.DERIV'
4106       include 'COMMON.INTERACT'
4107       include 'COMMON.FFIELD'
4108       include 'COMMON.IOUNITS'
4109       include 'COMMON.CONTROL'
4110       dimension ggg(3)
4111       evdw2=0.0D0
4112       evdw2_14=0.0d0
4113 cd    print '(a)','Enter ESCP'
4114 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4115       do i=iatscp_s,iatscp_e
4116         iteli=itel(i)
4117         xi=0.5D0*(c(1,i)+c(1,i+1))
4118         yi=0.5D0*(c(2,i)+c(2,i+1))
4119         zi=0.5D0*(c(3,i)+c(3,i+1))
4120
4121         do iint=1,nscp_gr(i)
4122
4123         do j=iscpstart(i,iint),iscpend(i,iint)
4124           itypj=itype(j)
4125 C Uncomment following three lines for SC-p interactions
4126 c         xj=c(1,nres+j)-xi
4127 c         yj=c(2,nres+j)-yi
4128 c         zj=c(3,nres+j)-zi
4129 C Uncomment following three lines for Ca-p interactions
4130           xj=c(1,j)-xi
4131           yj=c(2,j)-yi
4132           zj=c(3,j)-zi
4133           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4134           fac=rrij**expon2
4135           e1=fac*fac*aad(itypj,iteli)
4136           e2=fac*bad(itypj,iteli)
4137           if (iabs(j-i) .le. 2) then
4138             e1=scal14*e1
4139             e2=scal14*e2
4140             evdw2_14=evdw2_14+e1+e2
4141           endif
4142           evdwij=e1+e2
4143           evdw2=evdw2+evdwij
4144           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4145      &        'evdw2',i,j,evdwij
4146 C
4147 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4148 C
4149           fac=-(evdwij+e1)*rrij
4150           ggg(1)=xj*fac
4151           ggg(2)=yj*fac
4152           ggg(3)=zj*fac
4153 cgrad          if (j.lt.i) then
4154 cd          write (iout,*) 'j<i'
4155 C Uncomment following three lines for SC-p interactions
4156 c           do k=1,3
4157 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4158 c           enddo
4159 cgrad          else
4160 cd          write (iout,*) 'j>i'
4161 cgrad            do k=1,3
4162 cgrad              ggg(k)=-ggg(k)
4163 C Uncomment following line for SC-p interactions
4164 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4165 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4166 cgrad            enddo
4167 cgrad          endif
4168 cgrad          do k=1,3
4169 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4170 cgrad          enddo
4171 cgrad          kstart=min0(i+1,j)
4172 cgrad          kend=max0(i-1,j-1)
4173 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4174 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4175 cgrad          do k=kstart,kend
4176 cgrad            do l=1,3
4177 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4178 cgrad            enddo
4179 cgrad          enddo
4180           do k=1,3
4181             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4182             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4183           enddo
4184         enddo
4185
4186         enddo ! iint
4187       enddo ! i
4188       do i=1,nct
4189         do j=1,3
4190           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4191           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4192           gradx_scp(j,i)=expon*gradx_scp(j,i)
4193         enddo
4194       enddo
4195 C******************************************************************************
4196 C
4197 C                              N O T E !!!
4198 C
4199 C To save time the factor EXPON has been extracted from ALL components
4200 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4201 C use!
4202 C
4203 C******************************************************************************
4204       return
4205       end
4206 C--------------------------------------------------------------------------
4207       subroutine edis(ehpb)
4208 C
4209 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4210 C
4211       implicit real*8 (a-h,o-z)
4212       include 'DIMENSIONS'
4213       include 'COMMON.SBRIDGE'
4214       include 'COMMON.CHAIN'
4215       include 'COMMON.DERIV'
4216       include 'COMMON.VAR'
4217       include 'COMMON.INTERACT'
4218       include 'COMMON.IOUNITS'
4219       dimension ggg(3)
4220       ehpb=0.0D0
4221 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4222 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4223       if (link_end.eq.0) return
4224       do i=link_start,link_end
4225 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4226 C CA-CA distance used in regularization of structure.
4227         ii=ihpb(i)
4228         jj=jhpb(i)
4229 C iii and jjj point to the residues for which the distance is assigned.
4230         if (ii.gt.nres) then
4231           iii=ii-nres
4232           jjj=jj-nres
4233         else
4234           iii=ii
4235           jjj=jj
4236         endif
4237 cd        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj
4238 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4239 C    distance and angle dependent SS bond potential.
4240         if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4241           call ssbond_ene(iii,jjj,eij)
4242           ehpb=ehpb+2*eij
4243 cd          write (iout,*) "eij",eij
4244         else
4245 C Calculate the distance between the two points and its difference from the
4246 C target distance.
4247           dd=dist(ii,jj)
4248             rdis=dd-dhpb(i)
4249 C Get the force constant corresponding to this distance.
4250             waga=forcon(i)
4251 C Calculate the contribution to energy.
4252             ehpb=ehpb+waga*rdis*rdis
4253 C
4254 C Evaluate gradient.
4255 C
4256             fac=waga*rdis/dd
4257 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4258 cd   &   ' waga=',waga,' fac=',fac
4259             do j=1,3
4260               ggg(j)=fac*(c(j,jj)-c(j,ii))
4261             enddo
4262 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4263 C If this is a SC-SC distance, we need to calculate the contributions to the
4264 C Cartesian gradient in the SC vectors (ghpbx).
4265           if (iii.lt.ii) then
4266           do j=1,3
4267             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4268             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4269           enddo
4270           endif
4271 cgrad        do j=iii,jjj-1
4272 cgrad          do k=1,3
4273 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4274 cgrad          enddo
4275 cgrad        enddo
4276           do k=1,3
4277             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4278             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4279           enddo
4280         endif
4281       enddo
4282       ehpb=0.5D0*ehpb
4283       return
4284       end
4285 C--------------------------------------------------------------------------
4286       subroutine ssbond_ene(i,j,eij)
4287 C
4288 C Calculate the distance and angle dependent SS-bond potential energy
4289 C using a free-energy function derived based on RHF/6-31G** ab initio
4290 C calculations of diethyl disulfide.
4291 C
4292 C A. Liwo and U. Kozlowska, 11/24/03
4293 C
4294       implicit real*8 (a-h,o-z)
4295       include 'DIMENSIONS'
4296       include 'COMMON.SBRIDGE'
4297       include 'COMMON.CHAIN'
4298       include 'COMMON.DERIV'
4299       include 'COMMON.LOCAL'
4300       include 'COMMON.INTERACT'
4301       include 'COMMON.VAR'
4302       include 'COMMON.IOUNITS'
4303       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4304       itypi=itype(i)
4305       xi=c(1,nres+i)
4306       yi=c(2,nres+i)
4307       zi=c(3,nres+i)
4308       dxi=dc_norm(1,nres+i)
4309       dyi=dc_norm(2,nres+i)
4310       dzi=dc_norm(3,nres+i)
4311 c      dsci_inv=dsc_inv(itypi)
4312       dsci_inv=vbld_inv(nres+i)
4313       itypj=itype(j)
4314 c      dscj_inv=dsc_inv(itypj)
4315       dscj_inv=vbld_inv(nres+j)
4316       xj=c(1,nres+j)-xi
4317       yj=c(2,nres+j)-yi
4318       zj=c(3,nres+j)-zi
4319       dxj=dc_norm(1,nres+j)
4320       dyj=dc_norm(2,nres+j)
4321       dzj=dc_norm(3,nres+j)
4322       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4323       rij=dsqrt(rrij)
4324       erij(1)=xj*rij
4325       erij(2)=yj*rij
4326       erij(3)=zj*rij
4327       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4328       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4329       om12=dxi*dxj+dyi*dyj+dzi*dzj
4330       do k=1,3
4331         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4332         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4333       enddo
4334       rij=1.0d0/rij
4335       deltad=rij-d0cm
4336       deltat1=1.0d0-om1
4337       deltat2=1.0d0+om2
4338       deltat12=om2-om1+2.0d0
4339       cosphi=om12-om1*om2
4340       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4341      &  +akct*deltad*deltat12
4342      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4343 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4344 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4345 c     &  " deltat12",deltat12," eij",eij
4346       ed=2*akcm*deltad+akct*deltat12
4347       pom1=akct*deltad
4348       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4349       eom1=-2*akth*deltat1-pom1-om2*pom2
4350       eom2= 2*akth*deltat2+pom1-om1*pom2
4351       eom12=pom2
4352       do k=1,3
4353         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4354         ghpbx(k,i)=ghpbx(k,i)-ggk
4355      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4356      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4357         ghpbx(k,j)=ghpbx(k,j)+ggk
4358      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4359      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4360         ghpbc(k,i)=ghpbc(k,i)-ggk
4361         ghpbc(k,j)=ghpbc(k,j)+ggk
4362       enddo
4363 C
4364 C Calculate the components of the gradient in DC and X
4365 C
4366 cgrad      do k=i,j-1
4367 cgrad        do l=1,3
4368 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4369 cgrad        enddo
4370 cgrad      enddo
4371       return
4372       end
4373 C--------------------------------------------------------------------------
4374       subroutine ebond(estr)
4375 c
4376 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4377 c
4378       implicit real*8 (a-h,o-z)
4379       include 'DIMENSIONS'
4380       include 'COMMON.LOCAL'
4381       include 'COMMON.GEO'
4382       include 'COMMON.INTERACT'
4383       include 'COMMON.DERIV'
4384       include 'COMMON.VAR'
4385       include 'COMMON.CHAIN'
4386       include 'COMMON.IOUNITS'
4387       include 'COMMON.NAMES'
4388       include 'COMMON.FFIELD'
4389       include 'COMMON.CONTROL'
4390       include 'COMMON.SETUP'
4391       double precision u(3),ud(3)
4392       estr=0.0d0
4393       do i=ibondp_start,ibondp_end
4394         diff = vbld(i)-vbldp0
4395 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4396         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
4397      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4398         estr=estr+diff*diff
4399         do j=1,3
4400           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4401         enddo
4402 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4403       enddo
4404       estr=0.5d0*AKP*estr
4405 c
4406 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4407 c
4408       do i=ibond_start,ibond_end
4409         iti=itype(i)
4410         if (iti.ne.10) then
4411           nbi=nbondterm(iti)
4412           if (nbi.eq.1) then
4413             diff=vbld(i+nres)-vbldsc0(1,iti)
4414 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4415 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4416             if (energy_dec)  then
4417               write (iout,*)
4418      &         "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4419      &         AKSC(1,iti),AKSC(1,iti)*diff*diff
4420               call flush(iout)
4421             endif
4422             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4423             do j=1,3
4424               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4425             enddo
4426           else
4427             do j=1,nbi
4428               diff=vbld(i+nres)-vbldsc0(j,iti)
4429               ud(j)=aksc(j,iti)*diff
4430               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4431             enddo
4432             uprod=u(1)
4433             do j=2,nbi
4434               uprod=uprod*u(j)
4435             enddo
4436             usum=0.0d0
4437             usumsqder=0.0d0
4438             do j=1,nbi
4439               uprod1=1.0d0
4440               uprod2=1.0d0
4441               do k=1,nbi
4442                 if (k.ne.j) then
4443                   uprod1=uprod1*u(k)
4444                   uprod2=uprod2*u(k)*u(k)
4445                 endif
4446               enddo
4447               usum=usum+uprod1
4448               usumsqder=usumsqder+ud(j)*uprod2
4449             enddo
4450             estr=estr+uprod/usum
4451             do j=1,3
4452              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4453             enddo
4454           endif
4455         endif
4456       enddo
4457       return
4458       end
4459 #ifdef CRYST_THETA
4460 C--------------------------------------------------------------------------
4461       subroutine ebend(etheta)
4462 C
4463 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4464 C angles gamma and its derivatives in consecutive thetas and gammas.
4465 C
4466       implicit real*8 (a-h,o-z)
4467       include 'DIMENSIONS'
4468       include 'COMMON.LOCAL'
4469       include 'COMMON.GEO'
4470       include 'COMMON.INTERACT'
4471       include 'COMMON.DERIV'
4472       include 'COMMON.VAR'
4473       include 'COMMON.CHAIN'
4474       include 'COMMON.IOUNITS'
4475       include 'COMMON.NAMES'
4476       include 'COMMON.FFIELD'
4477       include 'COMMON.CONTROL'
4478       common /calcthet/ term1,term2,termm,diffak,ratak,
4479      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4480      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4481       double precision y(2),z(2)
4482       delta=0.02d0*pi
4483 c      time11=dexp(-2*time)
4484 c      time12=1.0d0
4485       etheta=0.0D0
4486 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4487       do i=ithet_start,ithet_end
4488 C Zero the energy function and its derivative at 0 or pi.
4489         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4490         it=itype(i-1)
4491         if (i.gt.3) then
4492 #ifdef OSF
4493           phii=phi(i)
4494           if (phii.ne.phii) phii=150.0
4495 #else
4496           phii=phi(i)
4497 #endif
4498           y(1)=dcos(phii)
4499           y(2)=dsin(phii)
4500         else
4501           y(1)=0.0D0
4502           y(2)=0.0D0
4503         endif
4504         if (i.lt.nres) then
4505 #ifdef OSF
4506           phii1=phi(i+1)
4507           if (phii1.ne.phii1) phii1=150.0
4508           phii1=pinorm(phii1)
4509           z(1)=cos(phii1)
4510 #else
4511           phii1=phi(i+1)
4512           z(1)=dcos(phii1)
4513 #endif
4514           z(2)=dsin(phii1)
4515         else
4516           z(1)=0.0D0
4517           z(2)=0.0D0
4518         endif
4519 C Calculate the "mean" value of theta from the part of the distribution
4520 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4521 C In following comments this theta will be referred to as t_c.
4522         thet_pred_mean=0.0d0
4523         do k=1,2
4524           athetk=athet(k,it)
4525           bthetk=bthet(k,it)
4526           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4527         enddo
4528         dthett=thet_pred_mean*ssd
4529         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4530 C Derivatives of the "mean" values in gamma1 and gamma2.
4531         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
4532         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
4533         if (theta(i).gt.pi-delta) then
4534           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4535      &         E_tc0)
4536           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4537           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4538           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4539      &        E_theta)
4540           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4541      &        E_tc)
4542         else if (theta(i).lt.delta) then
4543           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4544           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4545           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4546      &        E_theta)
4547           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4548           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4549      &        E_tc)
4550         else
4551           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4552      &        E_theta,E_tc)
4553         endif
4554         etheta=etheta+ethetai
4555         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4556      &      'ebend',i,ethetai
4557         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4558         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4559         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4560       enddo
4561 C Ufff.... We've done all this!!!
4562       return
4563       end
4564 C---------------------------------------------------------------------------
4565       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4566      &     E_tc)
4567       implicit real*8 (a-h,o-z)
4568       include 'DIMENSIONS'
4569       include 'COMMON.LOCAL'
4570       include 'COMMON.IOUNITS'
4571       common /calcthet/ term1,term2,termm,diffak,ratak,
4572      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4573      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4574 C Calculate the contributions to both Gaussian lobes.
4575 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4576 C The "polynomial part" of the "standard deviation" of this part of
4577 C the distribution.
4578         sig=polthet(3,it)
4579         do j=2,0,-1
4580           sig=sig*thet_pred_mean+polthet(j,it)
4581         enddo
4582 C Derivative of the "interior part" of the "standard deviation of the"
4583 C gamma-dependent Gaussian lobe in t_c.
4584         sigtc=3*polthet(3,it)
4585         do j=2,1,-1
4586           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4587         enddo
4588         sigtc=sig*sigtc
4589 C Set the parameters of both Gaussian lobes of the distribution.
4590 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4591         fac=sig*sig+sigc0(it)
4592         sigcsq=fac+fac
4593         sigc=1.0D0/sigcsq
4594 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4595         sigsqtc=-4.0D0*sigcsq*sigtc
4596 c       print *,i,sig,sigtc,sigsqtc
4597 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4598         sigtc=-sigtc/(fac*fac)
4599 C Following variable is sigma(t_c)**(-2)
4600         sigcsq=sigcsq*sigcsq
4601         sig0i=sig0(it)
4602         sig0inv=1.0D0/sig0i**2
4603         delthec=thetai-thet_pred_mean
4604         delthe0=thetai-theta0i
4605         term1=-0.5D0*sigcsq*delthec*delthec
4606         term2=-0.5D0*sig0inv*delthe0*delthe0
4607 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4608 C NaNs in taking the logarithm. We extract the largest exponent which is added
4609 C to the energy (this being the log of the distribution) at the end of energy
4610 C term evaluation for this virtual-bond angle.
4611         if (term1.gt.term2) then
4612           termm=term1
4613           term2=dexp(term2-termm)
4614           term1=1.0d0
4615         else
4616           termm=term2
4617           term1=dexp(term1-termm)
4618           term2=1.0d0
4619         endif
4620 C The ratio between the gamma-independent and gamma-dependent lobes of
4621 C the distribution is a Gaussian function of thet_pred_mean too.
4622         diffak=gthet(2,it)-thet_pred_mean
4623         ratak=diffak/gthet(3,it)**2
4624         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4625 C Let's differentiate it in thet_pred_mean NOW.
4626         aktc=ak*ratak
4627 C Now put together the distribution terms to make complete distribution.
4628         termexp=term1+ak*term2
4629         termpre=sigc+ak*sig0i
4630 C Contribution of the bending energy from this theta is just the -log of
4631 C the sum of the contributions from the two lobes and the pre-exponential
4632 C factor. Simple enough, isn't it?
4633         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4634 C NOW the derivatives!!!
4635 C 6/6/97 Take into account the deformation.
4636         E_theta=(delthec*sigcsq*term1
4637      &       +ak*delthe0*sig0inv*term2)/termexp
4638         E_tc=((sigtc+aktc*sig0i)/termpre
4639      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4640      &       aktc*term2)/termexp)
4641       return
4642       end
4643 c-----------------------------------------------------------------------------
4644       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4645       implicit real*8 (a-h,o-z)
4646       include 'DIMENSIONS'
4647       include 'COMMON.LOCAL'
4648       include 'COMMON.IOUNITS'
4649       common /calcthet/ term1,term2,termm,diffak,ratak,
4650      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4651      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4652       delthec=thetai-thet_pred_mean
4653       delthe0=thetai-theta0i
4654 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4655       t3 = thetai-thet_pred_mean
4656       t6 = t3**2
4657       t9 = term1
4658       t12 = t3*sigcsq
4659       t14 = t12+t6*sigsqtc
4660       t16 = 1.0d0
4661       t21 = thetai-theta0i
4662       t23 = t21**2
4663       t26 = term2
4664       t27 = t21*t26
4665       t32 = termexp
4666       t40 = t32**2
4667       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4668      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4669      & *(-t12*t9-ak*sig0inv*t27)
4670       return
4671       end
4672 #else
4673 C--------------------------------------------------------------------------
4674       subroutine ebend(etheta)
4675 C
4676 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4677 C angles gamma and its derivatives in consecutive thetas and gammas.
4678 C ab initio-derived potentials from
4679 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4680 C
4681       implicit real*8 (a-h,o-z)
4682       include 'DIMENSIONS'
4683       include 'COMMON.LOCAL'
4684       include 'COMMON.GEO'
4685       include 'COMMON.INTERACT'
4686       include 'COMMON.DERIV'
4687       include 'COMMON.VAR'
4688       include 'COMMON.CHAIN'
4689       include 'COMMON.IOUNITS'
4690       include 'COMMON.NAMES'
4691       include 'COMMON.FFIELD'
4692       include 'COMMON.CONTROL'
4693       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4694      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4695      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4696      & sinph1ph2(maxdouble,maxdouble)
4697       logical lprn /.false./, lprn1 /.false./
4698       etheta=0.0D0
4699       do i=ithet_start,ithet_end
4700         if ((itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
4701      &(itype(i).eq.ntyp1)) cycle
4702         dethetai=0.0d0
4703         dephii=0.0d0
4704         dephii1=0.0d0
4705         theti2=0.5d0*theta(i)
4706         ityp2=ithetyp(itype(i-1))
4707         do k=1,nntheterm
4708           coskt(k)=dcos(k*theti2)
4709           sinkt(k)=dsin(k*theti2)
4710         enddo
4711 C        if (i.gt.3) then
4712         if (i.gt.3 .and. itype(max0(i-3,1)).ne.ntyp1) then
4713 #ifdef OSF
4714           phii=phi(i)
4715           if (phii.ne.phii) phii=150.0
4716 #else
4717           phii=phi(i)
4718 #endif
4719           ityp1=ithetyp(itype(i-2))
4720           do k=1,nsingle
4721             cosph1(k)=dcos(k*phii)
4722             sinph1(k)=dsin(k*phii)
4723           enddo
4724         else
4725           phii=0.0d0
4726           ityp1=ithetyp(itype(i-2))
4727           do k=1,nsingle
4728             cosph1(k)=0.0d0
4729             sinph1(k)=0.0d0
4730           enddo
4731         endif
4732         if ((i.lt.nres).and. itype(i+1).ne.ntyp1) then
4733 #ifdef OSF
4734           phii1=phi(i+1)
4735           if (phii1.ne.phii1) phii1=150.0
4736           phii1=pinorm(phii1)
4737 #else
4738           phii1=phi(i+1)
4739 #endif
4740           ityp3=ithetyp(itype(i))
4741           do k=1,nsingle
4742             cosph2(k)=dcos(k*phii1)
4743             sinph2(k)=dsin(k*phii1)
4744           enddo
4745         else
4746           phii1=0.0d0
4747           ityp3=ithetyp(itype(i))
4748           do k=1,nsingle
4749             cosph2(k)=0.0d0
4750             sinph2(k)=0.0d0
4751           enddo
4752         endif
4753         ethetai=aa0thet(ityp1,ityp2,ityp3)
4754         do k=1,ndouble
4755           do l=1,k-1
4756             ccl=cosph1(l)*cosph2(k-l)
4757             ssl=sinph1(l)*sinph2(k-l)
4758             scl=sinph1(l)*cosph2(k-l)
4759             csl=cosph1(l)*sinph2(k-l)
4760             cosph1ph2(l,k)=ccl-ssl
4761             cosph1ph2(k,l)=ccl+ssl
4762             sinph1ph2(l,k)=scl+csl
4763             sinph1ph2(k,l)=scl-csl
4764           enddo
4765         enddo
4766         if (lprn) then
4767         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4768      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4769         write (iout,*) "coskt and sinkt"
4770         do k=1,nntheterm
4771           write (iout,*) k,coskt(k),sinkt(k)
4772         enddo
4773         endif
4774         do k=1,ntheterm
4775           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4776           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4777      &      *coskt(k)
4778           if (lprn)
4779      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4780      &     " ethetai",ethetai
4781         enddo
4782         if (lprn) then
4783         write (iout,*) "cosph and sinph"
4784         do k=1,nsingle
4785           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4786         enddo
4787         write (iout,*) "cosph1ph2 and sinph2ph2"
4788         do k=2,ndouble
4789           do l=1,k-1
4790             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4791      &         sinph1ph2(l,k),sinph1ph2(k,l)
4792           enddo
4793         enddo
4794         write(iout,*) "ethetai",ethetai
4795         endif
4796         do m=1,ntheterm2
4797           do k=1,nsingle
4798             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4799      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4800      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4801      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4802             ethetai=ethetai+sinkt(m)*aux
4803             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4804             dephii=dephii+k*sinkt(m)*(
4805      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4806      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4807             dephii1=dephii1+k*sinkt(m)*(
4808      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4809      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4810             if (lprn)
4811      &      write (iout,*) "m",m," k",k," bbthet",
4812      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4813      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4814      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4815      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4816           enddo
4817         enddo
4818         if (lprn)
4819      &  write(iout,*) "ethetai",ethetai
4820         do m=1,ntheterm3
4821           do k=2,ndouble
4822             do l=1,k-1
4823               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4824      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4825      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4826      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4827               ethetai=ethetai+sinkt(m)*aux
4828               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4829               dephii=dephii+l*sinkt(m)*(
4830      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4831      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4832      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4833      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4834               dephii1=dephii1+(k-l)*sinkt(m)*(
4835      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4836      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4837      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
4838      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4839               if (lprn) then
4840               write (iout,*) "m",m," k",k," l",l," ffthet",
4841      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
4842      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
4843      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
4844      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4845               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4846      &            cosph1ph2(k,l)*sinkt(m),
4847      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4848               endif
4849             enddo
4850           enddo
4851         enddo
4852 10      continue
4853         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4854      &   i,theta(i)*rad2deg,phii*rad2deg,
4855      &   phii1*rad2deg,ethetai
4856         etheta=etheta+ethetai
4857         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4858      &      'ebend',i,ethetai
4859         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4860         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4861         gloc(nphi+i-2,icg)=wang*dethetai
4862       enddo
4863       return
4864       end
4865 #endif
4866 #ifdef CRYST_SC
4867 c-----------------------------------------------------------------------------
4868       subroutine esc(escloc)
4869 C Calculate the local energy of a side chain and its derivatives in the
4870 C corresponding virtual-bond valence angles THETA and the spherical angles
4871 C ALPHA and OMEGA.
4872       implicit real*8 (a-h,o-z)
4873       include 'DIMENSIONS'
4874       include 'COMMON.GEO'
4875       include 'COMMON.LOCAL'
4876       include 'COMMON.VAR'
4877       include 'COMMON.INTERACT'
4878       include 'COMMON.DERIV'
4879       include 'COMMON.CHAIN'
4880       include 'COMMON.IOUNITS'
4881       include 'COMMON.NAMES'
4882       include 'COMMON.FFIELD'
4883       include 'COMMON.CONTROL'
4884       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4885      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4886       common /sccalc/ time11,time12,time112,theti,it,nlobit
4887       delta=0.02d0*pi
4888       escloc=0.0D0
4889 c     write (iout,'(a)') 'ESC'
4890       do i=loc_start,loc_end
4891         it=itype(i)
4892         if (it.eq.10) goto 1
4893         nlobit=nlob(it)
4894 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4895 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4896         theti=theta(i+1)-pipol
4897         x(1)=dtan(theti)
4898         x(2)=alph(i)
4899         x(3)=omeg(i)
4900
4901         if (x(2).gt.pi-delta) then
4902           xtemp(1)=x(1)
4903           xtemp(2)=pi-delta
4904           xtemp(3)=x(3)
4905           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4906           xtemp(2)=pi
4907           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4908           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4909      &        escloci,dersc(2))
4910           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4911      &        ddersc0(1),dersc(1))
4912           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4913      &        ddersc0(3),dersc(3))
4914           xtemp(2)=pi-delta
4915           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4916           xtemp(2)=pi
4917           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4918           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4919      &            dersc0(2),esclocbi,dersc02)
4920           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4921      &            dersc12,dersc01)
4922           call splinthet(x(2),0.5d0*delta,ss,ssd)
4923           dersc0(1)=dersc01
4924           dersc0(2)=dersc02
4925           dersc0(3)=0.0d0
4926           do k=1,3
4927             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4928           enddo
4929           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4930 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4931 c    &             esclocbi,ss,ssd
4932           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4933 c         escloci=esclocbi
4934 c         write (iout,*) escloci
4935         else if (x(2).lt.delta) then
4936           xtemp(1)=x(1)
4937           xtemp(2)=delta
4938           xtemp(3)=x(3)
4939           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4940           xtemp(2)=0.0d0
4941           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4942           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4943      &        escloci,dersc(2))
4944           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4945      &        ddersc0(1),dersc(1))
4946           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4947      &        ddersc0(3),dersc(3))
4948           xtemp(2)=delta
4949           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4950           xtemp(2)=0.0d0
4951           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4952           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4953      &            dersc0(2),esclocbi,dersc02)
4954           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4955      &            dersc12,dersc01)
4956           dersc0(1)=dersc01
4957           dersc0(2)=dersc02
4958           dersc0(3)=0.0d0
4959           call splinthet(x(2),0.5d0*delta,ss,ssd)
4960           do k=1,3
4961             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4962           enddo
4963           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4964 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4965 c    &             esclocbi,ss,ssd
4966           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4967 c         write (iout,*) escloci
4968         else
4969           call enesc(x,escloci,dersc,ddummy,.false.)
4970         endif
4971
4972         escloc=escloc+escloci
4973         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4974      &     'escloc',i,escloci
4975 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4976
4977         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4978      &   wscloc*dersc(1)
4979         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4980         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4981     1   continue
4982       enddo
4983       return
4984       end
4985 C---------------------------------------------------------------------------
4986       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4987       implicit real*8 (a-h,o-z)
4988       include 'DIMENSIONS'
4989       include 'COMMON.GEO'
4990       include 'COMMON.LOCAL'
4991       include 'COMMON.IOUNITS'
4992       common /sccalc/ time11,time12,time112,theti,it,nlobit
4993       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4994       double precision contr(maxlob,-1:1)
4995       logical mixed
4996 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4997         escloc_i=0.0D0
4998         do j=1,3
4999           dersc(j)=0.0D0
5000           if (mixed) ddersc(j)=0.0d0
5001         enddo
5002         x3=x(3)
5003
5004 C Because of periodicity of the dependence of the SC energy in omega we have
5005 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5006 C To avoid underflows, first compute & store the exponents.
5007
5008         do iii=-1,1
5009
5010           x(3)=x3+iii*dwapi
5011
5012           do j=1,nlobit
5013             do k=1,3
5014               z(k)=x(k)-censc(k,j,it)
5015             enddo
5016             do k=1,3
5017               Axk=0.0D0
5018               do l=1,3
5019                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5020               enddo
5021               Ax(k,j,iii)=Axk
5022             enddo
5023             expfac=0.0D0
5024             do k=1,3
5025               expfac=expfac+Ax(k,j,iii)*z(k)
5026             enddo
5027             contr(j,iii)=expfac
5028           enddo ! j
5029
5030         enddo ! iii
5031
5032         x(3)=x3
5033 C As in the case of ebend, we want to avoid underflows in exponentiation and
5034 C subsequent NaNs and INFs in energy calculation.
5035 C Find the largest exponent
5036         emin=contr(1,-1)
5037         do iii=-1,1
5038           do j=1,nlobit
5039             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5040           enddo
5041         enddo
5042         emin=0.5D0*emin
5043 cd      print *,'it=',it,' emin=',emin
5044
5045 C Compute the contribution to SC energy and derivatives
5046         do iii=-1,1
5047
5048           do j=1,nlobit
5049 #ifdef OSF
5050             adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin
5051             if(adexp.ne.adexp) adexp=1.0
5052             expfac=dexp(adexp)
5053 #else
5054             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
5055 #endif
5056 cd          print *,'j=',j,' expfac=',expfac
5057             escloc_i=escloc_i+expfac
5058             do k=1,3
5059               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5060             enddo
5061             if (mixed) then
5062               do k=1,3,2
5063                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5064      &            +gaussc(k,2,j,it))*expfac
5065               enddo
5066             endif
5067           enddo
5068
5069         enddo ! iii
5070
5071         dersc(1)=dersc(1)/cos(theti)**2
5072         ddersc(1)=ddersc(1)/cos(theti)**2
5073         ddersc(3)=ddersc(3)
5074
5075         escloci=-(dlog(escloc_i)-emin)
5076         do j=1,3
5077           dersc(j)=dersc(j)/escloc_i
5078         enddo
5079         if (mixed) then
5080           do j=1,3,2
5081             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5082           enddo
5083         endif
5084       return
5085       end
5086 C------------------------------------------------------------------------------
5087       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5088       implicit real*8 (a-h,o-z)
5089       include 'DIMENSIONS'
5090       include 'COMMON.GEO'
5091       include 'COMMON.LOCAL'
5092       include 'COMMON.IOUNITS'
5093       common /sccalc/ time11,time12,time112,theti,it,nlobit
5094       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5095       double precision contr(maxlob)
5096       logical mixed
5097
5098       escloc_i=0.0D0
5099
5100       do j=1,3
5101         dersc(j)=0.0D0
5102       enddo
5103
5104       do j=1,nlobit
5105         do k=1,2
5106           z(k)=x(k)-censc(k,j,it)
5107         enddo
5108         z(3)=dwapi
5109         do k=1,3
5110           Axk=0.0D0
5111           do l=1,3
5112             Axk=Axk+gaussc(l,k,j,it)*z(l)
5113           enddo
5114           Ax(k,j)=Axk
5115         enddo
5116         expfac=0.0D0
5117         do k=1,3
5118           expfac=expfac+Ax(k,j)*z(k)
5119         enddo
5120         contr(j)=expfac
5121       enddo ! j
5122
5123 C As in the case of ebend, we want to avoid underflows in exponentiation and
5124 C subsequent NaNs and INFs in energy calculation.
5125 C Find the largest exponent
5126       emin=contr(1)
5127       do j=1,nlobit
5128         if (emin.gt.contr(j)) emin=contr(j)
5129       enddo
5130       emin=0.5D0*emin
5131
5132 C Compute the contribution to SC energy and derivatives
5133
5134       dersc12=0.0d0
5135       do j=1,nlobit
5136         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
5137         escloc_i=escloc_i+expfac
5138         do k=1,2
5139           dersc(k)=dersc(k)+Ax(k,j)*expfac
5140         enddo
5141         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5142      &            +gaussc(1,2,j,it))*expfac
5143         dersc(3)=0.0d0
5144       enddo
5145
5146       dersc(1)=dersc(1)/cos(theti)**2
5147       dersc12=dersc12/cos(theti)**2
5148       escloci=-(dlog(escloc_i)-emin)
5149       do j=1,2
5150         dersc(j)=dersc(j)/escloc_i
5151       enddo
5152       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5153       return
5154       end
5155 #else
5156 c----------------------------------------------------------------------------------
5157       subroutine esc(escloc)
5158 C Calculate the local energy of a side chain and its derivatives in the
5159 C corresponding virtual-bond valence angles THETA and the spherical angles
5160 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5161 C added by Urszula Kozlowska. 07/11/2007
5162 C
5163       implicit real*8 (a-h,o-z)
5164       include 'DIMENSIONS'
5165       include 'COMMON.GEO'
5166       include 'COMMON.LOCAL'
5167       include 'COMMON.VAR'
5168       include 'COMMON.SCROT'
5169       include 'COMMON.INTERACT'
5170       include 'COMMON.DERIV'
5171       include 'COMMON.CHAIN'
5172       include 'COMMON.IOUNITS'
5173       include 'COMMON.NAMES'
5174       include 'COMMON.FFIELD'
5175       include 'COMMON.CONTROL'
5176       include 'COMMON.VECTORS'
5177       double precision x_prime(3),y_prime(3),z_prime(3)
5178      &    , sumene,dsc_i,dp2_i,x(65),
5179      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5180      &    de_dxx,de_dyy,de_dzz,de_dt
5181       double precision s1_t,s1_6_t,s2_t,s2_6_t
5182       double precision
5183      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5184      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5185      & dt_dCi(3),dt_dCi1(3)
5186       common /sccalc/ time11,time12,time112,theti,it,nlobit
5187       delta=0.02d0*pi
5188       escloc=0.0D0
5189       do i=loc_start,loc_end
5190         costtab(i+1) =dcos(theta(i+1))
5191         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5192         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5193         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5194         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5195         cosfac=dsqrt(cosfac2)
5196         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5197         sinfac=dsqrt(sinfac2)
5198         it=itype(i)
5199         if (it.eq.10) goto 1
5200 c
5201 C  Compute the axes of tghe local cartesian coordinates system; store in
5202 c   x_prime, y_prime and z_prime
5203 c
5204         do j=1,3
5205           x_prime(j) = 0.00
5206           y_prime(j) = 0.00
5207           z_prime(j) = 0.00
5208         enddo
5209 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5210 C     &   dc_norm(3,i+nres)
5211         do j = 1,3
5212           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5213           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5214         enddo
5215         do j = 1,3
5216           z_prime(j) = -uz(j,i-1)
5217         enddo
5218 c       write (2,*) "i",i
5219 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5220 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5221 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5222 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5223 c      & " xy",scalar(x_prime(1),y_prime(1)),
5224 c      & " xz",scalar(x_prime(1),z_prime(1)),
5225 c      & " yy",scalar(y_prime(1),y_prime(1)),
5226 c      & " yz",scalar(y_prime(1),z_prime(1)),
5227 c      & " zz",scalar(z_prime(1),z_prime(1))
5228 c
5229 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5230 C to local coordinate system. Store in xx, yy, zz.
5231 c
5232         xx=0.0d0
5233         yy=0.0d0
5234         zz=0.0d0
5235         do j = 1,3
5236           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5237           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5238           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5239         enddo
5240
5241         xxtab(i)=xx
5242         yytab(i)=yy
5243         zztab(i)=zz
5244 C
5245 C Compute the energy of the ith side cbain
5246 C
5247 c        write (2,*) "xx",xx," yy",yy," zz",zz
5248         it=itype(i)
5249         do j = 1,65
5250           x(j) = sc_parmin(j,it)
5251         enddo
5252 #ifdef CHECK_COORD
5253 Cc diagnostics - remove later
5254         xx1 = dcos(alph(2))
5255         yy1 = dsin(alph(2))*dcos(omeg(2))
5256         zz1 = -dsin(alph(2))*dsin(omeg(2))
5257         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5258      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5259      &    xx1,yy1,zz1
5260 C,"  --- ", xx_w,yy_w,zz_w
5261 c end diagnostics
5262 #endif
5263         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5264      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5265      &   + x(10)*yy*zz
5266         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5267      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5268      & + x(20)*yy*zz
5269         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5270      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5271      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5272      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5273      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5274      &  +x(40)*xx*yy*zz
5275         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5276      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5277      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5278      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5279      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5280      &  +x(60)*xx*yy*zz
5281         dsc_i   = 0.743d0+x(61)
5282         dp2_i   = 1.9d0+x(62)
5283         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5284      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5285         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5286      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5287         s1=(1+x(63))/(0.1d0 + dscp1)
5288         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5289         s2=(1+x(65))/(0.1d0 + dscp2)
5290         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5291         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5292      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5293 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5294 c     &   sumene4,
5295 c     &   dscp1,dscp2,sumene
5296 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5297         escloc = escloc + sumene
5298 c        write (2,*) "i",i," escloc",sumene,escloc
5299 #ifdef DEBUG
5300 C
5301 C This section to check the numerical derivatives of the energy of ith side
5302 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5303 C #define DEBUG in the code to turn it on.
5304 C
5305         write (2,*) "sumene               =",sumene
5306         aincr=1.0d-7
5307         xxsave=xx
5308         xx=xx+aincr
5309         write (2,*) xx,yy,zz
5310         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5311         de_dxx_num=(sumenep-sumene)/aincr
5312         xx=xxsave
5313         write (2,*) "xx+ sumene from enesc=",sumenep
5314         yysave=yy
5315         yy=yy+aincr
5316         write (2,*) xx,yy,zz
5317         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5318         de_dyy_num=(sumenep-sumene)/aincr
5319         yy=yysave
5320         write (2,*) "yy+ sumene from enesc=",sumenep
5321         zzsave=zz
5322         zz=zz+aincr
5323         write (2,*) xx,yy,zz
5324         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5325         de_dzz_num=(sumenep-sumene)/aincr
5326         zz=zzsave
5327         write (2,*) "zz+ sumene from enesc=",sumenep
5328         costsave=cost2tab(i+1)
5329         sintsave=sint2tab(i+1)
5330         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5331         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5332         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5333         de_dt_num=(sumenep-sumene)/aincr
5334         write (2,*) " t+ sumene from enesc=",sumenep
5335         cost2tab(i+1)=costsave
5336         sint2tab(i+1)=sintsave
5337 C End of diagnostics section.
5338 #endif
5339 C
5340 C Compute the gradient of esc
5341 C
5342         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5343         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5344         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5345         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5346         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5347         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5348         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5349         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5350         pom1=(sumene3*sint2tab(i+1)+sumene1)
5351      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5352         pom2=(sumene4*cost2tab(i+1)+sumene2)
5353      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5354         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5355         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5356      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5357      &  +x(40)*yy*zz
5358         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5359         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5360      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5361      &  +x(60)*yy*zz
5362         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5363      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5364      &        +(pom1+pom2)*pom_dx
5365 #ifdef DEBUG
5366         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5367 #endif
5368 C
5369         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5370         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5371      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5372      &  +x(40)*xx*zz
5373         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5374         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5375      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5376      &  +x(59)*zz**2 +x(60)*xx*zz
5377         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5378      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5379      &        +(pom1-pom2)*pom_dy
5380 #ifdef DEBUG
5381         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5382 #endif
5383 C
5384         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5385      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5386      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5387      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5388      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5389      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5390      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5391      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5392 #ifdef DEBUG
5393         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5394 #endif
5395 C
5396         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5397      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5398      &  +pom1*pom_dt1+pom2*pom_dt2
5399 #ifdef DEBUG
5400         write(2,*), "de_dt = ", de_dt,de_dt_num
5401 #endif
5402 c
5403 C
5404        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5405        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5406        cosfac2xx=cosfac2*xx
5407        sinfac2yy=sinfac2*yy
5408        do k = 1,3
5409          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5410      &      vbld_inv(i+1)
5411          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5412      &      vbld_inv(i)
5413          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5414          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5415 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5416 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5417 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5418 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5419          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5420          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5421          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5422          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5423          dZZ_Ci1(k)=0.0d0
5424          dZZ_Ci(k)=0.0d0
5425          do j=1,3
5426            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5427            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5428          enddo
5429
5430          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5431          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5432          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5433 c
5434          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5435          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5436        enddo
5437
5438        do k=1,3
5439          dXX_Ctab(k,i)=dXX_Ci(k)
5440          dXX_C1tab(k,i)=dXX_Ci1(k)
5441          dYY_Ctab(k,i)=dYY_Ci(k)
5442          dYY_C1tab(k,i)=dYY_Ci1(k)
5443          dZZ_Ctab(k,i)=dZZ_Ci(k)
5444          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5445          dXX_XYZtab(k,i)=dXX_XYZ(k)
5446          dYY_XYZtab(k,i)=dYY_XYZ(k)
5447          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5448        enddo
5449
5450        do k = 1,3
5451 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5452 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5453 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5454 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5455 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5456 c     &    dt_dci(k)
5457 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5458 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5459          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5460      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5461          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5462      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5463          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5464      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5465        enddo
5466 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5467 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5468
5469 C to check gradient call subroutine check_grad
5470
5471     1 continue
5472       enddo
5473       return
5474       end
5475 c------------------------------------------------------------------------------
5476       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5477       implicit none
5478       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5479      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5480       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5481      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5482      &   + x(10)*yy*zz
5483       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5484      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5485      & + x(20)*yy*zz
5486       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5487      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5488      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5489      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5490      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5491      &  +x(40)*xx*yy*zz
5492       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5493      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5494      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5495      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5496      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5497      &  +x(60)*xx*yy*zz
5498       dsc_i   = 0.743d0+x(61)
5499       dp2_i   = 1.9d0+x(62)
5500       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5501      &          *(xx*cost2+yy*sint2))
5502       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5503      &          *(xx*cost2-yy*sint2))
5504       s1=(1+x(63))/(0.1d0 + dscp1)
5505       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5506       s2=(1+x(65))/(0.1d0 + dscp2)
5507       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5508       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5509      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5510       enesc=sumene
5511       return
5512       end
5513 #endif
5514 c------------------------------------------------------------------------------
5515       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5516 C
5517 C This procedure calculates two-body contact function g(rij) and its derivative:
5518 C
5519 C           eps0ij                                     !       x < -1
5520 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5521 C            0                                         !       x > 1
5522 C
5523 C where x=(rij-r0ij)/delta
5524 C
5525 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5526 C
5527       implicit none
5528       double precision rij,r0ij,eps0ij,fcont,fprimcont
5529       double precision x,x2,x4,delta
5530 c     delta=0.02D0*r0ij
5531 c      delta=0.2D0*r0ij
5532       x=(rij-r0ij)/delta
5533       if (x.lt.-1.0D0) then
5534         fcont=eps0ij
5535         fprimcont=0.0D0
5536       else if (x.le.1.0D0) then
5537         x2=x*x
5538         x4=x2*x2
5539         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5540         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5541       else
5542         fcont=0.0D0
5543         fprimcont=0.0D0
5544       endif
5545       return
5546       end
5547 c------------------------------------------------------------------------------
5548       subroutine splinthet(theti,delta,ss,ssder)
5549       implicit real*8 (a-h,o-z)
5550       include 'DIMENSIONS'
5551       include 'COMMON.VAR'
5552       include 'COMMON.GEO'
5553       thetup=pi-delta
5554       thetlow=delta
5555       if (theti.gt.pipol) then
5556         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5557       else
5558         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5559         ssder=-ssder
5560       endif
5561       return
5562       end
5563 c------------------------------------------------------------------------------
5564       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5565       implicit none
5566       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5567       double precision ksi,ksi2,ksi3,a1,a2,a3
5568       a1=fprim0*delta/(f1-f0)
5569       a2=3.0d0-2.0d0*a1
5570       a3=a1-2.0d0
5571       ksi=(x-x0)/delta
5572       ksi2=ksi*ksi
5573       ksi3=ksi2*ksi
5574       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5575       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5576       return
5577       end
5578 c------------------------------------------------------------------------------
5579       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5580       implicit none
5581       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5582       double precision ksi,ksi2,ksi3,a1,a2,a3
5583       ksi=(x-x0)/delta
5584       ksi2=ksi*ksi
5585       ksi3=ksi2*ksi
5586       a1=fprim0x*delta
5587       a2=3*(f1x-f0x)-2*fprim0x*delta
5588       a3=fprim0x*delta-2*(f1x-f0x)
5589       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5590       return
5591       end
5592 C-----------------------------------------------------------------------------
5593 #ifdef CRYST_TOR
5594 C-----------------------------------------------------------------------------
5595       subroutine etor(etors,edihcnstr)
5596       implicit real*8 (a-h,o-z)
5597       include 'DIMENSIONS'
5598       include 'COMMON.VAR'
5599       include 'COMMON.GEO'
5600       include 'COMMON.LOCAL'
5601       include 'COMMON.TORSION'
5602       include 'COMMON.INTERACT'
5603       include 'COMMON.DERIV'
5604       include 'COMMON.CHAIN'
5605       include 'COMMON.NAMES'
5606       include 'COMMON.IOUNITS'
5607       include 'COMMON.FFIELD'
5608       include 'COMMON.TORCNSTR'
5609       include 'COMMON.CONTROL'
5610       logical lprn
5611 C Set lprn=.true. for debugging
5612       lprn=.false.
5613 c      lprn=.true.
5614       etors=0.0D0
5615       do i=iphi_start,iphi_end
5616       etors_ii=0.0D0
5617         itori=itortyp(itype(i-2))
5618         itori1=itortyp(itype(i-1))
5619         phii=phi(i)
5620         gloci=0.0D0
5621 C Proline-Proline pair is a special case...
5622         if (itori.eq.3 .and. itori1.eq.3) then
5623           if (phii.gt.-dwapi3) then
5624             cosphi=dcos(3*phii)
5625             fac=1.0D0/(1.0D0-cosphi)
5626             etorsi=v1(1,3,3)*fac
5627             etorsi=etorsi+etorsi
5628             etors=etors+etorsi-v1(1,3,3)
5629             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5630             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5631           endif
5632           do j=1,3
5633             v1ij=v1(j+1,itori,itori1)
5634             v2ij=v2(j+1,itori,itori1)
5635             cosphi=dcos(j*phii)
5636             sinphi=dsin(j*phii)
5637             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5638             if (energy_dec) etors_ii=etors_ii+
5639      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5640             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5641           enddo
5642         else
5643           do j=1,nterm_old
5644             v1ij=v1(j,itori,itori1)
5645             v2ij=v2(j,itori,itori1)
5646             cosphi=dcos(j*phii)
5647             sinphi=dsin(j*phii)
5648             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5649             if (energy_dec) etors_ii=etors_ii+
5650      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5651             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5652           enddo
5653         endif
5654         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5655      &        'etor',i,etors_ii
5656         if (lprn)
5657      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5658      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5659      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5660         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5661 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5662       enddo
5663 ! 6/20/98 - dihedral angle constraints
5664       edihcnstr=0.0d0
5665       do i=1,ndih_constr
5666         itori=idih_constr(i)
5667         phii=phi(itori)
5668         difi=phii-phi0(i)
5669         if (difi.gt.drange(i)) then
5670           difi=difi-drange(i)
5671           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5672           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5673         else if (difi.lt.-drange(i)) then
5674           difi=difi+drange(i)
5675           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5676           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5677         endif
5678 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5679 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5680       enddo
5681 !      write (iout,*) 'edihcnstr',edihcnstr
5682       return
5683       end
5684 c------------------------------------------------------------------------------
5685       subroutine etor_d(etors_d)
5686       etors_d=0.0d0
5687       return
5688       end
5689 c----------------------------------------------------------------------------
5690 #else
5691       subroutine etor(etors,edihcnstr)
5692       implicit real*8 (a-h,o-z)
5693       include 'DIMENSIONS'
5694       include 'COMMON.VAR'
5695       include 'COMMON.GEO'
5696       include 'COMMON.LOCAL'
5697       include 'COMMON.TORSION'
5698       include 'COMMON.INTERACT'
5699       include 'COMMON.DERIV'
5700       include 'COMMON.CHAIN'
5701       include 'COMMON.NAMES'
5702       include 'COMMON.IOUNITS'
5703       include 'COMMON.FFIELD'
5704       include 'COMMON.TORCNSTR'
5705       include 'COMMON.CONTROL'
5706       logical lprn
5707 C Set lprn=.true. for debugging
5708       lprn=.false.
5709 c     lprn=.true.
5710       etors=0.0D0
5711       do i=iphi_start,iphi_end
5712       etors_ii=0.0D0
5713         itori=itortyp(itype(i-2))
5714         itori1=itortyp(itype(i-1))
5715         phii=phi(i)
5716         gloci=0.0D0
5717 C Regular cosine and sine terms
5718         do j=1,nterm(itori,itori1)
5719           v1ij=v1(j,itori,itori1)
5720           v2ij=v2(j,itori,itori1)
5721           cosphi=dcos(j*phii)
5722           sinphi=dsin(j*phii)
5723           etors=etors+v1ij*cosphi+v2ij*sinphi
5724           if (energy_dec) etors_ii=etors_ii+
5725      &                v1ij*cosphi+v2ij*sinphi
5726           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5727         enddo
5728 C Lorentz terms
5729 C                         v1
5730 C  E = SUM ----------------------------------- - v1
5731 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5732 C
5733         cosphi=dcos(0.5d0*phii)
5734         sinphi=dsin(0.5d0*phii)
5735         do j=1,nlor(itori,itori1)
5736           vl1ij=vlor1(j,itori,itori1)
5737           vl2ij=vlor2(j,itori,itori1)
5738           vl3ij=vlor3(j,itori,itori1)
5739           pom=vl2ij*cosphi+vl3ij*sinphi
5740           pom1=1.0d0/(pom*pom+1.0d0)
5741           etors=etors+vl1ij*pom1
5742           if (energy_dec) etors_ii=etors_ii+
5743      &                vl1ij*pom1
5744           pom=-pom*pom1*pom1
5745           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5746         enddo
5747 C Subtract the constant term
5748         etors=etors-v0(itori,itori1)
5749           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5750      &         'etor',i,etors_ii-v0(itori,itori1)
5751         if (lprn)
5752      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5753      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5754      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5755         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5756 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5757       enddo
5758 ! 6/20/98 - dihedral angle constraints
5759       edihcnstr=0.0d0
5760 c      do i=1,ndih_constr
5761       do i=idihconstr_start,idihconstr_end
5762         itori=idih_constr(i)
5763         phii=phi(itori)
5764         difi=pinorm(phii-phi0(i))
5765         if (difi.gt.drange(i)) then
5766           difi=difi-drange(i)
5767           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5768           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5769         else if (difi.lt.-drange(i)) then
5770           difi=difi+drange(i)
5771           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5772           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5773         else
5774           difi=0.0
5775         endif
5776 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5777 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5778 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5779       enddo
5780 cd       write (iout,*) 'edihcnstr',edihcnstr
5781       return
5782       end
5783 c----------------------------------------------------------------------------
5784       subroutine etor_d(etors_d)
5785 C 6/23/01 Compute double torsional energy
5786       implicit real*8 (a-h,o-z)
5787       include 'DIMENSIONS'
5788       include 'COMMON.VAR'
5789       include 'COMMON.GEO'
5790       include 'COMMON.LOCAL'
5791       include 'COMMON.TORSION'
5792       include 'COMMON.INTERACT'
5793       include 'COMMON.DERIV'
5794       include 'COMMON.CHAIN'
5795       include 'COMMON.NAMES'
5796       include 'COMMON.IOUNITS'
5797       include 'COMMON.FFIELD'
5798       include 'COMMON.TORCNSTR'
5799       include 'COMMON.CONTROL'
5800       logical lprn
5801 C Set lprn=.true. for debugging
5802       lprn=.false.
5803 c     lprn=.true.
5804       etors_d=0.0D0
5805       do i=iphid_start,iphid_end
5806         etors_d_ii=0.0D0
5807         itori=itortyp(itype(i-2))
5808         itori1=itortyp(itype(i-1))
5809         itori2=itortyp(itype(i))
5810         phii=phi(i)
5811         phii1=phi(i+1)
5812         gloci1=0.0D0
5813         gloci2=0.0D0
5814 C Regular cosine and sine terms
5815         do j=1,ntermd_1(itori,itori1,itori2)
5816           v1cij=v1c(1,j,itori,itori1,itori2)
5817           v1sij=v1s(1,j,itori,itori1,itori2)
5818           v2cij=v1c(2,j,itori,itori1,itori2)
5819           v2sij=v1s(2,j,itori,itori1,itori2)
5820           cosphi1=dcos(j*phii)
5821           sinphi1=dsin(j*phii)
5822           cosphi2=dcos(j*phii1)
5823           sinphi2=dsin(j*phii1)
5824           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5825      &     v2cij*cosphi2+v2sij*sinphi2
5826           if (energy_dec) etors_d_ii=etors_d_ii+
5827      &     v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
5828           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5829           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5830         enddo
5831         do k=2,ntermd_2(itori,itori1,itori2)
5832           do l=1,k-1
5833             v1cdij = v2c(k,l,itori,itori1,itori2)
5834             v2cdij = v2c(l,k,itori,itori1,itori2)
5835             v1sdij = v2s(k,l,itori,itori1,itori2)
5836             v2sdij = v2s(l,k,itori,itori1,itori2)
5837             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5838             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5839             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5840             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5841             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5842      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5843             if (energy_dec) etors_d_ii=etors_d_ii+
5844      &        v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5845      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5846             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5847      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5848             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5849      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5850           enddo
5851         enddo
5852         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5853      &        'etor_d',i,etors_d_ii
5854         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5855         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5856       enddo
5857       return
5858       end
5859 #endif
5860 c------------------------------------------------------------------------------
5861       subroutine eback_sc_corr(esccor)
5862 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5863 c        conformational states; temporarily implemented as differences
5864 c        between UNRES torsional potentials (dependent on three types of
5865 c        residues) and the torsional potentials dependent on all 20 types
5866 c        of residues computed from AM1  energy surfaces of terminally-blocked
5867 c        amino-acid residues.
5868       implicit real*8 (a-h,o-z)
5869       include 'DIMENSIONS'
5870       include 'COMMON.VAR'
5871       include 'COMMON.GEO'
5872       include 'COMMON.LOCAL'
5873       include 'COMMON.TORSION'
5874       include 'COMMON.SCCOR'
5875       include 'COMMON.INTERACT'
5876       include 'COMMON.DERIV'
5877       include 'COMMON.CHAIN'
5878       include 'COMMON.NAMES'
5879       include 'COMMON.IOUNITS'
5880       include 'COMMON.FFIELD'
5881       include 'COMMON.CONTROL'
5882       logical lprn
5883 C Set lprn=.true. for debugging
5884 C Set lprn=.true. for debugging
5885       lprn=.false.
5886 c      lprn=.true.
5887 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
5888       esccor=0.0D0
5889       do i=itau_start,itau_end
5890         esccor_ii=0.0D0
5891         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5892         isccori=isccortyp(itype(i-2))
5893         isccori1=isccortyp(itype(i-1))
5894 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
5895         phii=phi(i)
5896
5897 cccc  Added 9 May 2012
5898 cc Tauangle is torsional engle depending on the value of first digit
5899 c(see comment below)
5900 cc Omicron is flat angle depending on the value of first digit
5901 c(see comment below)
5902 C        print *,i,tauangle(1,i)
5903
5904         do intertyp=1,3 !intertyp
5905 cc Added 09 May 2012 (Adasko)
5906 cc  Intertyp means interaction type of backbone mainchain correlation:
5907 c   1 = SC...Ca...Ca...Ca
5908 c   2 = Ca...Ca...Ca...SC
5909 c   3 = SC...Ca...Ca...SCi
5910         gloci=0.0D0
5911         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5912      &      (itype(i-1).eq.10).or.(itype(i-2).eq.21).or.
5913      &      (itype(i-1).eq.21)))
5914      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5915      &     .or.(itype(i-2).eq.21)))
5916      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5917      &      (itype(i-1).eq.21)))) cycle
5918         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle
5919         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21))
5920      & cycle
5921         do j=1,nterm_sccor(isccori,isccori1)
5922           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5923           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5924           cosphi=dcos(j*tauangle(intertyp,i))
5925           sinphi=dsin(j*tauangle(intertyp,i))
5926           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5927           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5928         enddo
5929 c      write (iout,*) "EBACK_SC_COR",i,esccor,intertyp
5930         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5931 c        write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
5932 c     &gloc_sc(intertyp,i-3,icg)
5933         if (lprn)
5934      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5935      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5936      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
5937      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
5938         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5939        enddo !intertyp
5940       enddo
5941 c        do i=1,nres
5942 c        write (iout,*) "W@T@F",  gloc_sc(1,i,icg),gloc_sc(2,i,icg),
5943 c     &   gloc_sc(3,i,icg)
5944 c        enddo
5945       return
5946       end
5947 c----------------------------------------------------------------------------
5948       subroutine multibody(ecorr)
5949 C This subroutine calculates multi-body contributions to energy following
5950 C the idea of Skolnick et al. If side chains I and J make a contact and
5951 C at the same time side chains I+1 and J+1 make a contact, an extra
5952 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5953       implicit real*8 (a-h,o-z)
5954       include 'DIMENSIONS'
5955       include 'COMMON.IOUNITS'
5956       include 'COMMON.DERIV'
5957       include 'COMMON.INTERACT'
5958       include 'COMMON.CONTACTS'
5959       double precision gx(3),gx1(3)
5960       logical lprn
5961
5962 C Set lprn=.true. for debugging
5963       lprn=.false.
5964
5965       if (lprn) then
5966         write (iout,'(a)') 'Contact function values:'
5967         do i=nnt,nct-2
5968           write (iout,'(i2,20(1x,i2,f10.5))')
5969      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5970         enddo
5971       endif
5972       ecorr=0.0D0
5973       do i=nnt,nct
5974         do j=1,3
5975           gradcorr(j,i)=0.0D0
5976           gradxorr(j,i)=0.0D0
5977         enddo
5978       enddo
5979       do i=nnt,nct-2
5980
5981         DO ISHIFT = 3,4
5982
5983         i1=i+ishift
5984         num_conti=num_cont(i)
5985         num_conti1=num_cont(i1)
5986         do jj=1,num_conti
5987           j=jcont(jj,i)
5988           do kk=1,num_conti1
5989             j1=jcont(kk,i1)
5990             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5991 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5992 cd   &                   ' ishift=',ishift
5993 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5994 C The system gains extra energy.
5995               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5996             endif   ! j1==j+-ishift
5997           enddo     ! kk
5998         enddo       ! jj
5999
6000         ENDDO ! ISHIFT
6001
6002       enddo         ! i
6003       return
6004       end
6005 c------------------------------------------------------------------------------
6006       double precision function esccorr(i,j,k,l,jj,kk)
6007       implicit real*8 (a-h,o-z)
6008       include 'DIMENSIONS'
6009       include 'COMMON.IOUNITS'
6010       include 'COMMON.DERIV'
6011       include 'COMMON.INTERACT'
6012       include 'COMMON.CONTACTS'
6013       double precision gx(3),gx1(3)
6014       logical lprn
6015       lprn=.false.
6016       eij=facont(jj,i)
6017       ekl=facont(kk,k)
6018 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6019 C Calculate the multi-body contribution to energy.
6020 C Calculate multi-body contributions to the gradient.
6021 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6022 cd   & k,l,(gacont(m,kk,k),m=1,3)
6023       do m=1,3
6024         gx(m) =ekl*gacont(m,jj,i)
6025         gx1(m)=eij*gacont(m,kk,k)
6026         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6027         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6028         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6029         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6030       enddo
6031       do m=i,j-1
6032         do ll=1,3
6033           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6034         enddo
6035       enddo
6036       do m=k,l-1
6037         do ll=1,3
6038           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6039         enddo
6040       enddo
6041       esccorr=-eij*ekl
6042       return
6043       end
6044 c------------------------------------------------------------------------------
6045       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6046 C This subroutine calculates multi-body contributions to hydrogen-bonding
6047       implicit real*8 (a-h,o-z)
6048       include 'DIMENSIONS'
6049       include 'COMMON.IOUNITS'
6050 #ifdef MPI
6051       include "mpif.h"
6052       parameter (max_cont=maxconts)
6053       parameter (max_dim=26)
6054       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6055       double precision zapas(max_dim,maxconts,max_fg_procs),
6056      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6057       common /przechowalnia/ zapas
6058       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6059      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6060 #endif
6061       include 'COMMON.SETUP'
6062       include 'COMMON.FFIELD'
6063       include 'COMMON.DERIV'
6064       include 'COMMON.INTERACT'
6065       include 'COMMON.CONTACTS'
6066       include 'COMMON.CONTROL'
6067       include 'COMMON.LOCAL'
6068       double precision gx(3),gx1(3),time00
6069       logical lprn,ldone
6070
6071 C Set lprn=.true. for debugging
6072       lprn=.false.
6073 #ifdef MPI
6074       n_corr=0
6075       n_corr1=0
6076       if (nfgtasks.le.1) goto 30
6077       if (lprn) then
6078         write (iout,'(a)') 'Contact function values before RECEIVE:'
6079         do i=nnt,nct-2
6080           write (iout,'(2i3,50(1x,i2,f5.2))')
6081      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6082      &    j=1,num_cont_hb(i))
6083         enddo
6084       endif
6085       call flush(iout)
6086       do i=1,ntask_cont_from
6087         ncont_recv(i)=0
6088       enddo
6089       do i=1,ntask_cont_to
6090         ncont_sent(i)=0
6091       enddo
6092 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6093 c     & ntask_cont_to
6094 C Make the list of contacts to send to send to other procesors
6095 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6096 c      call flush(iout)
6097       do i=iturn3_start,iturn3_end
6098 c        write (iout,*) "make contact list turn3",i," num_cont",
6099 c     &    num_cont_hb(i)
6100         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6101       enddo
6102       do i=iturn4_start,iturn4_end
6103 c        write (iout,*) "make contact list turn4",i," num_cont",
6104 c     &   num_cont_hb(i)
6105         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6106       enddo
6107       do ii=1,nat_sent
6108         i=iat_sent(ii)
6109 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6110 c     &    num_cont_hb(i)
6111         do j=1,num_cont_hb(i)
6112         do k=1,4
6113           jjc=jcont_hb(j,i)
6114           iproc=iint_sent_local(k,jjc,ii)
6115 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6116           if (iproc.gt.0) then
6117             ncont_sent(iproc)=ncont_sent(iproc)+1
6118             nn=ncont_sent(iproc)
6119             zapas(1,nn,iproc)=i
6120             zapas(2,nn,iproc)=jjc
6121             zapas(3,nn,iproc)=facont_hb(j,i)
6122             zapas(4,nn,iproc)=ees0p(j,i)
6123             zapas(5,nn,iproc)=ees0m(j,i)
6124             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6125             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6126             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6127             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6128             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6129             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6130             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6131             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6132             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6133             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6134             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6135             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6136             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6137             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6138             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6139             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6140             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6141             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6142             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6143             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6144             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6145           endif
6146         enddo
6147         enddo
6148       enddo
6149       if (lprn) then
6150       write (iout,*)
6151      &  "Numbers of contacts to be sent to other processors",
6152      &  (ncont_sent(i),i=1,ntask_cont_to)
6153       write (iout,*) "Contacts sent"
6154       do ii=1,ntask_cont_to
6155         nn=ncont_sent(ii)
6156         iproc=itask_cont_to(ii)
6157         write (iout,*) nn," contacts to processor",iproc,
6158      &   " of CONT_TO_COMM group"
6159         do i=1,nn
6160           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6161         enddo
6162       enddo
6163       call flush(iout)
6164       endif
6165       CorrelType=477
6166       CorrelID=fg_rank+1
6167       CorrelType1=478
6168       CorrelID1=nfgtasks+fg_rank+1
6169       ireq=0
6170 C Receive the numbers of needed contacts from other processors
6171       do ii=1,ntask_cont_from
6172         iproc=itask_cont_from(ii)
6173         ireq=ireq+1
6174         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6175      &    FG_COMM,req(ireq),IERR)
6176       enddo
6177 c      write (iout,*) "IRECV ended"
6178 c      call flush(iout)
6179 C Send the number of contacts needed by other processors
6180       do ii=1,ntask_cont_to
6181         iproc=itask_cont_to(ii)
6182         ireq=ireq+1
6183         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6184      &    FG_COMM,req(ireq),IERR)
6185       enddo
6186 c      write (iout,*) "ISEND ended"
6187 c      write (iout,*) "number of requests (nn)",ireq
6188       call flush(iout)
6189       if (ireq.gt.0)
6190      &  call MPI_Waitall(ireq,req,status_array,ierr)
6191 c      write (iout,*)
6192 c     &  "Numbers of contacts to be received from other processors",
6193 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6194 c      call flush(iout)
6195 C Receive contacts
6196       ireq=0
6197       do ii=1,ntask_cont_from
6198         iproc=itask_cont_from(ii)
6199         nn=ncont_recv(ii)
6200 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6201 c     &   " of CONT_TO_COMM group"
6202         call flush(iout)
6203         if (nn.gt.0) then
6204           ireq=ireq+1
6205           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6206      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6207 c          write (iout,*) "ireq,req",ireq,req(ireq)
6208         endif
6209       enddo
6210 C Send the contacts to processors that need them
6211       do ii=1,ntask_cont_to
6212         iproc=itask_cont_to(ii)
6213         nn=ncont_sent(ii)
6214 c        write (iout,*) nn," contacts to processor",iproc,
6215 c     &   " of CONT_TO_COMM group"
6216         if (nn.gt.0) then
6217           ireq=ireq+1
6218           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6219      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6220 c          write (iout,*) "ireq,req",ireq,req(ireq)
6221 c          do i=1,nn
6222 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6223 c          enddo
6224         endif
6225       enddo
6226 c      write (iout,*) "number of requests (contacts)",ireq
6227 c      write (iout,*) "req",(req(i),i=1,4)
6228 c      call flush(iout)
6229       if (ireq.gt.0)
6230      & call MPI_Waitall(ireq,req,status_array,ierr)
6231       do iii=1,ntask_cont_from
6232         iproc=itask_cont_from(iii)
6233         nn=ncont_recv(iii)
6234         if (lprn) then
6235         write (iout,*) "Received",nn," contacts from processor",iproc,
6236      &   " of CONT_FROM_COMM group"
6237         call flush(iout)
6238         do i=1,nn
6239           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6240         enddo
6241         call flush(iout)
6242         endif
6243         do i=1,nn
6244           ii=zapas_recv(1,i,iii)
6245 c Flag the received contacts to prevent double-counting
6246           jj=-zapas_recv(2,i,iii)
6247 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6248 c          call flush(iout)
6249           nnn=num_cont_hb(ii)+1
6250           num_cont_hb(ii)=nnn
6251           jcont_hb(nnn,ii)=jj
6252           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6253           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6254           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6255           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6256           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6257           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6258           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6259           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6260           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6261           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6262           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6263           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6264           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6265           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6266           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6267           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6268           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6269           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6270           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6271           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6272           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6273           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6274           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6275           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6276         enddo
6277       enddo
6278       call flush(iout)
6279       if (lprn) then
6280         write (iout,'(a)') 'Contact function values after receive:'
6281         do i=nnt,nct-2
6282           write (iout,'(2i3,50(1x,i3,f5.2))')
6283      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6284      &    j=1,num_cont_hb(i))
6285         enddo
6286         call flush(iout)
6287       endif
6288    30 continue
6289 #endif
6290       if (lprn) then
6291         write (iout,'(a)') 'Contact function values:'
6292         do i=nnt,nct-2
6293           write (iout,'(2i3,50(1x,i3,f5.2))')
6294      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6295      &    j=1,num_cont_hb(i))
6296         enddo
6297       endif
6298       ecorr=0.0D0
6299 C Remove the loop below after debugging !!!
6300       do i=nnt,nct
6301         do j=1,3
6302           gradcorr(j,i)=0.0D0
6303           gradxorr(j,i)=0.0D0
6304         enddo
6305       enddo
6306 C Calculate the local-electrostatic correlation terms
6307       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6308         i1=i+1
6309         num_conti=num_cont_hb(i)
6310         num_conti1=num_cont_hb(i+1)
6311         do jj=1,num_conti
6312           j=jcont_hb(jj,i)
6313           jp=iabs(j)
6314           do kk=1,num_conti1
6315             j1=jcont_hb(kk,i1)
6316             jp1=iabs(j1)
6317 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6318 c     &         ' jj=',jj,' kk=',kk
6319             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6320      &          .or. j.lt.0 .and. j1.gt.0) .and.
6321      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6322 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6323 C The system gains extra energy.
6324               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6325               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6326      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6327               n_corr=n_corr+1
6328             else if (j1.eq.j) then
6329 C Contacts I-J and I-(J+1) occur simultaneously.
6330 C The system loses extra energy.
6331 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6332             endif
6333           enddo ! kk
6334           do kk=1,num_conti
6335             j1=jcont_hb(kk,i)
6336 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6337 c    &         ' jj=',jj,' kk=',kk
6338             if (j1.eq.j+1) then
6339 C Contacts I-J and (I+1)-J occur simultaneously.
6340 C The system loses extra energy.
6341 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6342             endif ! j1==j+1
6343           enddo ! kk
6344         enddo ! jj
6345       enddo ! i
6346       return
6347       end
6348 c------------------------------------------------------------------------------
6349       subroutine add_hb_contact(ii,jj,itask)
6350       implicit real*8 (a-h,o-z)
6351       include "DIMENSIONS"
6352       include "COMMON.IOUNITS"
6353       integer max_cont
6354       integer max_dim
6355       parameter (max_cont=maxconts)
6356       parameter (max_dim=26)
6357       include "COMMON.CONTACTS"
6358       double precision zapas(max_dim,maxconts,max_fg_procs),
6359      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6360       common /przechowalnia/ zapas
6361       integer i,j,ii,jj,iproc,itask(4),nn
6362 c      write (iout,*) "itask",itask
6363       do i=1,2
6364         iproc=itask(i)
6365         if (iproc.gt.0) then
6366           do j=1,num_cont_hb(ii)
6367             jjc=jcont_hb(j,ii)
6368 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6369             if (jjc.eq.jj) then
6370               ncont_sent(iproc)=ncont_sent(iproc)+1
6371               nn=ncont_sent(iproc)
6372               zapas(1,nn,iproc)=ii
6373               zapas(2,nn,iproc)=jjc
6374               zapas(3,nn,iproc)=facont_hb(j,ii)
6375               zapas(4,nn,iproc)=ees0p(j,ii)
6376               zapas(5,nn,iproc)=ees0m(j,ii)
6377               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6378               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6379               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6380               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6381               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6382               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6383               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6384               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6385               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6386               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6387               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6388               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6389               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6390               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6391               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6392               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6393               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6394               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6395               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6396               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6397               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6398               exit
6399             endif
6400           enddo
6401         endif
6402       enddo
6403       return
6404       end
6405 c------------------------------------------------------------------------------
6406       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6407      &  n_corr1)
6408 C This subroutine calculates multi-body contributions to hydrogen-bonding
6409       implicit real*8 (a-h,o-z)
6410       include 'DIMENSIONS'
6411       include 'COMMON.IOUNITS'
6412 #ifdef MPI
6413       include "mpif.h"
6414       parameter (max_cont=maxconts)
6415       parameter (max_dim=70)
6416       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6417       double precision zapas(max_dim,maxconts,max_fg_procs),
6418      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6419       common /przechowalnia/ zapas
6420       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6421      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6422 #endif
6423       include 'COMMON.SETUP'
6424       include 'COMMON.FFIELD'
6425       include 'COMMON.DERIV'
6426       include 'COMMON.LOCAL'
6427       include 'COMMON.INTERACT'
6428       include 'COMMON.CONTACTS'
6429       include 'COMMON.CHAIN'
6430       include 'COMMON.CONTROL'
6431       double precision gx(3),gx1(3)
6432       integer num_cont_hb_old(maxres)
6433       logical lprn,ldone
6434       double precision eello4,eello5,eelo6,eello_turn6
6435       external eello4,eello5,eello6,eello_turn6
6436 C Set lprn=.true. for debugging
6437       lprn=.false.
6438       eturn6=0.0d0
6439 #ifdef MPI
6440       do i=1,nres
6441         num_cont_hb_old(i)=num_cont_hb(i)
6442       enddo
6443       n_corr=0
6444       n_corr1=0
6445       if (nfgtasks.le.1) goto 30
6446       if (lprn) then
6447         write (iout,'(a)') 'Contact function values before RECEIVE:'
6448         do i=nnt,nct-2
6449           write (iout,'(2i3,50(1x,i2,f5.2))')
6450      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6451      &    j=1,num_cont_hb(i))
6452         enddo
6453       endif
6454       call flush(iout)
6455       do i=1,ntask_cont_from
6456         ncont_recv(i)=0
6457       enddo
6458       do i=1,ntask_cont_to
6459         ncont_sent(i)=0
6460       enddo
6461 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6462 c     & ntask_cont_to
6463 C Make the list of contacts to send to send to other procesors
6464       do i=iturn3_start,iturn3_end
6465 c        write (iout,*) "make contact list turn3",i," num_cont",
6466 c     &    num_cont_hb(i)
6467         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6468       enddo
6469       do i=iturn4_start,iturn4_end
6470 c        write (iout,*) "make contact list turn4",i," num_cont",
6471 c     &   num_cont_hb(i)
6472         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6473       enddo
6474       do ii=1,nat_sent
6475         i=iat_sent(ii)
6476 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6477 c     &    num_cont_hb(i)
6478         do j=1,num_cont_hb(i)
6479         do k=1,4
6480           jjc=jcont_hb(j,i)
6481           iproc=iint_sent_local(k,jjc,ii)
6482 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6483           if (iproc.ne.0) then
6484             ncont_sent(iproc)=ncont_sent(iproc)+1
6485             nn=ncont_sent(iproc)
6486             zapas(1,nn,iproc)=i
6487             zapas(2,nn,iproc)=jjc
6488             zapas(3,nn,iproc)=d_cont(j,i)
6489             ind=3
6490             do kk=1,3
6491               ind=ind+1
6492               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6493             enddo
6494             do kk=1,2
6495               do ll=1,2
6496                 ind=ind+1
6497                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6498               enddo
6499             enddo
6500             do jj=1,5
6501               do kk=1,3
6502                 do ll=1,2
6503                   do mm=1,2
6504                     ind=ind+1
6505                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6506                   enddo
6507                 enddo
6508               enddo
6509             enddo
6510           endif
6511         enddo
6512         enddo
6513       enddo
6514       if (lprn) then
6515       write (iout,*)
6516      &  "Numbers of contacts to be sent to other processors",
6517      &  (ncont_sent(i),i=1,ntask_cont_to)
6518       write (iout,*) "Contacts sent"
6519       do ii=1,ntask_cont_to
6520         nn=ncont_sent(ii)
6521         iproc=itask_cont_to(ii)
6522         write (iout,*) nn," contacts to processor",iproc,
6523      &   " of CONT_TO_COMM group"
6524         do i=1,nn
6525           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6526         enddo
6527       enddo
6528       call flush(iout)
6529       endif
6530       CorrelType=477
6531       CorrelID=fg_rank+1
6532       CorrelType1=478
6533       CorrelID1=nfgtasks+fg_rank+1
6534       ireq=0
6535 C Receive the numbers of needed contacts from other processors
6536       do ii=1,ntask_cont_from
6537         iproc=itask_cont_from(ii)
6538         ireq=ireq+1
6539         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6540      &    FG_COMM,req(ireq),IERR)
6541       enddo
6542 c      write (iout,*) "IRECV ended"
6543 c      call flush(iout)
6544 C Send the number of contacts needed by other processors
6545       do ii=1,ntask_cont_to
6546         iproc=itask_cont_to(ii)
6547         ireq=ireq+1
6548         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6549      &    FG_COMM,req(ireq),IERR)
6550       enddo
6551 c      write (iout,*) "ISEND ended"
6552 c      write (iout,*) "number of requests (nn)",ireq
6553       call flush(iout)
6554       if (ireq.gt.0)
6555      &  call MPI_Waitall(ireq,req,status_array,ierr)
6556 c      write (iout,*)
6557 c     &  "Numbers of contacts to be received from other processors",
6558 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6559 c      call flush(iout)
6560 C Receive contacts
6561       ireq=0
6562       do ii=1,ntask_cont_from
6563         iproc=itask_cont_from(ii)
6564         nn=ncont_recv(ii)
6565 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6566 c     &   " of CONT_TO_COMM group"
6567         call flush(iout)
6568         if (nn.gt.0) then
6569           ireq=ireq+1
6570           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6571      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6572 c          write (iout,*) "ireq,req",ireq,req(ireq)
6573         endif
6574       enddo
6575 C Send the contacts to processors that need them
6576       do ii=1,ntask_cont_to
6577         iproc=itask_cont_to(ii)
6578         nn=ncont_sent(ii)
6579 c        write (iout,*) nn," contacts to processor",iproc,
6580 c     &   " of CONT_TO_COMM group"
6581         if (nn.gt.0) then
6582           ireq=ireq+1
6583           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6584      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6585 c          write (iout,*) "ireq,req",ireq,req(ireq)
6586 c          do i=1,nn
6587 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6588 c          enddo
6589         endif
6590       enddo
6591 c      write (iout,*) "number of requests (contacts)",ireq
6592 c      write (iout,*) "req",(req(i),i=1,4)
6593 c      call flush(iout)
6594       if (ireq.gt.0)
6595      & call MPI_Waitall(ireq,req,status_array,ierr)
6596       do iii=1,ntask_cont_from
6597         iproc=itask_cont_from(iii)
6598         nn=ncont_recv(iii)
6599         if (lprn) then
6600         write (iout,*) "Received",nn," contacts from processor",iproc,
6601      &   " of CONT_FROM_COMM group"
6602         call flush(iout)
6603         do i=1,nn
6604           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6605         enddo
6606         call flush(iout)
6607         endif
6608         do i=1,nn
6609           ii=zapas_recv(1,i,iii)
6610 c Flag the received contacts to prevent double-counting
6611           jj=-zapas_recv(2,i,iii)
6612 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6613 c          call flush(iout)
6614           nnn=num_cont_hb(ii)+1
6615           num_cont_hb(ii)=nnn
6616           jcont_hb(nnn,ii)=jj
6617           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6618           ind=3
6619           do kk=1,3
6620             ind=ind+1
6621             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6622           enddo
6623           do kk=1,2
6624             do ll=1,2
6625               ind=ind+1
6626               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6627             enddo
6628           enddo
6629           do jj=1,5
6630             do kk=1,3
6631               do ll=1,2
6632                 do mm=1,2
6633                   ind=ind+1
6634                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6635                 enddo
6636               enddo
6637             enddo
6638           enddo
6639         enddo
6640       enddo
6641       call flush(iout)
6642       if (lprn) then
6643         write (iout,'(a)') 'Contact function values after receive:'
6644         do i=nnt,nct-2
6645           write (iout,'(2i3,50(1x,i3,5f6.3))')
6646      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6647      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6648         enddo
6649         call flush(iout)
6650       endif
6651    30 continue
6652 #endif
6653       if (lprn) then
6654         write (iout,'(a)') 'Contact function values:'
6655         do i=nnt,nct-2
6656           write (iout,'(2i3,50(1x,i2,5f6.3))')
6657      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6658      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6659         enddo
6660       endif
6661       ecorr=0.0D0
6662       ecorr5=0.0d0
6663       ecorr6=0.0d0
6664 C Remove the loop below after debugging !!!
6665       do i=nnt,nct
6666         do j=1,3
6667           gradcorr(j,i)=0.0D0
6668           gradxorr(j,i)=0.0D0
6669         enddo
6670       enddo
6671 C Calculate the dipole-dipole interaction energies
6672       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6673       do i=iatel_s,iatel_e+1
6674         num_conti=num_cont_hb(i)
6675         do jj=1,num_conti
6676           j=jcont_hb(jj,i)
6677 #ifdef MOMENT
6678           call dipole(i,j,jj)
6679 #endif
6680         enddo
6681       enddo
6682       endif
6683 C Calculate the local-electrostatic correlation terms
6684 c                write (iout,*) "gradcorr5 in eello5 before loop"
6685 c                do iii=1,nres
6686 c                  write (iout,'(i5,3f10.5)')
6687 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6688 c                enddo
6689       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6690 c        write (iout,*) "corr loop i",i
6691         i1=i+1
6692         num_conti=num_cont_hb(i)
6693         num_conti1=num_cont_hb(i+1)
6694         do jj=1,num_conti
6695           j=jcont_hb(jj,i)
6696           jp=iabs(j)
6697           do kk=1,num_conti1
6698             j1=jcont_hb(kk,i1)
6699             jp1=iabs(j1)
6700 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6701 c     &         ' jj=',jj,' kk=',kk
6702 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6703             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6704      &          .or. j.lt.0 .and. j1.gt.0) .and.
6705      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6706 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6707 C The system gains extra energy.
6708               n_corr=n_corr+1
6709               sqd1=dsqrt(d_cont(jj,i))
6710               sqd2=dsqrt(d_cont(kk,i1))
6711               sred_geom = sqd1*sqd2
6712               IF (sred_geom.lt.cutoff_corr) THEN
6713                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6714      &            ekont,fprimcont)
6715 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6716 cd     &         ' jj=',jj,' kk=',kk
6717                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6718                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6719                 do l=1,3
6720                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6721                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6722                 enddo
6723                 n_corr1=n_corr1+1
6724 cd               write (iout,*) 'sred_geom=',sred_geom,
6725 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6726 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6727 cd               write (iout,*) "g_contij",g_contij
6728 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6729 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6730                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6731                 if (wcorr4.gt.0.0d0)
6732      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6733                   if (energy_dec.and.wcorr4.gt.0.0d0)
6734      1                 write (iout,'(a6,4i5,0pf7.3)')
6735      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6736 c                write (iout,*) "gradcorr5 before eello5"
6737 c                do iii=1,nres
6738 c                  write (iout,'(i5,3f10.5)')
6739 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6740 c                enddo
6741                 if (wcorr5.gt.0.0d0)
6742      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6743 c                write (iout,*) "gradcorr5 after eello5"
6744 c                do iii=1,nres
6745 c                  write (iout,'(i5,3f10.5)')
6746 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6747 c                enddo
6748                   if (energy_dec.and.wcorr5.gt.0.0d0)
6749      1                 write (iout,'(a6,4i5,0pf7.3)')
6750      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6751 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6752 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6753                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6754      &               .or. wturn6.eq.0.0d0))then
6755 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6756                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6757                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6758      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6759 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6760 cd     &            'ecorr6=',ecorr6
6761 cd                write (iout,'(4e15.5)') sred_geom,
6762 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6763 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6764 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6765                 else if (wturn6.gt.0.0d0
6766      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6767 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6768                   eturn6=eturn6+eello_turn6(i,jj,kk)
6769                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6770      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6771 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6772                 endif
6773               ENDIF
6774 1111          continue
6775             endif
6776           enddo ! kk
6777         enddo ! jj
6778       enddo ! i
6779       do i=1,nres
6780         num_cont_hb(i)=num_cont_hb_old(i)
6781       enddo
6782 c                write (iout,*) "gradcorr5 in eello5"
6783 c                do iii=1,nres
6784 c                  write (iout,'(i5,3f10.5)')
6785 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6786 c                enddo
6787       return
6788       end
6789 c------------------------------------------------------------------------------
6790       subroutine add_hb_contact_eello(ii,jj,itask)
6791       implicit real*8 (a-h,o-z)
6792       include "DIMENSIONS"
6793       include "COMMON.IOUNITS"
6794       integer max_cont
6795       integer max_dim
6796       parameter (max_cont=maxconts)
6797       parameter (max_dim=70)
6798       include "COMMON.CONTACTS"
6799       double precision zapas(max_dim,maxconts,max_fg_procs),
6800      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6801       common /przechowalnia/ zapas
6802       integer i,j,ii,jj,iproc,itask(4),nn
6803 c      write (iout,*) "itask",itask
6804       do i=1,2
6805         iproc=itask(i)
6806         if (iproc.gt.0) then
6807           do j=1,num_cont_hb(ii)
6808             jjc=jcont_hb(j,ii)
6809 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6810             if (jjc.eq.jj) then
6811               ncont_sent(iproc)=ncont_sent(iproc)+1
6812               nn=ncont_sent(iproc)
6813               zapas(1,nn,iproc)=ii
6814               zapas(2,nn,iproc)=jjc
6815               zapas(3,nn,iproc)=d_cont(j,ii)
6816               ind=3
6817               do kk=1,3
6818                 ind=ind+1
6819                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6820               enddo
6821               do kk=1,2
6822                 do ll=1,2
6823                   ind=ind+1
6824                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6825                 enddo
6826               enddo
6827               do jj=1,5
6828                 do kk=1,3
6829                   do ll=1,2
6830                     do mm=1,2
6831                       ind=ind+1
6832                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6833                     enddo
6834                   enddo
6835                 enddo
6836               enddo
6837               exit
6838             endif
6839           enddo
6840         endif
6841       enddo
6842       return
6843       end
6844 c------------------------------------------------------------------------------
6845       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6846       implicit real*8 (a-h,o-z)
6847       include 'DIMENSIONS'
6848       include 'COMMON.IOUNITS'
6849       include 'COMMON.DERIV'
6850       include 'COMMON.INTERACT'
6851       include 'COMMON.CONTACTS'
6852       double precision gx(3),gx1(3)
6853       logical lprn
6854       lprn=.false.
6855       eij=facont_hb(jj,i)
6856       ekl=facont_hb(kk,k)
6857       ees0pij=ees0p(jj,i)
6858       ees0pkl=ees0p(kk,k)
6859       ees0mij=ees0m(jj,i)
6860       ees0mkl=ees0m(kk,k)
6861       ekont=eij*ekl
6862       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6863 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6864 C Following 4 lines for diagnostics.
6865 cd    ees0pkl=0.0D0
6866 cd    ees0pij=1.0D0
6867 cd    ees0mkl=0.0D0
6868 cd    ees0mij=1.0D0
6869 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6870 c     & 'Contacts ',i,j,
6871 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6872 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6873 c     & 'gradcorr_long'
6874 C Calculate the multi-body contribution to energy.
6875 c      ecorr=ecorr+ekont*ees
6876 C Calculate multi-body contributions to the gradient.
6877       coeffpees0pij=coeffp*ees0pij
6878       coeffmees0mij=coeffm*ees0mij
6879       coeffpees0pkl=coeffp*ees0pkl
6880       coeffmees0mkl=coeffm*ees0mkl
6881       do ll=1,3
6882 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6883         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6884      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6885      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6886         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6887      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6888      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6889 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6890         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6891      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6892      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6893         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6894      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6895      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6896         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6897      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6898      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6899         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6900         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6901         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6902      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6903      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6904         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6905         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6906 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6907       enddo
6908 c      write (iout,*)
6909 cgrad      do m=i+1,j-1
6910 cgrad        do ll=1,3
6911 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6912 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6913 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6914 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6915 cgrad        enddo
6916 cgrad      enddo
6917 cgrad      do m=k+1,l-1
6918 cgrad        do ll=1,3
6919 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6920 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6921 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6922 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6923 cgrad        enddo
6924 cgrad      enddo
6925 c      write (iout,*) "ehbcorr",ekont*ees
6926       ehbcorr=ekont*ees
6927       return
6928       end
6929 #ifdef MOMENT
6930 C---------------------------------------------------------------------------
6931       subroutine dipole(i,j,jj)
6932       implicit real*8 (a-h,o-z)
6933       include 'DIMENSIONS'
6934       include 'COMMON.IOUNITS'
6935       include 'COMMON.CHAIN'
6936       include 'COMMON.FFIELD'
6937       include 'COMMON.DERIV'
6938       include 'COMMON.INTERACT'
6939       include 'COMMON.CONTACTS'
6940       include 'COMMON.TORSION'
6941       include 'COMMON.VAR'
6942       include 'COMMON.GEO'
6943       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6944      &  auxmat(2,2)
6945       iti1 = itortyp(itype(i+1))
6946       if (j.lt.nres-1) then
6947         itj1 = itortyp(itype(j+1))
6948       else
6949         itj1=ntortyp+1
6950       endif
6951       do iii=1,2
6952         dipi(iii,1)=Ub2(iii,i)
6953         dipderi(iii)=Ub2der(iii,i)
6954         dipi(iii,2)=b1(iii,iti1)
6955         dipj(iii,1)=Ub2(iii,j)
6956         dipderj(iii)=Ub2der(iii,j)
6957         dipj(iii,2)=b1(iii,itj1)
6958       enddo
6959       kkk=0
6960       do iii=1,2
6961         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6962         do jjj=1,2
6963           kkk=kkk+1
6964           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6965         enddo
6966       enddo
6967       do kkk=1,5
6968         do lll=1,3
6969           mmm=0
6970           do iii=1,2
6971             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6972      &        auxvec(1))
6973             do jjj=1,2
6974               mmm=mmm+1
6975               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6976             enddo
6977           enddo
6978         enddo
6979       enddo
6980       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6981       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6982       do iii=1,2
6983         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6984       enddo
6985       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6986       do iii=1,2
6987         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6988       enddo
6989       return
6990       end
6991 #endif
6992 C---------------------------------------------------------------------------
6993       subroutine calc_eello(i,j,k,l,jj,kk)
6994 C
6995 C This subroutine computes matrices and vectors needed to calculate
6996 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6997 C
6998       implicit real*8 (a-h,o-z)
6999       include 'DIMENSIONS'
7000       include 'COMMON.IOUNITS'
7001       include 'COMMON.CHAIN'
7002       include 'COMMON.DERIV'
7003       include 'COMMON.INTERACT'
7004       include 'COMMON.CONTACTS'
7005       include 'COMMON.TORSION'
7006       include 'COMMON.VAR'
7007       include 'COMMON.GEO'
7008       include 'COMMON.FFIELD'
7009       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7010      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7011       logical lprn
7012       common /kutas/ lprn
7013 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7014 cd     & ' jj=',jj,' kk=',kk
7015 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7016 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7017 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7018       do iii=1,2
7019         do jjj=1,2
7020           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7021           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7022         enddo
7023       enddo
7024       call transpose2(aa1(1,1),aa1t(1,1))
7025       call transpose2(aa2(1,1),aa2t(1,1))
7026       do kkk=1,5
7027         do lll=1,3
7028           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7029      &      aa1tder(1,1,lll,kkk))
7030           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7031      &      aa2tder(1,1,lll,kkk))
7032         enddo
7033       enddo
7034       if (l.eq.j+1) then
7035 C parallel orientation of the two CA-CA-CA frames.
7036         if (i.gt.1) then
7037           iti=itortyp(itype(i))
7038         else
7039           iti=ntortyp+1
7040         endif
7041         itk1=itortyp(itype(k+1))
7042         itj=itortyp(itype(j))
7043         if (l.lt.nres-1) then
7044           itl1=itortyp(itype(l+1))
7045         else
7046           itl1=ntortyp+1
7047         endif
7048 C A1 kernel(j+1) A2T
7049 cd        do iii=1,2
7050 cd          write (iout,'(3f10.5,5x,3f10.5)')
7051 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7052 cd        enddo
7053         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7054      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7055      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7056 C Following matrices are needed only for 6-th order cumulants
7057         IF (wcorr6.gt.0.0d0) THEN
7058         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7059      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7060      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7061         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7062      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7063      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7064      &   ADtEAderx(1,1,1,1,1,1))
7065         lprn=.false.
7066         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7067      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7068      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7069      &   ADtEA1derx(1,1,1,1,1,1))
7070         ENDIF
7071 C End 6-th order cumulants
7072 cd        lprn=.false.
7073 cd        if (lprn) then
7074 cd        write (2,*) 'In calc_eello6'
7075 cd        do iii=1,2
7076 cd          write (2,*) 'iii=',iii
7077 cd          do kkk=1,5
7078 cd            write (2,*) 'kkk=',kkk
7079 cd            do jjj=1,2
7080 cd              write (2,'(3(2f10.5),5x)')
7081 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7082 cd            enddo
7083 cd          enddo
7084 cd        enddo
7085 cd        endif
7086         call transpose2(EUgder(1,1,k),auxmat(1,1))
7087         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7088         call transpose2(EUg(1,1,k),auxmat(1,1))
7089         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7090         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7091         do iii=1,2
7092           do kkk=1,5
7093             do lll=1,3
7094               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7095      &          EAEAderx(1,1,lll,kkk,iii,1))
7096             enddo
7097           enddo
7098         enddo
7099 C A1T kernel(i+1) A2
7100         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7101      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7102      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7103 C Following matrices are needed only for 6-th order cumulants
7104         IF (wcorr6.gt.0.0d0) THEN
7105         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7106      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7107      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7108         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7109      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7110      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7111      &   ADtEAderx(1,1,1,1,1,2))
7112         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7113      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7114      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7115      &   ADtEA1derx(1,1,1,1,1,2))
7116         ENDIF
7117 C End 6-th order cumulants
7118         call transpose2(EUgder(1,1,l),auxmat(1,1))
7119         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7120         call transpose2(EUg(1,1,l),auxmat(1,1))
7121         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7122         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7123         do iii=1,2
7124           do kkk=1,5
7125             do lll=1,3
7126               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7127      &          EAEAderx(1,1,lll,kkk,iii,2))
7128             enddo
7129           enddo
7130         enddo
7131 C AEAb1 and AEAb2
7132 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7133 C They are needed only when the fifth- or the sixth-order cumulants are
7134 C indluded.
7135         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7136         call transpose2(AEA(1,1,1),auxmat(1,1))
7137         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7138         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7139         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7140         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7141         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7142         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7143         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7144         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7145         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7146         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7147         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7148         call transpose2(AEA(1,1,2),auxmat(1,1))
7149         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7150         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7151         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7152         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7153         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7154         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7155         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7156         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7157         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7158         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7159         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7160 C Calculate the Cartesian derivatives of the vectors.
7161         do iii=1,2
7162           do kkk=1,5
7163             do lll=1,3
7164               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7165               call matvec2(auxmat(1,1),b1(1,iti),
7166      &          AEAb1derx(1,lll,kkk,iii,1,1))
7167               call matvec2(auxmat(1,1),Ub2(1,i),
7168      &          AEAb2derx(1,lll,kkk,iii,1,1))
7169               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7170      &          AEAb1derx(1,lll,kkk,iii,2,1))
7171               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7172      &          AEAb2derx(1,lll,kkk,iii,2,1))
7173               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7174               call matvec2(auxmat(1,1),b1(1,itj),
7175      &          AEAb1derx(1,lll,kkk,iii,1,2))
7176               call matvec2(auxmat(1,1),Ub2(1,j),
7177      &          AEAb2derx(1,lll,kkk,iii,1,2))
7178               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7179      &          AEAb1derx(1,lll,kkk,iii,2,2))
7180               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7181      &          AEAb2derx(1,lll,kkk,iii,2,2))
7182             enddo
7183           enddo
7184         enddo
7185         ENDIF
7186 C End vectors
7187       else
7188 C Antiparallel orientation of the two CA-CA-CA frames.
7189         if (i.gt.1) then
7190           iti=itortyp(itype(i))
7191         else
7192           iti=ntortyp+1
7193         endif
7194         itk1=itortyp(itype(k+1))
7195         itl=itortyp(itype(l))
7196         itj=itortyp(itype(j))
7197         if (j.lt.nres-1) then
7198           itj1=itortyp(itype(j+1))
7199         else
7200           itj1=ntortyp+1
7201         endif
7202 C A2 kernel(j-1)T A1T
7203         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7204      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7205      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7206 C Following matrices are needed only for 6-th order cumulants
7207         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7208      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7209         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7210      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7211      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7212         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7213      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7214      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7215      &   ADtEAderx(1,1,1,1,1,1))
7216         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7217      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7218      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7219      &   ADtEA1derx(1,1,1,1,1,1))
7220         ENDIF
7221 C End 6-th order cumulants
7222         call transpose2(EUgder(1,1,k),auxmat(1,1))
7223         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7224         call transpose2(EUg(1,1,k),auxmat(1,1))
7225         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7226         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7227         do iii=1,2
7228           do kkk=1,5
7229             do lll=1,3
7230               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7231      &          EAEAderx(1,1,lll,kkk,iii,1))
7232             enddo
7233           enddo
7234         enddo
7235 C A2T kernel(i+1)T A1
7236         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7237      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7238      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7239 C Following matrices are needed only for 6-th order cumulants
7240         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7241      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7242         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7243      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7244      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7245         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7246      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7247      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7248      &   ADtEAderx(1,1,1,1,1,2))
7249         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7250      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7251      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7252      &   ADtEA1derx(1,1,1,1,1,2))
7253         ENDIF
7254 C End 6-th order cumulants
7255         call transpose2(EUgder(1,1,j),auxmat(1,1))
7256         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7257         call transpose2(EUg(1,1,j),auxmat(1,1))
7258         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7259         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7260         do iii=1,2
7261           do kkk=1,5
7262             do lll=1,3
7263               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7264      &          EAEAderx(1,1,lll,kkk,iii,2))
7265             enddo
7266           enddo
7267         enddo
7268 C AEAb1 and AEAb2
7269 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7270 C They are needed only when the fifth- or the sixth-order cumulants are
7271 C indluded.
7272         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7273      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7274         call transpose2(AEA(1,1,1),auxmat(1,1))
7275         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7276         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7277         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7278         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7279         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7280         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7281         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7282         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7283         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7284         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7285         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7286         call transpose2(AEA(1,1,2),auxmat(1,1))
7287         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7288         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7289         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7290         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7291         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7292         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7293         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7294         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7295         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7296         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7297         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7298 C Calculate the Cartesian derivatives of the vectors.
7299         do iii=1,2
7300           do kkk=1,5
7301             do lll=1,3
7302               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7303               call matvec2(auxmat(1,1),b1(1,iti),
7304      &          AEAb1derx(1,lll,kkk,iii,1,1))
7305               call matvec2(auxmat(1,1),Ub2(1,i),
7306      &          AEAb2derx(1,lll,kkk,iii,1,1))
7307               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7308      &          AEAb1derx(1,lll,kkk,iii,2,1))
7309               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7310      &          AEAb2derx(1,lll,kkk,iii,2,1))
7311               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7312               call matvec2(auxmat(1,1),b1(1,itl),
7313      &          AEAb1derx(1,lll,kkk,iii,1,2))
7314               call matvec2(auxmat(1,1),Ub2(1,l),
7315      &          AEAb2derx(1,lll,kkk,iii,1,2))
7316               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7317      &          AEAb1derx(1,lll,kkk,iii,2,2))
7318               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7319      &          AEAb2derx(1,lll,kkk,iii,2,2))
7320             enddo
7321           enddo
7322         enddo
7323         ENDIF
7324 C End vectors
7325       endif
7326       return
7327       end
7328 C---------------------------------------------------------------------------
7329       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7330      &  KK,KKderg,AKA,AKAderg,AKAderx)
7331       implicit none
7332       integer nderg
7333       logical transp
7334       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7335      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7336      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7337       integer iii,kkk,lll
7338       integer jjj,mmm
7339       logical lprn
7340       common /kutas/ lprn
7341       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7342       do iii=1,nderg
7343         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7344      &    AKAderg(1,1,iii))
7345       enddo
7346 cd      if (lprn) write (2,*) 'In kernel'
7347       do kkk=1,5
7348 cd        if (lprn) write (2,*) 'kkk=',kkk
7349         do lll=1,3
7350           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7351      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7352 cd          if (lprn) then
7353 cd            write (2,*) 'lll=',lll
7354 cd            write (2,*) 'iii=1'
7355 cd            do jjj=1,2
7356 cd              write (2,'(3(2f10.5),5x)')
7357 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7358 cd            enddo
7359 cd          endif
7360           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7361      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7362 cd          if (lprn) then
7363 cd            write (2,*) 'lll=',lll
7364 cd            write (2,*) 'iii=2'
7365 cd            do jjj=1,2
7366 cd              write (2,'(3(2f10.5),5x)')
7367 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7368 cd            enddo
7369 cd          endif
7370         enddo
7371       enddo
7372       return
7373       end
7374 C---------------------------------------------------------------------------
7375       double precision function eello4(i,j,k,l,jj,kk)
7376       implicit real*8 (a-h,o-z)
7377       include 'DIMENSIONS'
7378       include 'COMMON.IOUNITS'
7379       include 'COMMON.CHAIN'
7380       include 'COMMON.DERIV'
7381       include 'COMMON.INTERACT'
7382       include 'COMMON.CONTACTS'
7383       include 'COMMON.TORSION'
7384       include 'COMMON.VAR'
7385       include 'COMMON.GEO'
7386       double precision pizda(2,2),ggg1(3),ggg2(3)
7387 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7388 cd        eello4=0.0d0
7389 cd        return
7390 cd      endif
7391 cd      print *,'eello4:',i,j,k,l,jj,kk
7392 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7393 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7394 cold      eij=facont_hb(jj,i)
7395 cold      ekl=facont_hb(kk,k)
7396 cold      ekont=eij*ekl
7397       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7398 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7399       gcorr_loc(k-1)=gcorr_loc(k-1)
7400      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7401       if (l.eq.j+1) then
7402         gcorr_loc(l-1)=gcorr_loc(l-1)
7403      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7404       else
7405         gcorr_loc(j-1)=gcorr_loc(j-1)
7406      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7407       endif
7408       do iii=1,2
7409         do kkk=1,5
7410           do lll=1,3
7411             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7412      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7413 cd            derx(lll,kkk,iii)=0.0d0
7414           enddo
7415         enddo
7416       enddo
7417 cd      gcorr_loc(l-1)=0.0d0
7418 cd      gcorr_loc(j-1)=0.0d0
7419 cd      gcorr_loc(k-1)=0.0d0
7420 cd      eel4=1.0d0
7421 cd      write (iout,*)'Contacts have occurred for peptide groups',
7422 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7423 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7424       if (j.lt.nres-1) then
7425         j1=j+1
7426         j2=j-1
7427       else
7428         j1=j-1
7429         j2=j-2
7430       endif
7431       if (l.lt.nres-1) then
7432         l1=l+1
7433         l2=l-1
7434       else
7435         l1=l-1
7436         l2=l-2
7437       endif
7438       do ll=1,3
7439 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7440 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7441         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7442         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7443 cgrad        ghalf=0.5d0*ggg1(ll)
7444         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7445         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7446         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7447         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7448         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7449         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7450 cgrad        ghalf=0.5d0*ggg2(ll)
7451         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7452         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7453         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7454         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7455         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7456         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7457       enddo
7458 cgrad      do m=i+1,j-1
7459 cgrad        do ll=1,3
7460 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7461 cgrad        enddo
7462 cgrad      enddo
7463 cgrad      do m=k+1,l-1
7464 cgrad        do ll=1,3
7465 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7466 cgrad        enddo
7467 cgrad      enddo
7468 cgrad      do m=i+2,j2
7469 cgrad        do ll=1,3
7470 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7471 cgrad        enddo
7472 cgrad      enddo
7473 cgrad      do m=k+2,l2
7474 cgrad        do ll=1,3
7475 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7476 cgrad        enddo
7477 cgrad      enddo
7478 cd      do iii=1,nres-3
7479 cd        write (2,*) iii,gcorr_loc(iii)
7480 cd      enddo
7481       eello4=ekont*eel4
7482 cd      write (2,*) 'ekont',ekont
7483 cd      write (iout,*) 'eello4',ekont*eel4
7484       return
7485       end
7486 C---------------------------------------------------------------------------
7487       double precision function eello5(i,j,k,l,jj,kk)
7488       implicit real*8 (a-h,o-z)
7489       include 'DIMENSIONS'
7490       include 'COMMON.IOUNITS'
7491       include 'COMMON.CHAIN'
7492       include 'COMMON.DERIV'
7493       include 'COMMON.INTERACT'
7494       include 'COMMON.CONTACTS'
7495       include 'COMMON.TORSION'
7496       include 'COMMON.VAR'
7497       include 'COMMON.GEO'
7498       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7499       double precision ggg1(3),ggg2(3)
7500 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7501 C                                                                              C
7502 C                            Parallel chains                                   C
7503 C                                                                              C
7504 C          o             o                   o             o                   C
7505 C         /l\           / \             \   / \           / \   /              C
7506 C        /   \         /   \             \ /   \         /   \ /               C
7507 C       j| o |l1       | o |              o| o |         | o |o                C
7508 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7509 C      \i/   \         /   \ /             /   \         /   \                 C
7510 C       o    k1             o                                                  C
7511 C         (I)          (II)                (III)          (IV)                 C
7512 C                                                                              C
7513 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7514 C                                                                              C
7515 C                            Antiparallel chains                               C
7516 C                                                                              C
7517 C          o             o                   o             o                   C
7518 C         /j\           / \             \   / \           / \   /              C
7519 C        /   \         /   \             \ /   \         /   \ /               C
7520 C      j1| o |l        | o |              o| o |         | o |o                C
7521 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7522 C      \i/   \         /   \ /             /   \         /   \                 C
7523 C       o     k1            o                                                  C
7524 C         (I)          (II)                (III)          (IV)                 C
7525 C                                                                              C
7526 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7527 C                                                                              C
7528 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7529 C                                                                              C
7530 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7531 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7532 cd        eello5=0.0d0
7533 cd        return
7534 cd      endif
7535 cd      write (iout,*)
7536 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7537 cd     &   ' and',k,l
7538       itk=itortyp(itype(k))
7539       itl=itortyp(itype(l))
7540       itj=itortyp(itype(j))
7541       eello5_1=0.0d0
7542       eello5_2=0.0d0
7543       eello5_3=0.0d0
7544       eello5_4=0.0d0
7545 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7546 cd     &   eel5_3_num,eel5_4_num)
7547       do iii=1,2
7548         do kkk=1,5
7549           do lll=1,3
7550             derx(lll,kkk,iii)=0.0d0
7551           enddo
7552         enddo
7553       enddo
7554 cd      eij=facont_hb(jj,i)
7555 cd      ekl=facont_hb(kk,k)
7556 cd      ekont=eij*ekl
7557 cd      write (iout,*)'Contacts have occurred for peptide groups',
7558 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7559 cd      goto 1111
7560 C Contribution from the graph I.
7561 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7562 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7563       call transpose2(EUg(1,1,k),auxmat(1,1))
7564       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7565       vv(1)=pizda(1,1)-pizda(2,2)
7566       vv(2)=pizda(1,2)+pizda(2,1)
7567       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7568      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7569 C Explicit gradient in virtual-dihedral angles.
7570       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7571      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7572      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7573       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7574       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7575       vv(1)=pizda(1,1)-pizda(2,2)
7576       vv(2)=pizda(1,2)+pizda(2,1)
7577       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7578      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7579      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7580       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7581       vv(1)=pizda(1,1)-pizda(2,2)
7582       vv(2)=pizda(1,2)+pizda(2,1)
7583       if (l.eq.j+1) then
7584         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7585      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7586      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7587       else
7588         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7589      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7590      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7591       endif
7592 C Cartesian gradient
7593       do iii=1,2
7594         do kkk=1,5
7595           do lll=1,3
7596             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7597      &        pizda(1,1))
7598             vv(1)=pizda(1,1)-pizda(2,2)
7599             vv(2)=pizda(1,2)+pizda(2,1)
7600             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7601      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7602      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7603           enddo
7604         enddo
7605       enddo
7606 c      goto 1112
7607 c1111  continue
7608 C Contribution from graph II
7609       call transpose2(EE(1,1,itk),auxmat(1,1))
7610       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7611       vv(1)=pizda(1,1)+pizda(2,2)
7612       vv(2)=pizda(2,1)-pizda(1,2)
7613       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7614      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7615 C Explicit gradient in virtual-dihedral angles.
7616       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7617      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7618       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7619       vv(1)=pizda(1,1)+pizda(2,2)
7620       vv(2)=pizda(2,1)-pizda(1,2)
7621       if (l.eq.j+1) then
7622         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7623      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7624      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7625       else
7626         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7627      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7628      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7629       endif
7630 C Cartesian gradient
7631       do iii=1,2
7632         do kkk=1,5
7633           do lll=1,3
7634             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7635      &        pizda(1,1))
7636             vv(1)=pizda(1,1)+pizda(2,2)
7637             vv(2)=pizda(2,1)-pizda(1,2)
7638             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7639      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7640      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7641           enddo
7642         enddo
7643       enddo
7644 cd      goto 1112
7645 cd1111  continue
7646       if (l.eq.j+1) then
7647 cd        goto 1110
7648 C Parallel orientation
7649 C Contribution from graph III
7650         call transpose2(EUg(1,1,l),auxmat(1,1))
7651         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7652         vv(1)=pizda(1,1)-pizda(2,2)
7653         vv(2)=pizda(1,2)+pizda(2,1)
7654         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7655      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7656 C Explicit gradient in virtual-dihedral angles.
7657         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7658      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7659      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7660         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7661         vv(1)=pizda(1,1)-pizda(2,2)
7662         vv(2)=pizda(1,2)+pizda(2,1)
7663         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7664      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7665      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7666         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7667         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7668         vv(1)=pizda(1,1)-pizda(2,2)
7669         vv(2)=pizda(1,2)+pizda(2,1)
7670         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7671      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7672      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7673 C Cartesian gradient
7674         do iii=1,2
7675           do kkk=1,5
7676             do lll=1,3
7677               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7678      &          pizda(1,1))
7679               vv(1)=pizda(1,1)-pizda(2,2)
7680               vv(2)=pizda(1,2)+pizda(2,1)
7681               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7682      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7683      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7684             enddo
7685           enddo
7686         enddo
7687 cd        goto 1112
7688 C Contribution from graph IV
7689 cd1110    continue
7690         call transpose2(EE(1,1,itl),auxmat(1,1))
7691         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7692         vv(1)=pizda(1,1)+pizda(2,2)
7693         vv(2)=pizda(2,1)-pizda(1,2)
7694         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7695      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7696 C Explicit gradient in virtual-dihedral angles.
7697         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7698      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7699         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7700         vv(1)=pizda(1,1)+pizda(2,2)
7701         vv(2)=pizda(2,1)-pizda(1,2)
7702         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7703      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7704      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7705 C Cartesian gradient
7706         do iii=1,2
7707           do kkk=1,5
7708             do lll=1,3
7709               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7710      &          pizda(1,1))
7711               vv(1)=pizda(1,1)+pizda(2,2)
7712               vv(2)=pizda(2,1)-pizda(1,2)
7713               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7714      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7715      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7716             enddo
7717           enddo
7718         enddo
7719       else
7720 C Antiparallel orientation
7721 C Contribution from graph III
7722 c        goto 1110
7723         call transpose2(EUg(1,1,j),auxmat(1,1))
7724         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7725         vv(1)=pizda(1,1)-pizda(2,2)
7726         vv(2)=pizda(1,2)+pizda(2,1)
7727         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7728      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7729 C Explicit gradient in virtual-dihedral angles.
7730         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7731      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7732      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7733         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7734         vv(1)=pizda(1,1)-pizda(2,2)
7735         vv(2)=pizda(1,2)+pizda(2,1)
7736         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7737      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7738      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7739         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7740         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7741         vv(1)=pizda(1,1)-pizda(2,2)
7742         vv(2)=pizda(1,2)+pizda(2,1)
7743         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7744      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7745      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7746 C Cartesian gradient
7747         do iii=1,2
7748           do kkk=1,5
7749             do lll=1,3
7750               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7751      &          pizda(1,1))
7752               vv(1)=pizda(1,1)-pizda(2,2)
7753               vv(2)=pizda(1,2)+pizda(2,1)
7754               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7755      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7756      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7757             enddo
7758           enddo
7759         enddo
7760 cd        goto 1112
7761 C Contribution from graph IV
7762 1110    continue
7763         call transpose2(EE(1,1,itj),auxmat(1,1))
7764         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7765         vv(1)=pizda(1,1)+pizda(2,2)
7766         vv(2)=pizda(2,1)-pizda(1,2)
7767         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7768      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7769 C Explicit gradient in virtual-dihedral angles.
7770         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7771      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7772         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7773         vv(1)=pizda(1,1)+pizda(2,2)
7774         vv(2)=pizda(2,1)-pizda(1,2)
7775         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7776      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7777      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7778 C Cartesian gradient
7779         do iii=1,2
7780           do kkk=1,5
7781             do lll=1,3
7782               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7783      &          pizda(1,1))
7784               vv(1)=pizda(1,1)+pizda(2,2)
7785               vv(2)=pizda(2,1)-pizda(1,2)
7786               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7787      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7788      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7789             enddo
7790           enddo
7791         enddo
7792       endif
7793 1112  continue
7794       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7795 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7796 cd        write (2,*) 'ijkl',i,j,k,l
7797 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7798 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7799 cd      endif
7800 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7801 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7802 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7803 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7804       if (j.lt.nres-1) then
7805         j1=j+1
7806         j2=j-1
7807       else
7808         j1=j-1
7809         j2=j-2
7810       endif
7811       if (l.lt.nres-1) then
7812         l1=l+1
7813         l2=l-1
7814       else
7815         l1=l-1
7816         l2=l-2
7817       endif
7818 cd      eij=1.0d0
7819 cd      ekl=1.0d0
7820 cd      ekont=1.0d0
7821 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7822 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7823 C        summed up outside the subrouine as for the other subroutines
7824 C        handling long-range interactions. The old code is commented out
7825 C        with "cgrad" to keep track of changes.
7826       do ll=1,3
7827 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7828 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7829         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7830         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7831 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7832 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7833 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7834 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7835 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7836 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7837 c     &   gradcorr5ij,
7838 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7839 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7840 cgrad        ghalf=0.5d0*ggg1(ll)
7841 cd        ghalf=0.0d0
7842         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7843         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7844         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7845         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7846         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7847         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7848 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7849 cgrad        ghalf=0.5d0*ggg2(ll)
7850 cd        ghalf=0.0d0
7851         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7852         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7853         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7854         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7855         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7856         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7857       enddo
7858 cd      goto 1112
7859 cgrad      do m=i+1,j-1
7860 cgrad        do ll=1,3
7861 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7862 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7863 cgrad        enddo
7864 cgrad      enddo
7865 cgrad      do m=k+1,l-1
7866 cgrad        do ll=1,3
7867 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7868 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7869 cgrad        enddo
7870 cgrad      enddo
7871 c1112  continue
7872 cgrad      do m=i+2,j2
7873 cgrad        do ll=1,3
7874 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7875 cgrad        enddo
7876 cgrad      enddo
7877 cgrad      do m=k+2,l2
7878 cgrad        do ll=1,3
7879 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7880 cgrad        enddo
7881 cgrad      enddo
7882 cd      do iii=1,nres-3
7883 cd        write (2,*) iii,g_corr5_loc(iii)
7884 cd      enddo
7885       eello5=ekont*eel5
7886 cd      write (2,*) 'ekont',ekont
7887 cd      write (iout,*) 'eello5',ekont*eel5
7888       return
7889       end
7890 c--------------------------------------------------------------------------
7891       double precision function eello6(i,j,k,l,jj,kk)
7892       implicit real*8 (a-h,o-z)
7893       include 'DIMENSIONS'
7894       include 'COMMON.IOUNITS'
7895       include 'COMMON.CHAIN'
7896       include 'COMMON.DERIV'
7897       include 'COMMON.INTERACT'
7898       include 'COMMON.CONTACTS'
7899       include 'COMMON.TORSION'
7900       include 'COMMON.VAR'
7901       include 'COMMON.GEO'
7902       include 'COMMON.FFIELD'
7903       double precision ggg1(3),ggg2(3)
7904 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7905 cd        eello6=0.0d0
7906 cd        return
7907 cd      endif
7908 cd      write (iout,*)
7909 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7910 cd     &   ' and',k,l
7911       eello6_1=0.0d0
7912       eello6_2=0.0d0
7913       eello6_3=0.0d0
7914       eello6_4=0.0d0
7915       eello6_5=0.0d0
7916       eello6_6=0.0d0
7917 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7918 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7919       do iii=1,2
7920         do kkk=1,5
7921           do lll=1,3
7922             derx(lll,kkk,iii)=0.0d0
7923           enddo
7924         enddo
7925       enddo
7926 cd      eij=facont_hb(jj,i)
7927 cd      ekl=facont_hb(kk,k)
7928 cd      ekont=eij*ekl
7929 cd      eij=1.0d0
7930 cd      ekl=1.0d0
7931 cd      ekont=1.0d0
7932       if (l.eq.j+1) then
7933         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7934         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7935         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7936         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7937         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7938         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7939       else
7940         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7941         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7942         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7943         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7944         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7945           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7946         else
7947           eello6_5=0.0d0
7948         endif
7949         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7950       endif
7951 C If turn contributions are considered, they will be handled separately.
7952       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7953 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
7954 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
7955 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
7956 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
7957 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
7958 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
7959 cd      goto 1112
7960       if (j.lt.nres-1) then
7961         j1=j+1
7962         j2=j-1
7963       else
7964         j1=j-1
7965         j2=j-2
7966       endif
7967       if (l.lt.nres-1) then
7968         l1=l+1
7969         l2=l-1
7970       else
7971         l1=l-1
7972         l2=l-2
7973       endif
7974       do ll=1,3
7975 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
7976 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
7977 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7978 cgrad        ghalf=0.5d0*ggg1(ll)
7979 cd        ghalf=0.0d0
7980         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
7981         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
7982         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
7983         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7984         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
7985         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7986         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
7987         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
7988 cgrad        ghalf=0.5d0*ggg2(ll)
7989 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7990 cd        ghalf=0.0d0
7991         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
7992         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7993         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
7994         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7995         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
7996         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
7997       enddo
7998 cd      goto 1112
7999 cgrad      do m=i+1,j-1
8000 cgrad        do ll=1,3
8001 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8002 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8003 cgrad        enddo
8004 cgrad      enddo
8005 cgrad      do m=k+1,l-1
8006 cgrad        do ll=1,3
8007 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8008 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8009 cgrad        enddo
8010 cgrad      enddo
8011 cgrad1112  continue
8012 cgrad      do m=i+2,j2
8013 cgrad        do ll=1,3
8014 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8015 cgrad        enddo
8016 cgrad      enddo
8017 cgrad      do m=k+2,l2
8018 cgrad        do ll=1,3
8019 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8020 cgrad        enddo
8021 cgrad      enddo
8022 cd      do iii=1,nres-3
8023 cd        write (2,*) iii,g_corr6_loc(iii)
8024 cd      enddo
8025       eello6=ekont*eel6
8026 cd      write (2,*) 'ekont',ekont
8027 cd      write (iout,*) 'eello6',ekont*eel6
8028       return
8029       end
8030 c--------------------------------------------------------------------------
8031       double precision function eello6_graph1(i,j,k,l,imat,swap)
8032       implicit real*8 (a-h,o-z)
8033       include 'DIMENSIONS'
8034       include 'COMMON.IOUNITS'
8035       include 'COMMON.CHAIN'
8036       include 'COMMON.DERIV'
8037       include 'COMMON.INTERACT'
8038       include 'COMMON.CONTACTS'
8039       include 'COMMON.TORSION'
8040       include 'COMMON.VAR'
8041       include 'COMMON.GEO'
8042       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8043       logical swap
8044       logical lprn
8045       common /kutas/ lprn
8046 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8047 C                                                                              C
8048 C      Parallel       Antiparallel                                             C
8049 C                                                                              C
8050 C          o             o                                                     C
8051 C         /l\           /j\                                                    C
8052 C        /   \         /   \                                                   C
8053 C       /| o |         | o |\                                                  C
8054 C     \ j|/k\|  /   \  |/k\|l /                                                C
8055 C      \ /   \ /     \ /   \ /                                                 C
8056 C       o     o       o     o                                                  C
8057 C       i             i                                                        C
8058 C                                                                              C
8059 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8060       itk=itortyp(itype(k))
8061       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8062       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8063       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8064       call transpose2(EUgC(1,1,k),auxmat(1,1))
8065       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8066       vv1(1)=pizda1(1,1)-pizda1(2,2)
8067       vv1(2)=pizda1(1,2)+pizda1(2,1)
8068       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8069       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8070       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8071       s5=scalar2(vv(1),Dtobr2(1,i))
8072 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8073       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8074       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8075      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8076      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8077      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8078      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8079      & +scalar2(vv(1),Dtobr2der(1,i)))
8080       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8081       vv1(1)=pizda1(1,1)-pizda1(2,2)
8082       vv1(2)=pizda1(1,2)+pizda1(2,1)
8083       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8084       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8085       if (l.eq.j+1) then
8086         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8087      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8088      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8089      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8090      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8091       else
8092         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8093      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8094      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8095      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8096      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8097       endif
8098       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8099       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8100       vv1(1)=pizda1(1,1)-pizda1(2,2)
8101       vv1(2)=pizda1(1,2)+pizda1(2,1)
8102       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8103      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8104      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8105      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8106       do iii=1,2
8107         if (swap) then
8108           ind=3-iii
8109         else
8110           ind=iii
8111         endif
8112         do kkk=1,5
8113           do lll=1,3
8114             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8115             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8116             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8117             call transpose2(EUgC(1,1,k),auxmat(1,1))
8118             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8119      &        pizda1(1,1))
8120             vv1(1)=pizda1(1,1)-pizda1(2,2)
8121             vv1(2)=pizda1(1,2)+pizda1(2,1)
8122             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8123             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8124      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8125             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8126      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8127             s5=scalar2(vv(1),Dtobr2(1,i))
8128             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8129           enddo
8130         enddo
8131       enddo
8132       return
8133       end
8134 c----------------------------------------------------------------------------
8135       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8136       implicit real*8 (a-h,o-z)
8137       include 'DIMENSIONS'
8138       include 'COMMON.IOUNITS'
8139       include 'COMMON.CHAIN'
8140       include 'COMMON.DERIV'
8141       include 'COMMON.INTERACT'
8142       include 'COMMON.CONTACTS'
8143       include 'COMMON.TORSION'
8144       include 'COMMON.VAR'
8145       include 'COMMON.GEO'
8146       logical swap
8147       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8148      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8149       logical lprn
8150       common /kutas/ lprn
8151 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8152 C                                                                              C
8153 C      Parallel       Antiparallel                                             C
8154 C                                                                              C
8155 C          o             o                                                     C
8156 C     \   /l\           /j\   /                                                C
8157 C      \ /   \         /   \ /                                                 C
8158 C       o| o |         | o |o                                                  C
8159 C     \ j|/k\|      \  |/k\|l                                                  C
8160 C      \ /   \       \ /   \                                                   C
8161 C       o             o                                                        C
8162 C       i             i                                                        C
8163 C                                                                              C
8164 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8165 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8166 C AL 7/4/01 s1 would occur in the sixth-order moment,
8167 C           but not in a cluster cumulant
8168 #ifdef MOMENT
8169       s1=dip(1,jj,i)*dip(1,kk,k)
8170 #endif
8171       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8172       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8173       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8174       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8175       call transpose2(EUg(1,1,k),auxmat(1,1))
8176       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8177       vv(1)=pizda(1,1)-pizda(2,2)
8178       vv(2)=pizda(1,2)+pizda(2,1)
8179       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8180 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8181 #ifdef MOMENT
8182       eello6_graph2=-(s1+s2+s3+s4)
8183 #else
8184       eello6_graph2=-(s2+s3+s4)
8185 #endif
8186 c      eello6_graph2=-s3
8187 C Derivatives in gamma(i-1)
8188       if (i.gt.1) then
8189 #ifdef MOMENT
8190         s1=dipderg(1,jj,i)*dip(1,kk,k)
8191 #endif
8192         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8193         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8194         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8195         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8196 #ifdef MOMENT
8197         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8198 #else
8199         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8200 #endif
8201 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8202       endif
8203 C Derivatives in gamma(k-1)
8204 #ifdef MOMENT
8205       s1=dip(1,jj,i)*dipderg(1,kk,k)
8206 #endif
8207       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8208       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8209       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8210       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8211       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8212       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8213       vv(1)=pizda(1,1)-pizda(2,2)
8214       vv(2)=pizda(1,2)+pizda(2,1)
8215       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8216 #ifdef MOMENT
8217       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8218 #else
8219       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8220 #endif
8221 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8222 C Derivatives in gamma(j-1) or gamma(l-1)
8223       if (j.gt.1) then
8224 #ifdef MOMENT
8225         s1=dipderg(3,jj,i)*dip(1,kk,k)
8226 #endif
8227         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8228         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8229         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8230         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8231         vv(1)=pizda(1,1)-pizda(2,2)
8232         vv(2)=pizda(1,2)+pizda(2,1)
8233         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8234 #ifdef MOMENT
8235         if (swap) then
8236           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8237         else
8238           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8239         endif
8240 #endif
8241         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8242 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8243       endif
8244 C Derivatives in gamma(l-1) or gamma(j-1)
8245       if (l.gt.1) then
8246 #ifdef MOMENT
8247         s1=dip(1,jj,i)*dipderg(3,kk,k)
8248 #endif
8249         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8250         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8251         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8252         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8253         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8254         vv(1)=pizda(1,1)-pizda(2,2)
8255         vv(2)=pizda(1,2)+pizda(2,1)
8256         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8257 #ifdef MOMENT
8258         if (swap) then
8259           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8260         else
8261           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8262         endif
8263 #endif
8264         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8265 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8266       endif
8267 C Cartesian derivatives.
8268       if (lprn) then
8269         write (2,*) 'In eello6_graph2'
8270         do iii=1,2
8271           write (2,*) 'iii=',iii
8272           do kkk=1,5
8273             write (2,*) 'kkk=',kkk
8274             do jjj=1,2
8275               write (2,'(3(2f10.5),5x)')
8276      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8277             enddo
8278           enddo
8279         enddo
8280       endif
8281       do iii=1,2
8282         do kkk=1,5
8283           do lll=1,3
8284 #ifdef MOMENT
8285             if (iii.eq.1) then
8286               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8287             else
8288               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8289             endif
8290 #endif
8291             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8292      &        auxvec(1))
8293             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8294             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8295      &        auxvec(1))
8296             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8297             call transpose2(EUg(1,1,k),auxmat(1,1))
8298             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8299      &        pizda(1,1))
8300             vv(1)=pizda(1,1)-pizda(2,2)
8301             vv(2)=pizda(1,2)+pizda(2,1)
8302             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8303 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8304 #ifdef MOMENT
8305             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8306 #else
8307             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8308 #endif
8309             if (swap) then
8310               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8311             else
8312               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8313             endif
8314           enddo
8315         enddo
8316       enddo
8317       return
8318       end
8319 c----------------------------------------------------------------------------
8320       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8321       implicit real*8 (a-h,o-z)
8322       include 'DIMENSIONS'
8323       include 'COMMON.IOUNITS'
8324       include 'COMMON.CHAIN'
8325       include 'COMMON.DERIV'
8326       include 'COMMON.INTERACT'
8327       include 'COMMON.CONTACTS'
8328       include 'COMMON.TORSION'
8329       include 'COMMON.VAR'
8330       include 'COMMON.GEO'
8331       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8332       logical swap
8333 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8334 C                                                                              C
8335 C      Parallel       Antiparallel                                             C
8336 C                                                                              C
8337 C          o             o                                                     C
8338 C         /l\   /   \   /j\                                                    C
8339 C        /   \ /     \ /   \                                                   C
8340 C       /| o |o       o| o |\                                                  C
8341 C       j|/k\|  /      |/k\|l /                                                C
8342 C        /   \ /       /   \ /                                                 C
8343 C       /     o       /     o                                                  C
8344 C       i             i                                                        C
8345 C                                                                              C
8346 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8347 C
8348 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8349 C           energy moment and not to the cluster cumulant.
8350       iti=itortyp(itype(i))
8351       if (j.lt.nres-1) then
8352         itj1=itortyp(itype(j+1))
8353       else
8354         itj1=ntortyp+1
8355       endif
8356       itk=itortyp(itype(k))
8357       itk1=itortyp(itype(k+1))
8358       if (l.lt.nres-1) then
8359         itl1=itortyp(itype(l+1))
8360       else
8361         itl1=ntortyp+1
8362       endif
8363 #ifdef MOMENT
8364       s1=dip(4,jj,i)*dip(4,kk,k)
8365 #endif
8366       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8367       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8368       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8369       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8370       call transpose2(EE(1,1,itk),auxmat(1,1))
8371       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8372       vv(1)=pizda(1,1)+pizda(2,2)
8373       vv(2)=pizda(2,1)-pizda(1,2)
8374       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8375 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8376 cd     & "sum",-(s2+s3+s4)
8377 #ifdef MOMENT
8378       eello6_graph3=-(s1+s2+s3+s4)
8379 #else
8380       eello6_graph3=-(s2+s3+s4)
8381 #endif
8382 c      eello6_graph3=-s4
8383 C Derivatives in gamma(k-1)
8384       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8385       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8386       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8387       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8388 C Derivatives in gamma(l-1)
8389       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8390       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8391       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8392       vv(1)=pizda(1,1)+pizda(2,2)
8393       vv(2)=pizda(2,1)-pizda(1,2)
8394       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8395       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8396 C Cartesian derivatives.
8397       do iii=1,2
8398         do kkk=1,5
8399           do lll=1,3
8400 #ifdef MOMENT
8401             if (iii.eq.1) then
8402               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8403             else
8404               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8405             endif
8406 #endif
8407             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8408      &        auxvec(1))
8409             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8410             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8411      &        auxvec(1))
8412             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8413             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8414      &        pizda(1,1))
8415             vv(1)=pizda(1,1)+pizda(2,2)
8416             vv(2)=pizda(2,1)-pizda(1,2)
8417             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8418 #ifdef MOMENT
8419             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8420 #else
8421             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8422 #endif
8423             if (swap) then
8424               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8425             else
8426               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8427             endif
8428 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8429           enddo
8430         enddo
8431       enddo
8432       return
8433       end
8434 c----------------------------------------------------------------------------
8435       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8436       implicit real*8 (a-h,o-z)
8437       include 'DIMENSIONS'
8438       include 'COMMON.IOUNITS'
8439       include 'COMMON.CHAIN'
8440       include 'COMMON.DERIV'
8441       include 'COMMON.INTERACT'
8442       include 'COMMON.CONTACTS'
8443       include 'COMMON.TORSION'
8444       include 'COMMON.VAR'
8445       include 'COMMON.GEO'
8446       include 'COMMON.FFIELD'
8447       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8448      & auxvec1(2),auxmat1(2,2)
8449       logical swap
8450 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8451 C                                                                              C
8452 C      Parallel       Antiparallel                                             C
8453 C                                                                              C
8454 C          o             o                                                     C
8455 C         /l\   /   \   /j\                                                    C
8456 C        /   \ /     \ /   \                                                   C
8457 C       /| o |o       o| o |\                                                  C
8458 C     \ j|/k\|      \  |/k\|l                                                  C
8459 C      \ /   \       \ /   \                                                   C
8460 C       o     \       o     \                                                  C
8461 C       i             i                                                        C
8462 C                                                                              C
8463 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8464 C
8465 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8466 C           energy moment and not to the cluster cumulant.
8467 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8468       iti=itortyp(itype(i))
8469       itj=itortyp(itype(j))
8470       if (j.lt.nres-1) then
8471         itj1=itortyp(itype(j+1))
8472       else
8473         itj1=ntortyp+1
8474       endif
8475       itk=itortyp(itype(k))
8476       if (k.lt.nres-1) then
8477         itk1=itortyp(itype(k+1))
8478       else
8479         itk1=ntortyp+1
8480       endif
8481       itl=itortyp(itype(l))
8482       if (l.lt.nres-1) then
8483         itl1=itortyp(itype(l+1))
8484       else
8485         itl1=ntortyp+1
8486       endif
8487 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8488 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8489 cd     & ' itl',itl,' itl1',itl1
8490 #ifdef MOMENT
8491       if (imat.eq.1) then
8492         s1=dip(3,jj,i)*dip(3,kk,k)
8493       else
8494         s1=dip(2,jj,j)*dip(2,kk,l)
8495       endif
8496 #endif
8497       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8498       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8499       if (j.eq.l+1) then
8500         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8501         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8502       else
8503         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8504         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8505       endif
8506       call transpose2(EUg(1,1,k),auxmat(1,1))
8507       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8508       vv(1)=pizda(1,1)-pizda(2,2)
8509       vv(2)=pizda(2,1)+pizda(1,2)
8510       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8511 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8512 #ifdef MOMENT
8513       eello6_graph4=-(s1+s2+s3+s4)
8514 #else
8515       eello6_graph4=-(s2+s3+s4)
8516 #endif
8517 C Derivatives in gamma(i-1)
8518       if (i.gt.1) then
8519 #ifdef MOMENT
8520         if (imat.eq.1) then
8521           s1=dipderg(2,jj,i)*dip(3,kk,k)
8522         else
8523           s1=dipderg(4,jj,j)*dip(2,kk,l)
8524         endif
8525 #endif
8526         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8527         if (j.eq.l+1) then
8528           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8529           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8530         else
8531           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8532           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8533         endif
8534         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8535         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8536 cd          write (2,*) 'turn6 derivatives'
8537 #ifdef MOMENT
8538           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8539 #else
8540           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8541 #endif
8542         else
8543 #ifdef MOMENT
8544           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8545 #else
8546           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8547 #endif
8548         endif
8549       endif
8550 C Derivatives in gamma(k-1)
8551 #ifdef MOMENT
8552       if (imat.eq.1) then
8553         s1=dip(3,jj,i)*dipderg(2,kk,k)
8554       else
8555         s1=dip(2,jj,j)*dipderg(4,kk,l)
8556       endif
8557 #endif
8558       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8559       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8560       if (j.eq.l+1) then
8561         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8562         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8563       else
8564         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8565         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8566       endif
8567       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8568       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8569       vv(1)=pizda(1,1)-pizda(2,2)
8570       vv(2)=pizda(2,1)+pizda(1,2)
8571       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8572       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8573 #ifdef MOMENT
8574         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8575 #else
8576         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8577 #endif
8578       else
8579 #ifdef MOMENT
8580         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8581 #else
8582         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8583 #endif
8584       endif
8585 C Derivatives in gamma(j-1) or gamma(l-1)
8586       if (l.eq.j+1 .and. l.gt.1) then
8587         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8588         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8589         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8590         vv(1)=pizda(1,1)-pizda(2,2)
8591         vv(2)=pizda(2,1)+pizda(1,2)
8592         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8593         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8594       else if (j.gt.1) then
8595         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8596         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8597         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8598         vv(1)=pizda(1,1)-pizda(2,2)
8599         vv(2)=pizda(2,1)+pizda(1,2)
8600         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8601         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8602           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8603         else
8604           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8605         endif
8606       endif
8607 C Cartesian derivatives.
8608       do iii=1,2
8609         do kkk=1,5
8610           do lll=1,3
8611 #ifdef MOMENT
8612             if (iii.eq.1) then
8613               if (imat.eq.1) then
8614                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8615               else
8616                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8617               endif
8618             else
8619               if (imat.eq.1) then
8620                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8621               else
8622                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8623               endif
8624             endif
8625 #endif
8626             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8627      &        auxvec(1))
8628             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8629             if (j.eq.l+1) then
8630               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8631      &          b1(1,itj1),auxvec(1))
8632               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8633             else
8634               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8635      &          b1(1,itl1),auxvec(1))
8636               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8637             endif
8638             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8639      &        pizda(1,1))
8640             vv(1)=pizda(1,1)-pizda(2,2)
8641             vv(2)=pizda(2,1)+pizda(1,2)
8642             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8643             if (swap) then
8644               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8645 #ifdef MOMENT
8646                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8647      &             -(s1+s2+s4)
8648 #else
8649                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8650      &             -(s2+s4)
8651 #endif
8652                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8653               else
8654 #ifdef MOMENT
8655                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8656 #else
8657                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8658 #endif
8659                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8660               endif
8661             else
8662 #ifdef MOMENT
8663               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8664 #else
8665               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8666 #endif
8667               if (l.eq.j+1) then
8668                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8669               else
8670                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8671               endif
8672             endif
8673           enddo
8674         enddo
8675       enddo
8676       return
8677       end
8678 c----------------------------------------------------------------------------
8679       double precision function eello_turn6(i,jj,kk)
8680       implicit real*8 (a-h,o-z)
8681       include 'DIMENSIONS'
8682       include 'COMMON.IOUNITS'
8683       include 'COMMON.CHAIN'
8684       include 'COMMON.DERIV'
8685       include 'COMMON.INTERACT'
8686       include 'COMMON.CONTACTS'
8687       include 'COMMON.TORSION'
8688       include 'COMMON.VAR'
8689       include 'COMMON.GEO'
8690       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8691      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8692      &  ggg1(3),ggg2(3)
8693       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8694      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8695 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8696 C           the respective energy moment and not to the cluster cumulant.
8697       s1=0.0d0
8698       s8=0.0d0
8699       s13=0.0d0
8700 c
8701       eello_turn6=0.0d0
8702       j=i+4
8703       k=i+1
8704       l=i+3
8705       iti=itortyp(itype(i))
8706       itk=itortyp(itype(k))
8707       itk1=itortyp(itype(k+1))
8708       itl=itortyp(itype(l))
8709       itj=itortyp(itype(j))
8710 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8711 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8712 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8713 cd        eello6=0.0d0
8714 cd        return
8715 cd      endif
8716 cd      write (iout,*)
8717 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8718 cd     &   ' and',k,l
8719 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8720       do iii=1,2
8721         do kkk=1,5
8722           do lll=1,3
8723             derx_turn(lll,kkk,iii)=0.0d0
8724           enddo
8725         enddo
8726       enddo
8727 cd      eij=1.0d0
8728 cd      ekl=1.0d0
8729 cd      ekont=1.0d0
8730       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8731 cd      eello6_5=0.0d0
8732 cd      write (2,*) 'eello6_5',eello6_5
8733 #ifdef MOMENT
8734       call transpose2(AEA(1,1,1),auxmat(1,1))
8735       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8736       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8737       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8738 #endif
8739       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8740       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8741       s2 = scalar2(b1(1,itk),vtemp1(1))
8742 #ifdef MOMENT
8743       call transpose2(AEA(1,1,2),atemp(1,1))
8744       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8745       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8746       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8747 #endif
8748       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8749       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8750       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8751 #ifdef MOMENT
8752       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8753       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8754       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8755       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8756       ss13 = scalar2(b1(1,itk),vtemp4(1))
8757       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8758 #endif
8759 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8760 c      s1=0.0d0
8761 c      s2=0.0d0
8762 c      s8=0.0d0
8763 c      s12=0.0d0
8764 c      s13=0.0d0
8765       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8766 C Derivatives in gamma(i+2)
8767       s1d =0.0d0
8768       s8d =0.0d0
8769 #ifdef MOMENT
8770       call transpose2(AEA(1,1,1),auxmatd(1,1))
8771       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8772       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8773       call transpose2(AEAderg(1,1,2),atempd(1,1))
8774       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8775       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8776 #endif
8777       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8778       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8779       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8780 c      s1d=0.0d0
8781 c      s2d=0.0d0
8782 c      s8d=0.0d0
8783 c      s12d=0.0d0
8784 c      s13d=0.0d0
8785       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8786 C Derivatives in gamma(i+3)
8787 #ifdef MOMENT
8788       call transpose2(AEA(1,1,1),auxmatd(1,1))
8789       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8790       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8791       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8792 #endif
8793       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8794       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8795       s2d = scalar2(b1(1,itk),vtemp1d(1))
8796 #ifdef MOMENT
8797       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8798       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8799 #endif
8800       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8801 #ifdef MOMENT
8802       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8803       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8804       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8805 #endif
8806 c      s1d=0.0d0
8807 c      s2d=0.0d0
8808 c      s8d=0.0d0
8809 c      s12d=0.0d0
8810 c      s13d=0.0d0
8811 #ifdef MOMENT
8812       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8813      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8814 #else
8815       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8816      &               -0.5d0*ekont*(s2d+s12d)
8817 #endif
8818 C Derivatives in gamma(i+4)
8819       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8820       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8821       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8822 #ifdef MOMENT
8823       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8824       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8825       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8826 #endif
8827 c      s1d=0.0d0
8828 c      s2d=0.0d0
8829 c      s8d=0.0d0
8830 C      s12d=0.0d0
8831 c      s13d=0.0d0
8832 #ifdef MOMENT
8833       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8834 #else
8835       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8836 #endif
8837 C Derivatives in gamma(i+5)
8838 #ifdef MOMENT
8839       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8840       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8841       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8842 #endif
8843       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8844       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8845       s2d = scalar2(b1(1,itk),vtemp1d(1))
8846 #ifdef MOMENT
8847       call transpose2(AEA(1,1,2),atempd(1,1))
8848       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8849       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8850 #endif
8851       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8852       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8853 #ifdef MOMENT
8854       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8855       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8856       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8857 #endif
8858 c      s1d=0.0d0
8859 c      s2d=0.0d0
8860 c      s8d=0.0d0
8861 c      s12d=0.0d0
8862 c      s13d=0.0d0
8863 #ifdef MOMENT
8864       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8865      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8866 #else
8867       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8868      &               -0.5d0*ekont*(s2d+s12d)
8869 #endif
8870 C Cartesian derivatives
8871       do iii=1,2
8872         do kkk=1,5
8873           do lll=1,3
8874 #ifdef MOMENT
8875             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8876             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8877             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8878 #endif
8879             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8880             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8881      &          vtemp1d(1))
8882             s2d = scalar2(b1(1,itk),vtemp1d(1))
8883 #ifdef MOMENT
8884             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8885             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8886             s8d = -(atempd(1,1)+atempd(2,2))*
8887      &           scalar2(cc(1,1,itl),vtemp2(1))
8888 #endif
8889             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8890      &           auxmatd(1,1))
8891             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8892             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8893 c      s1d=0.0d0
8894 c      s2d=0.0d0
8895 c      s8d=0.0d0
8896 c      s12d=0.0d0
8897 c      s13d=0.0d0
8898 #ifdef MOMENT
8899             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8900      &        - 0.5d0*(s1d+s2d)
8901 #else
8902             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8903      &        - 0.5d0*s2d
8904 #endif
8905 #ifdef MOMENT
8906             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8907      &        - 0.5d0*(s8d+s12d)
8908 #else
8909             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8910      &        - 0.5d0*s12d
8911 #endif
8912           enddo
8913         enddo
8914       enddo
8915 #ifdef MOMENT
8916       do kkk=1,5
8917         do lll=1,3
8918           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8919      &      achuj_tempd(1,1))
8920           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8921           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8922           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8923           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8924           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8925      &      vtemp4d(1))
8926           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8927           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8928           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8929         enddo
8930       enddo
8931 #endif
8932 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8933 cd     &  16*eel_turn6_num
8934 cd      goto 1112
8935       if (j.lt.nres-1) then
8936         j1=j+1
8937         j2=j-1
8938       else
8939         j1=j-1
8940         j2=j-2
8941       endif
8942       if (l.lt.nres-1) then
8943         l1=l+1
8944         l2=l-1
8945       else
8946         l1=l-1
8947         l2=l-2
8948       endif
8949       do ll=1,3
8950 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
8951 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
8952 cgrad        ghalf=0.5d0*ggg1(ll)
8953 cd        ghalf=0.0d0
8954         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
8955         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
8956         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
8957      &    +ekont*derx_turn(ll,2,1)
8958         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8959         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
8960      &    +ekont*derx_turn(ll,4,1)
8961         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8962         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
8963         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
8964 cgrad        ghalf=0.5d0*ggg2(ll)
8965 cd        ghalf=0.0d0
8966         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
8967      &    +ekont*derx_turn(ll,2,2)
8968         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8969         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
8970      &    +ekont*derx_turn(ll,4,2)
8971         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8972         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
8973         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
8974       enddo
8975 cd      goto 1112
8976 cgrad      do m=i+1,j-1
8977 cgrad        do ll=1,3
8978 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8979 cgrad        enddo
8980 cgrad      enddo
8981 cgrad      do m=k+1,l-1
8982 cgrad        do ll=1,3
8983 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8984 cgrad        enddo
8985 cgrad      enddo
8986 cgrad1112  continue
8987 cgrad      do m=i+2,j2
8988 cgrad        do ll=1,3
8989 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8990 cgrad        enddo
8991 cgrad      enddo
8992 cgrad      do m=k+2,l2
8993 cgrad        do ll=1,3
8994 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8995 cgrad        enddo
8996 cgrad      enddo
8997 cd      do iii=1,nres-3
8998 cd        write (2,*) iii,g_corr6_loc(iii)
8999 cd      enddo
9000       eello_turn6=ekont*eel_turn6
9001 cd      write (2,*) 'ekont',ekont
9002 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9003       return
9004       end
9005
9006 C-----------------------------------------------------------------------------
9007       double precision function scalar(u,v)
9008 !DIR$ INLINEALWAYS scalar
9009 #ifndef OSF
9010 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9011 #endif
9012       implicit none
9013       double precision u(3),v(3)
9014 cd      double precision sc
9015 cd      integer i
9016 cd      sc=0.0d0
9017 cd      do i=1,3
9018 cd        sc=sc+u(i)*v(i)
9019 cd      enddo
9020 cd      scalar=sc
9021
9022       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9023       return
9024       end
9025 crc-------------------------------------------------
9026       SUBROUTINE MATVEC2(A1,V1,V2)
9027 !DIR$ INLINEALWAYS MATVEC2
9028 #ifndef OSF
9029 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9030 #endif
9031       implicit real*8 (a-h,o-z)
9032       include 'DIMENSIONS'
9033       DIMENSION A1(2,2),V1(2),V2(2)
9034 c      DO 1 I=1,2
9035 c        VI=0.0
9036 c        DO 3 K=1,2
9037 c    3     VI=VI+A1(I,K)*V1(K)
9038 c        Vaux(I)=VI
9039 c    1 CONTINUE
9040
9041       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9042       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9043
9044       v2(1)=vaux1
9045       v2(2)=vaux2
9046       END
9047 C---------------------------------------
9048       SUBROUTINE MATMAT2(A1,A2,A3)
9049 #ifndef OSF
9050 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9051 #endif
9052       implicit real*8 (a-h,o-z)
9053       include 'DIMENSIONS'
9054       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9055 c      DIMENSION AI3(2,2)
9056 c        DO  J=1,2
9057 c          A3IJ=0.0
9058 c          DO K=1,2
9059 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9060 c          enddo
9061 c          A3(I,J)=A3IJ
9062 c       enddo
9063 c      enddo
9064
9065       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9066       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9067       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9068       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9069
9070       A3(1,1)=AI3_11
9071       A3(2,1)=AI3_21
9072       A3(1,2)=AI3_12
9073       A3(2,2)=AI3_22
9074       END
9075
9076 c-------------------------------------------------------------------------
9077       double precision function scalar2(u,v)
9078 !DIR$ INLINEALWAYS scalar2
9079       implicit none
9080       double precision u(2),v(2)
9081       double precision sc
9082       integer i
9083       scalar2=u(1)*v(1)+u(2)*v(2)
9084       return
9085       end
9086
9087 C-----------------------------------------------------------------------------
9088
9089       subroutine transpose2(a,at)
9090 !DIR$ INLINEALWAYS transpose2
9091 #ifndef OSF
9092 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9093 #endif
9094       implicit none
9095       double precision a(2,2),at(2,2)
9096       at(1,1)=a(1,1)
9097       at(1,2)=a(2,1)
9098       at(2,1)=a(1,2)
9099       at(2,2)=a(2,2)
9100       return
9101       end
9102 c--------------------------------------------------------------------------
9103       subroutine transpose(n,a,at)
9104       implicit none
9105       integer n,i,j
9106       double precision a(n,n),at(n,n)
9107       do i=1,n
9108         do j=1,n
9109           at(j,i)=a(i,j)
9110         enddo
9111       enddo
9112       return
9113       end
9114 C---------------------------------------------------------------------------
9115       subroutine prodmat3(a1,a2,kk,transp,prod)
9116 !DIR$ INLINEALWAYS prodmat3
9117 #ifndef OSF
9118 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9119 #endif
9120       implicit none
9121       integer i,j
9122       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9123       logical transp
9124 crc      double precision auxmat(2,2),prod_(2,2)
9125
9126       if (transp) then
9127 crc        call transpose2(kk(1,1),auxmat(1,1))
9128 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9129 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9130
9131            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9132      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9133            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9134      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9135            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9136      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9137            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9138      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9139
9140       else
9141 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9142 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9143
9144            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9145      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9146            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9147      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9148            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9149      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9150            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9151      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9152
9153       endif
9154 c      call transpose2(a2(1,1),a2t(1,1))
9155
9156 crc      print *,transp
9157 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9158 crc      print *,((prod(i,j),i=1,2),j=1,2)
9159
9160       return
9161       end
9162