source/unres/src_MD-M/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       include 'COMMON.SPLITELE'
  28 #ifdef MPI
  29 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  30 c     & " nfgtasks",nfgtasks
  31       if (nfgtasks.gt.1) then
  32         time00=MPI_Wtime()
  33 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  34         if (fg_rank.eq.0) then
  35           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  36 c          print *,"Processor",myrank," BROADCAST iorder"
  37 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  38 C FG slaves as WEIGHTS array.
  39           weights_(1)=wsc
  40           weights_(2)=wscp
  41           weights_(3)=welec
  42           weights_(4)=wcorr
  43           weights_(5)=wcorr5
  44           weights_(6)=wcorr6
  45           weights_(7)=wel_loc
  46           weights_(8)=wturn3
  47           weights_(9)=wturn4
  48           weights_(10)=wturn6
  49           weights_(11)=wang
  50           weights_(12)=wscloc
  51           weights_(13)=wtor
  52           weights_(14)=wtor_d
  53           weights_(15)=wstrain
  54           weights_(16)=wvdwpp
  55           weights_(17)=wbond
  56           weights_(18)=scal14
  57           weights_(21)=wsccor
  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         endif
  85         time_Bcast=time_Bcast+MPI_Wtime()-time00
  86         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  87 c        call chainbuild_cart
  88       endif
  89 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
  90 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  91 #else
  92 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  93 c        call int_from_cart1(.false.)
  94 c      endif
  95 #endif
  96 #ifdef TIMING
  97       time00=MPI_Wtime()
  98 #endif
  99 C
 100 C Compute the side-chain and electrostatic interaction energy
 101 C
 102       goto (101,102,103,104,105,106) ipot
 103 C Lennard-Jones potential.
 104   101 call elj(evdw)
 105 cd    print '(a)','Exit ELJ'
 106       goto 107
 107 C Lennard-Jones-Kihara potential (shifted).
 108   102 call eljk(evdw)
 109       goto 107
 110 C Berne-Pechukas potential (dilated LJ, angular dependence).
 111   103 call ebp(evdw)
 112       goto 107
 113 C Gay-Berne potential (shifted LJ, angular dependence).
 114   104 call egb(evdw)
 115       goto 107
 116 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 117   105 call egbv(evdw)
 118       goto 107
 119 C Soft-sphere potential
 120   106 call e_softsphere(evdw)
 121 C
 122 C Calculate electrostatic (H-bonding) energy of the main chain.
 123 C
 124   107 continue
 125 cmc
 126 cmc Sep-06: egb takes care of dynamic ss bonds too
 127 cmc
 128 c      if (dyn_ss) call dyn_set_nss
 129
 130 c      print *,"Processor",myrank," computed USCSC"
 131 #ifdef TIMING
 132       time01=MPI_Wtime()
 133 #endif
 134       call vec_and_deriv
 135 #ifdef TIMING
 136       time_vec=time_vec+MPI_Wtime()-time01
 137 #endif
 138 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 139       if (ipot.lt.6) then
 140 #ifdef SPLITELE
 141          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 142      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 143      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 144      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 145 #else
 146          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 147      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 148      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 149      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 150 #endif
 151             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 152          else
 153             ees=0.0d0
 154             evdw1=0.0d0
 155             eel_loc=0.0d0
 156             eello_turn3=0.0d0
 157             eello_turn4=0.0d0
 158          endif
 159       else
 160         write (iout,*) "Soft-spheer ELEC potential"
 161 c        call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 162 c     &   eello_turn4)
 163       endif
 164 c      print *,"Processor",myrank," computed UELEC"
 165 C
 166 C Calculate excluded-volume interaction energy between peptide groups
 167 C and side chains.
 168 C
 169       if (ipot.lt.6) then
 170        if(wscp.gt.0d0) then
 171         call escp(evdw2,evdw2_14)
 172        else
 173         evdw2=0
 174         evdw2_14=0
 175        endif
 176       else
 177 c        write (iout,*) "Soft-sphere SCP potential"
 178         call escp_soft_sphere(evdw2,evdw2_14)
 179       endif
 180 c
 181 c Calculate the bond-stretching energy
 182 c
 183       call ebond(estr)
 184 C
 185 C Calculate the disulfide-bridge and other energy and the contributions
 186 C from other distance constraints.
 187 cd    print *,'Calling EHPB'
 188       call edis(ehpb)
 189 cd    print *,'EHPB exitted succesfully.'
 190 C
 191 C Calculate the virtual-bond-angle energy.
 192 C
 193       if (wang.gt.0d0) then
 194         call ebend(ebe)
 195       else
 196         ebe=0
 197       endif
 198 c      print *,"Processor",myrank," computed UB"
 199 C
 200 C Calculate the SC local energy.
 201 C
 202       call esc(escloc)
 203 c      print *,"Processor",myrank," computed USC"
 204 C
 205 C Calculate the virtual-bond torsional energy.
 206 C
 207 cd    print *,'nterm=',nterm
 208       if (wtor.gt.0) then
 209        call etor(etors,edihcnstr)
 210       else
 211        etors=0
 212        edihcnstr=0
 213       endif
 214 c      print *,"Processor",myrank," computed Utor"
 215 C
 216 C 6/23/01 Calculate double-torsional energy
 217 C
 218       if (wtor_d.gt.0) then
 219        call etor_d(etors_d)
 220       else
 221        etors_d=0
 222       endif
 223 c      print *,"Processor",myrank," computed Utord"
 224 C
 225 C 21/5/07 Calculate local sicdechain correlation energy
 226 C
 227       if (wsccor.gt.0.0d0) then
 228         call eback_sc_corr(esccor)
 229       else
 230         esccor=0.0d0
 231       endif
 232 c      print *,"Processor",myrank," computed Usccorr"
 233 C
 234 C 12/1/95 Multi-body terms
 235 C
 236       n_corr=0
 237       n_corr1=0
 238       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 239      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 240          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 241 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 242 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 243       else
 244          ecorr=0.0d0
 245          ecorr5=0.0d0
 246          ecorr6=0.0d0
 247          eturn6=0.0d0
 248       endif
 249       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 250          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 251 cd         write (iout,*) "multibody_hb ecorr",ecorr
 252       endif
 253 c      print *,"Processor",myrank," computed Ucorr"
 254 C
 255 C If performing constraint dynamics, call the constraint energy
 256 C  after the equilibration time
 257       if(usampl.and.totT.gt.eq_time) then
 258          call EconstrQ
 259          call Econstr_back
 260       else
 261          Uconst=0.0d0
 262          Uconst_back=0.0d0
 263       endif
 264 C 01/27/2015 added by adasko
 265 C the energy component below is energy transfer into lipid environment
 266 C based on partition function
 267       if (wliptran.gt.0) then
 268         call Eliptransfer
 269       endif
 270 #ifdef TIMING
 271       time_enecalc=time_enecalc+MPI_Wtime()-time00
 272 #endif
 273 c      print *,"Processor",myrank," computed Uconstr"
 274 #ifdef TIMING
 275       time00=MPI_Wtime()
 276 #endif
 277 c
 278 C Sum the energies
 279 C
 280       energia(1)=evdw
 281 #ifdef SCP14
 282       energia(2)=evdw2-evdw2_14
 283       energia(18)=evdw2_14
 284 #else
 285       energia(2)=evdw2
 286       energia(18)=0.0d0
 287 #endif
 288 #ifdef SPLITELE
 289       energia(3)=ees
 290       energia(16)=evdw1
 291 #else
 292       energia(3)=ees+evdw1
 293       energia(16)=0.0d0
 294 #endif
 295       energia(4)=ecorr
 296       energia(5)=ecorr5
 297       energia(6)=ecorr6
 298       energia(7)=eel_loc
 299       energia(8)=eello_turn3
 300       energia(9)=eello_turn4
 301       energia(10)=eturn6
 302       energia(11)=ebe
 303       energia(12)=escloc
 304       energia(13)=etors
 305       energia(14)=etors_d
 306       energia(15)=ehpb
 307       energia(19)=edihcnstr
 308       energia(17)=estr
 309       energia(20)=Uconst+Uconst_back
 310       energia(21)=esccor
 311       energia(22)=eliptrans
 312 c    Here are the energies showed per procesor if the are more processors
 313 c    per molecule then we sum it up in sum_energy subroutine
 314 c      print *," Processor",myrank," calls SUM_ENERGY"
 315       call sum_energy(energia,.true.)
 316       if (dyn_ss) call dyn_set_nss
 317 c      print *," Processor",myrank," left SUM_ENERGY"
 318 #ifdef TIMING
 319       time_sumene=time_sumene+MPI_Wtime()-time00
 320 #endif
 321       return
 322       end
 323 c-------------------------------------------------------------------------------
 324       subroutine sum_energy(energia,reduce)
 325       implicit real*8 (a-h,o-z)
 326       include 'DIMENSIONS'
 327 #ifndef ISNAN
 328       external proc_proc
 329 #ifdef WINPGI
 330 cMS$ATTRIBUTES C ::  proc_proc
 331 #endif
 332 #endif
 333 #ifdef MPI
 334       include "mpif.h"
 335 #endif
 336       include 'COMMON.SETUP'
 337       include 'COMMON.IOUNITS'
 338       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 339       include 'COMMON.FFIELD'
 340       include 'COMMON.DERIV'
 341       include 'COMMON.INTERACT'
 342       include 'COMMON.SBRIDGE'
 343       include 'COMMON.CHAIN'
 344       include 'COMMON.VAR'
 345       include 'COMMON.CONTROL'
 346       include 'COMMON.TIME1'
 347       logical reduce
 348 #ifdef MPI
 349       if (nfgtasks.gt.1 .and. reduce) then
 350 #ifdef DEBUG
 351         write (iout,*) "energies before REDUCE"
 352         call enerprint(energia)
 353         call flush(iout)
 354 #endif
 355         do i=0,n_ene
 356           enebuff(i)=energia(i)
 357         enddo
 358         time00=MPI_Wtime()
 359         call MPI_Barrier(FG_COMM,IERR)
 360         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 361         time00=MPI_Wtime()
 362         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 363      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 364 #ifdef DEBUG
 365         write (iout,*) "energies after REDUCE"
 366         call enerprint(energia)
 367         call flush(iout)
 368 #endif
 369         time_Reduce=time_Reduce+MPI_Wtime()-time00
 370       endif
 371       if (fg_rank.eq.0) then
 372 #endif
 373       evdw=energia(1)
 374 #ifdef SCP14
 375       evdw2=energia(2)+energia(18)
 376       evdw2_14=energia(18)
 377 #else
 378       evdw2=energia(2)
 379 #endif
 380 #ifdef SPLITELE
 381       ees=energia(3)
 382       evdw1=energia(16)
 383 #else
 384       ees=energia(3)
 385       evdw1=0.0d0
 386 #endif
 387       ecorr=energia(4)
 388       ecorr5=energia(5)
 389       ecorr6=energia(6)
 390       eel_loc=energia(7)
 391       eello_turn3=energia(8)
 392       eello_turn4=energia(9)
 393       eturn6=energia(10)
 394       ebe=energia(11)
 395       escloc=energia(12)
 396       etors=energia(13)
 397       etors_d=energia(14)
 398       ehpb=energia(15)
 399       edihcnstr=energia(19)
 400       estr=energia(17)
 401       Uconst=energia(20)
 402       esccor=energia(21)
 403       energia(22)=eliptrans
 404 #ifdef SPLITELE
 405       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 406      & +wang*ebe+wtor*etors+wscloc*escloc
 407      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 408      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 409      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 410      & +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran
 411 #else
 412       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 413      & +wang*ebe+wtor*etors+wscloc*escloc
 414      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 415      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 416      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 417      & +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran
 418 #endif
 419       energia(0)=etot
 420 c detecting NaNQ
 421 #ifdef ISNAN
 422 #ifdef AIX
 423       if (isnan(etot).ne.0) energia(0)=1.0d+99
 424 #else
 425       if (isnan(etot)) energia(0)=1.0d+99
 426 #endif
 427 #else
 428       i=0
 429 #ifdef WINPGI
 430       idumm=proc_proc(etot,i)
 431 #else
 432       call proc_proc(etot,i)
 433 #endif
 434       if(i.eq.1)energia(0)=1.0d+99
 435 #endif
 436 #ifdef MPI
 437       endif
 438 #endif
 439       return
 440       end
 441 c-------------------------------------------------------------------------------
 442       subroutine sum_gradient
 443       implicit real*8 (a-h,o-z)
 444       include 'DIMENSIONS'
 445 #ifndef ISNAN
 446       external proc_proc
 447 #ifdef WINPGI
 448 cMS$ATTRIBUTES C ::  proc_proc
 449 #endif
 450 #endif
 451 #ifdef MPI
 452       include 'mpif.h'
 453 #endif
 454       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 455      &  glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres)
 456       include 'COMMON.SETUP'
 457       include 'COMMON.IOUNITS'
 458       include 'COMMON.FFIELD'
 459       include 'COMMON.DERIV'
 460       include 'COMMON.INTERACT'
 461       include 'COMMON.SBRIDGE'
 462       include 'COMMON.CHAIN'
 463       include 'COMMON.VAR'
 464       include 'COMMON.CONTROL'
 465       include 'COMMON.TIME1'
 466       include 'COMMON.MAXGRAD'
 467       include 'COMMON.SCCOR'
 468 #ifdef TIMING
 469       time01=MPI_Wtime()
 470 #endif
 471 #ifdef DEBUG
 472       write (iout,*) "sum_gradient gvdwc, gvdwx"
 473       do i=1,nres
 474         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 475      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 476       enddo
 477       call flush(iout)
 478 #endif
 479 #ifdef MPI
 480 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 481         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 482      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 483 #endif
 484 C
 485 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 486 C            in virtual-bond-vector coordinates
 487 C
 488 #ifdef DEBUG
 489 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 490 c      do i=1,nres-1
 491 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 492 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 493 c      enddo
 494 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 495 c      do i=1,nres-1
 496 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 497 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 498 c      enddo
 499       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 500       do i=1,nres
 501         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 502      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 503      &   g_corr5_loc(i)
 504       enddo
 505       call flush(iout)
 506 #endif
 507 #ifdef SPLITELE
 508       do i=1,nct
 509         do j=1,3
 510           gradbufc(j,i)=wsc*gvdwc(j,i)+
 511      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 512      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 513      &                wel_loc*gel_loc_long(j,i)+
 514      &                wcorr*gradcorr_long(j,i)+
 515      &                wcorr5*gradcorr5_long(j,i)+
 516      &                wcorr6*gradcorr6_long(j,i)+
 517      &                wturn6*gcorr6_turn_long(j,i)+
 518      &                wstrain*ghpbc(j,i)
 519         enddo
 520       enddo
 521 #else
 522       do i=1,nct
 523         do j=1,3
 524           gradbufc(j,i)=wsc*gvdwc(j,i)+
 525      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 526      &                welec*gelc_long(j,i)+
 527      &                wbond*gradb(j,i)+
 528      &                wel_loc*gel_loc_long(j,i)+
 529      &                wcorr*gradcorr_long(j,i)+
 530      &                wcorr5*gradcorr5_long(j,i)+
 531      &                wcorr6*gradcorr6_long(j,i)+
 532      &                wturn6*gcorr6_turn_long(j,i)+
 533      &                wstrain*ghpbc(j,i)
 534         enddo
 535       enddo
 536 #endif
 537 #ifdef MPI
 538       if (nfgtasks.gt.1) then
 539       time00=MPI_Wtime()
 540 #ifdef DEBUG
 541       write (iout,*) "gradbufc before allreduce"
 542       do i=1,nres
 543         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 544       enddo
 545       call flush(iout)
 546 #endif
 547       do i=1,nres
 548         do j=1,3
 549           gradbufc_sum(j,i)=gradbufc(j,i)
 550         enddo
 551       enddo
 552 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 553 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 554 c      time_reduce=time_reduce+MPI_Wtime()-time00
 555 #ifdef DEBUG
 556 c      write (iout,*) "gradbufc_sum after allreduce"
 557 c      do i=1,nres
 558 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 559 c      enddo
 560 c      call flush(iout)
 561 #endif
 562 #ifdef TIMING
 563 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 564 #endif
 565       do i=nnt,nres
 566         do k=1,3
 567           gradbufc(k,i)=0.0d0
 568         enddo
 569       enddo
 570 #ifdef DEBUG
 571       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 572       write (iout,*) (i," jgrad_start",jgrad_start(i),
 573      &                  " jgrad_end  ",jgrad_end(i),
 574      &                  i=igrad_start,igrad_end)
 575 #endif
 576 c
 577 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 578 c do not parallelize this part.
 579 c
 580 c      do i=igrad_start,igrad_end
 581 c        do j=jgrad_start(i),jgrad_end(i)
 582 c          do k=1,3
 583 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 584 c          enddo
 585 c        enddo
 586 c      enddo
 587       do j=1,3
 588         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 589       enddo
 590       do i=nres-2,nnt,-1
 591         do j=1,3
 592           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 593         enddo
 594       enddo
 595 #ifdef DEBUG
 596       write (iout,*) "gradbufc after summing"
 597       do i=1,nres
 598         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 599       enddo
 600       call flush(iout)
 601 #endif
 602       else
 603 #endif
 604 #ifdef DEBUG
 605       write (iout,*) "gradbufc"
 606       do i=1,nres
 607         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 608       enddo
 609       call flush(iout)
 610 #endif
 611       do i=1,nres
 612         do j=1,3
 613           gradbufc_sum(j,i)=gradbufc(j,i)
 614           gradbufc(j,i)=0.0d0
 615         enddo
 616       enddo
 617       do j=1,3
 618         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 619       enddo
 620       do i=nres-2,nnt,-1
 621         do j=1,3
 622           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 623         enddo
 624       enddo
 625 c      do i=nnt,nres-1
 626 c        do k=1,3
 627 c          gradbufc(k,i)=0.0d0
 628 c        enddo
 629 c        do j=i+1,nres
 630 c          do k=1,3
 631 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 632 c          enddo
 633 c        enddo
 634 c      enddo
 635 #ifdef DEBUG
 636       write (iout,*) "gradbufc after summing"
 637       do i=1,nres
 638         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 639       enddo
 640       call flush(iout)
 641 #endif
 642 #ifdef MPI
 643       endif
 644 #endif
 645       do k=1,3
 646         gradbufc(k,nres)=0.0d0
 647       enddo
 648       do i=1,nct
 649         do j=1,3
 650 #ifdef SPLITELE
 651           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 652      &                wel_loc*gel_loc(j,i)+
 653      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 654      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 655      &                wel_loc*gel_loc_long(j,i)+
 656      &                wcorr*gradcorr_long(j,i)+
 657      &                wcorr5*gradcorr5_long(j,i)+
 658      &                wcorr6*gradcorr6_long(j,i)+
 659      &                wturn6*gcorr6_turn_long(j,i))+
 660      &                wbond*gradb(j,i)+
 661      &                wcorr*gradcorr(j,i)+
 662      &                wturn3*gcorr3_turn(j,i)+
 663      &                wturn4*gcorr4_turn(j,i)+
 664      &                wcorr5*gradcorr5(j,i)+
 665      &                wcorr6*gradcorr6(j,i)+
 666      &                wturn6*gcorr6_turn(j,i)+
 667      &                wsccor*gsccorc(j,i)
 668      &               +wscloc*gscloc(j,i)
 669      &               +wliptran*gliptranc(j,i)
 670 #else
 671           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 672      &                wel_loc*gel_loc(j,i)+
 673      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 674      &                welec*gelc_long(j,i)
 675      &                wel_loc*gel_loc_long(j,i)+
 676      &                wcorr*gcorr_long(j,i)+
 677      &                wcorr5*gradcorr5_long(j,i)+
 678      &                wcorr6*gradcorr6_long(j,i)+
 679      &                wturn6*gcorr6_turn_long(j,i))+
 680      &                wbond*gradb(j,i)+
 681      &                wcorr*gradcorr(j,i)+
 682      &                wturn3*gcorr3_turn(j,i)+
 683      &                wturn4*gcorr4_turn(j,i)+
 684      &                wcorr5*gradcorr5(j,i)+
 685      &                wcorr6*gradcorr6(j,i)+
 686      &                wturn6*gcorr6_turn(j,i)+
 687      &                wsccor*gsccorc(j,i)
 688      &               +wscloc*gscloc(j,i)
 689      &               +wliptran*gliptranc(j,i)
 690 #endif
 691           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 692      &                  wbond*gradbx(j,i)+
 693      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 694      &                  wsccor*gsccorx(j,i)
 695      &                 +wscloc*gsclocx(j,i)
 696      &                 +wliptran*gliptranx(j,i)
 697         enddo
 698       enddo
 699 #ifdef DEBUG
 700       write (iout,*) "gloc before adding corr"
 701       do i=1,4*nres
 702         write (iout,*) i,gloc(i,icg)
 703       enddo
 704 #endif
 705       do i=1,nres-3
 706         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 707      &   +wcorr5*g_corr5_loc(i)
 708      &   +wcorr6*g_corr6_loc(i)
 709      &   +wturn4*gel_loc_turn4(i)
 710      &   +wturn3*gel_loc_turn3(i)
 711      &   +wturn6*gel_loc_turn6(i)
 712      &   +wel_loc*gel_loc_loc(i)
 713       enddo
 714 #ifdef DEBUG
 715       write (iout,*) "gloc after adding corr"
 716       do i=1,4*nres
 717         write (iout,*) i,gloc(i,icg)
 718       enddo
 719 #endif
 720 #ifdef MPI
 721       if (nfgtasks.gt.1) then
 722         do j=1,3
 723           do i=1,nres
 724             gradbufc(j,i)=gradc(j,i,icg)
 725             gradbufx(j,i)=gradx(j,i,icg)
 726           enddo
 727         enddo
 728         do i=1,4*nres
 729           glocbuf(i)=gloc(i,icg)
 730         enddo
 731 c#define DEBUG
 732 #ifdef DEBUG
 733       write (iout,*) "gloc_sc before reduce"
 734       do i=1,nres
 735        do j=1,1
 736         write (iout,*) i,j,gloc_sc(j,i,icg)
 737        enddo
 738       enddo
 739 #endif
 740 c#undef DEBUG
 741         do i=1,nres
 742          do j=1,3
 743           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 744          enddo
 745         enddo
 746         time00=MPI_Wtime()
 747         call MPI_Barrier(FG_COMM,IERR)
 748         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 749         time00=MPI_Wtime()
 750         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 751      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 752         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 753      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 754         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 755      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 756         time_reduce=time_reduce+MPI_Wtime()-time00
 757         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 758      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 759         time_reduce=time_reduce+MPI_Wtime()-time00
 760 c#define DEBUG
 761 #ifdef DEBUG
 762       write (iout,*) "gloc_sc after reduce"
 763       do i=1,nres
 764        do j=1,1
 765         write (iout,*) i,j,gloc_sc(j,i,icg)
 766        enddo
 767       enddo
 768 #endif
 769 c#undef DEBUG
 770 #ifdef DEBUG
 771       write (iout,*) "gloc after reduce"
 772       do i=1,4*nres
 773         write (iout,*) i,gloc(i,icg)
 774       enddo
 775 #endif
 776       endif
 777 #endif
 778       if (gnorm_check) then
 779 c
 780 c Compute the maximum elements of the gradient
 781 c
 782       gvdwc_max=0.0d0
 783       gvdwc_scp_max=0.0d0
 784       gelc_max=0.0d0
 785       gvdwpp_max=0.0d0
 786       gradb_max=0.0d0
 787       ghpbc_max=0.0d0
 788       gradcorr_max=0.0d0
 789       gel_loc_max=0.0d0
 790       gcorr3_turn_max=0.0d0
 791       gcorr4_turn_max=0.0d0
 792       gradcorr5_max=0.0d0
 793       gradcorr6_max=0.0d0
 794       gcorr6_turn_max=0.0d0
 795       gsccorc_max=0.0d0
 796       gscloc_max=0.0d0
 797       gvdwx_max=0.0d0
 798       gradx_scp_max=0.0d0
 799       ghpbx_max=0.0d0
 800       gradxorr_max=0.0d0
 801       gsccorx_max=0.0d0
 802       gsclocx_max=0.0d0
 803       do i=1,nct
 804         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 805         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 806         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 807         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 808      &   gvdwc_scp_max=gvdwc_scp_norm
 809         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 810         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 811         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 812         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 813         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 814         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 815         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 816         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 817         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 818         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 819         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 820         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 821         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 822      &    gcorr3_turn(1,i)))
 823         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 824      &    gcorr3_turn_max=gcorr3_turn_norm
 825         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 826      &    gcorr4_turn(1,i)))
 827         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 828      &    gcorr4_turn_max=gcorr4_turn_norm
 829         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 830         if (gradcorr5_norm.gt.gradcorr5_max)
 831      &    gradcorr5_max=gradcorr5_norm
 832         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 833         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 834         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 835      &    gcorr6_turn(1,i)))
 836         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 837      &    gcorr6_turn_max=gcorr6_turn_norm
 838         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 839         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 840         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 841         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 842         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 843         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 844         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 845         if (gradx_scp_norm.gt.gradx_scp_max)
 846      &    gradx_scp_max=gradx_scp_norm
 847         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 848         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 849         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 850         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 851         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 852         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 853         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 854         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 855       enddo
 856       if (gradout) then
 857 #ifdef AIX
 858         open(istat,file=statname,position="append")
 859 #else
 860         open(istat,file=statname,access="append")
 861 #endif
 862         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 863      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 864      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 865      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 866      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 867      &     gsccorx_max,gsclocx_max
 868         close(istat)
 869         if (gvdwc_max.gt.1.0d4) then
 870           write (iout,*) "gvdwc gvdwx gradb gradbx"
 871           do i=nnt,nct
 872             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 873      &        gradb(j,i),gradbx(j,i),j=1,3)
 874           enddo
 875           call pdbout(0.0d0,'cipiszcze',iout)
 876           call flush(iout)
 877         endif
 878       endif
 879       endif
 880 #ifdef DEBUG
 881       write (iout,*) "gradc gradx gloc"
 882       do i=1,nres
 883         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 884      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 885       enddo
 886 #endif
 887 #ifdef TIMING
 888       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 889 #endif
 890       return
 891       end
 892 c-------------------------------------------------------------------------------
 893       subroutine rescale_weights(t_bath)
 894       implicit real*8 (a-h,o-z)
 895       include 'DIMENSIONS'
 896       include 'COMMON.IOUNITS'
 897       include 'COMMON.FFIELD'
 898       include 'COMMON.SBRIDGE'
 899       double precision kfac /2.4d0/
 900       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 901 c      facT=temp0/t_bath
 902 c      facT=2*temp0/(t_bath+temp0)
 903       if (rescale_mode.eq.0) then
 904         facT=1.0d0
 905         facT2=1.0d0
 906         facT3=1.0d0
 907         facT4=1.0d0
 908         facT5=1.0d0
 909       else if (rescale_mode.eq.1) then
 910         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 911         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 912         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 913         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 914         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 915       else if (rescale_mode.eq.2) then
 916         x=t_bath/temp0
 917         x2=x*x
 918         x3=x2*x
 919         x4=x3*x
 920         x5=x4*x
 921         facT=licznik/dlog(dexp(x)+dexp(-x))
 922         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 923         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 924         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 925         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 926       else
 927         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 928         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 929 #ifdef MPI
 930        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 931 #endif
 932        stop 555
 933       endif
 934       welec=weights(3)*fact
 935       wcorr=weights(4)*fact3
 936       wcorr5=weights(5)*fact4
 937       wcorr6=weights(6)*fact5
 938       wel_loc=weights(7)*fact2
 939       wturn3=weights(8)*fact2
 940       wturn4=weights(9)*fact3
 941       wturn6=weights(10)*fact5
 942       wtor=weights(13)*fact
 943       wtor_d=weights(14)*fact2
 944       wsccor=weights(21)*fact
 945
 946       return
 947       end
 948 C------------------------------------------------------------------------
 949       subroutine enerprint(energia)
 950       implicit real*8 (a-h,o-z)
 951       include 'DIMENSIONS'
 952       include 'COMMON.IOUNITS'
 953       include 'COMMON.FFIELD'
 954       include 'COMMON.SBRIDGE'
 955       include 'COMMON.MD'
 956       double precision energia(0:n_ene)
 957       etot=energia(0)
 958       evdw=energia(1)
 959       evdw2=energia(2)
 960 #ifdef SCP14
 961       evdw2=energia(2)+energia(18)
 962 #else
 963       evdw2=energia(2)
 964 #endif
 965       ees=energia(3)
 966 #ifdef SPLITELE
 967       evdw1=energia(16)
 968 #endif
 969       ecorr=energia(4)
 970       ecorr5=energia(5)
 971       ecorr6=energia(6)
 972       eel_loc=energia(7)
 973       eello_turn3=energia(8)
 974       eello_turn4=energia(9)
 975       eello_turn6=energia(10)
 976       ebe=energia(11)
 977       escloc=energia(12)
 978       etors=energia(13)
 979       etors_d=energia(14)
 980       ehpb=energia(15)
 981       edihcnstr=energia(19)
 982       estr=energia(17)
 983       Uconst=energia(20)
 984       esccor=energia(21)
 985 #ifdef SPLITELE
 986       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
 987      &  estr,wbond,ebe,wang,
 988      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 989      &  ecorr,wcorr,
 990      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 991      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
 992      &  edihcnstr,ebr*nss,
 993      &  Uconst,etot
 994    10 format (/'Virtual-chain energies:'//
 995      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 996      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 997      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 998      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 999      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1000      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1001      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1002      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1003      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1004      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1005      & ' (SS bridges & dist. cnstr.)'/
1006      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1007      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1008      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1009      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1010      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1011      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1012      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1013      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1014      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1015      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1016      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1017      & 'ETOT=  ',1pE16.6,' (total)')
1018 #else
1019       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1020      &  estr,wbond,ebe,wang,
1021      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1022      &  ecorr,wcorr,
1023      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1024      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1025      &  ebr*nss,Uconst,etot
1026    10 format (/'Virtual-chain energies:'//
1027      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1028      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1029      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1030      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1031      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1032      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1033      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1034      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1035      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1036      & ' (SS bridges & dist. cnstr.)'/
1037      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1038      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1039      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1040      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1041      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1042      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1043      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1044      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1045      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1046      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1047      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1048      & 'ETOT=  ',1pE16.6,' (total)')
1049 #endif
1050       return
1051       end
1052 C-----------------------------------------------------------------------
1053       subroutine elj(evdw)
1054 C
1055 C This subroutine calculates the interaction energy of nonbonded side chains
1056 C assuming the LJ potential of interaction.
1057 C
1058       implicit real*8 (a-h,o-z)
1059       include 'DIMENSIONS'
1060       parameter (accur=1.0d-10)
1061       include 'COMMON.GEO'
1062       include 'COMMON.VAR'
1063       include 'COMMON.LOCAL'
1064       include 'COMMON.CHAIN'
1065       include 'COMMON.DERIV'
1066       include 'COMMON.INTERACT'
1067       include 'COMMON.TORSION'
1068       include 'COMMON.SBRIDGE'
1069       include 'COMMON.NAMES'
1070       include 'COMMON.IOUNITS'
1071       include 'COMMON.CONTACTS'
1072       dimension gg(3)
1073 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1074       evdw=0.0D0
1075       do i=iatsc_s,iatsc_e
1076         itypi=iabs(itype(i))
1077         if (itypi.eq.ntyp1) cycle
1078         itypi1=iabs(itype(i+1))
1079         xi=c(1,nres+i)
1080         yi=c(2,nres+i)
1081         zi=c(3,nres+i)
1082 C Change 12/1/95
1083         num_conti=0
1084 C
1085 C Calculate SC interaction energy.
1086 C
1087         do iint=1,nint_gr(i)
1088 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1089 cd   &                  'iend=',iend(i,iint)
1090           do j=istart(i,iint),iend(i,iint)
1091             itypj=iabs(itype(j))
1092             if (itypj.eq.ntyp1) cycle
1093             xj=c(1,nres+j)-xi
1094             yj=c(2,nres+j)-yi
1095             zj=c(3,nres+j)-zi
1096 C Change 12/1/95 to calculate four-body interactions
1097             rij=xj*xj+yj*yj+zj*zj
1098             rrij=1.0D0/rij
1099 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1100             eps0ij=eps(itypi,itypj)
1101             fac=rrij**expon2
1102             e1=fac*fac*aa(itypi,itypj)
1103             e2=fac*bb(itypi,itypj)
1104             evdwij=e1+e2
1105 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1106 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1107 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1108 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1109 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1110 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1111             evdw=evdw+evdwij
1112 C
1113 C Calculate the components of the gradient in DC and X
1114 C
1115             fac=-rrij*(e1+evdwij)
1116             gg(1)=xj*fac
1117             gg(2)=yj*fac
1118             gg(3)=zj*fac
1119             do k=1,3
1120               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1121               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1122               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1123               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1124             enddo
1125 cgrad            do k=i,j-1
1126 cgrad              do l=1,3
1127 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1128 cgrad              enddo
1129 cgrad            enddo
1130 C
1131 C 12/1/95, revised on 5/20/97
1132 C
1133 C Calculate the contact function. The ith column of the array JCONT will
1134 C contain the numbers of atoms that make contacts with the atom I (of numbers
1135 C greater than I). The arrays FACONT and GACONT will contain the values of
1136 C the contact function and its derivative.
1137 C
1138 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1139 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1140 C Uncomment next line, if the correlation interactions are contact function only
1141             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1142               rij=dsqrt(rij)
1143               sigij=sigma(itypi,itypj)
1144               r0ij=rs0(itypi,itypj)
1145 C
1146 C Check whether the SC's are not too far to make a contact.
1147 C
1148               rcut=1.5d0*r0ij
1149               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1150 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1151 C
1152               if (fcont.gt.0.0D0) then
1153 C If the SC-SC distance if close to sigma, apply spline.
1154 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1155 cAdam &             fcont1,fprimcont1)
1156 cAdam           fcont1=1.0d0-fcont1
1157 cAdam           if (fcont1.gt.0.0d0) then
1158 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1159 cAdam             fcont=fcont*fcont1
1160 cAdam           endif
1161 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1162 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1163 cga             do k=1,3
1164 cga               gg(k)=gg(k)*eps0ij
1165 cga             enddo
1166 cga             eps0ij=-evdwij*eps0ij
1167 C Uncomment for AL's type of SC correlation interactions.
1168 cadam           eps0ij=-evdwij
1169                 num_conti=num_conti+1
1170                 jcont(num_conti,i)=j
1171                 facont(num_conti,i)=fcont*eps0ij
1172                 fprimcont=eps0ij*fprimcont/rij
1173                 fcont=expon*fcont
1174 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1175 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1176 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1177 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1178                 gacont(1,num_conti,i)=-fprimcont*xj
1179                 gacont(2,num_conti,i)=-fprimcont*yj
1180                 gacont(3,num_conti,i)=-fprimcont*zj
1181 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1182 cd              write (iout,'(2i3,3f10.5)')
1183 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1184               endif
1185             endif
1186           enddo      ! j
1187         enddo        ! iint
1188 C Change 12/1/95
1189         num_cont(i)=num_conti
1190       enddo          ! i
1191       do i=1,nct
1192         do j=1,3
1193           gvdwc(j,i)=expon*gvdwc(j,i)
1194           gvdwx(j,i)=expon*gvdwx(j,i)
1195         enddo
1196       enddo
1197 C******************************************************************************
1198 C
1199 C                              N O T E !!!
1200 C
1201 C To save time, the factor of EXPON has been extracted from ALL components
1202 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1203 C use!
1204 C
1205 C******************************************************************************
1206       return
1207       end
1208 C-----------------------------------------------------------------------------
1209       subroutine eljk(evdw)
1210 C
1211 C This subroutine calculates the interaction energy of nonbonded side chains
1212 C assuming the LJK potential of interaction.
1213 C
1214       implicit real*8 (a-h,o-z)
1215       include 'DIMENSIONS'
1216       include 'COMMON.GEO'
1217       include 'COMMON.VAR'
1218       include 'COMMON.LOCAL'
1219       include 'COMMON.CHAIN'
1220       include 'COMMON.DERIV'
1221       include 'COMMON.INTERACT'
1222       include 'COMMON.IOUNITS'
1223       include 'COMMON.NAMES'
1224       dimension gg(3)
1225       logical scheck
1226 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1227       evdw=0.0D0
1228       do i=iatsc_s,iatsc_e
1229         itypi=iabs(itype(i))
1230         if (itypi.eq.ntyp1) cycle
1231         itypi1=iabs(itype(i+1))
1232         xi=c(1,nres+i)
1233         yi=c(2,nres+i)
1234         zi=c(3,nres+i)
1235 C
1236 C Calculate SC interaction energy.
1237 C
1238         do iint=1,nint_gr(i)
1239           do j=istart(i,iint),iend(i,iint)
1240             itypj=iabs(itype(j))
1241             if (itypj.eq.ntyp1) cycle
1242             xj=c(1,nres+j)-xi
1243             yj=c(2,nres+j)-yi
1244             zj=c(3,nres+j)-zi
1245             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1246             fac_augm=rrij**expon
1247             e_augm=augm(itypi,itypj)*fac_augm
1248             r_inv_ij=dsqrt(rrij)
1249             rij=1.0D0/r_inv_ij
1250             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1251             fac=r_shift_inv**expon
1252             e1=fac*fac*aa(itypi,itypj)
1253             e2=fac*bb(itypi,itypj)
1254             evdwij=e_augm+e1+e2
1255 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1256 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1257 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1258 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1259 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1260 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1261 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1262             evdw=evdw+evdwij
1263 C
1264 C Calculate the components of the gradient in DC and X
1265 C
1266             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1267             gg(1)=xj*fac
1268             gg(2)=yj*fac
1269             gg(3)=zj*fac
1270             do k=1,3
1271               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1272               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1273               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1274               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1275             enddo
1276 cgrad            do k=i,j-1
1277 cgrad              do l=1,3
1278 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1279 cgrad              enddo
1280 cgrad            enddo
1281           enddo      ! j
1282         enddo        ! iint
1283       enddo          ! i
1284       do i=1,nct
1285         do j=1,3
1286           gvdwc(j,i)=expon*gvdwc(j,i)
1287           gvdwx(j,i)=expon*gvdwx(j,i)
1288         enddo
1289       enddo
1290       return
1291       end
1292 C-----------------------------------------------------------------------------
1293       subroutine ebp(evdw)
1294 C
1295 C This subroutine calculates the interaction energy of nonbonded side chains
1296 C assuming the Berne-Pechukas potential of interaction.
1297 C
1298       implicit real*8 (a-h,o-z)
1299       include 'DIMENSIONS'
1300       include 'COMMON.GEO'
1301       include 'COMMON.VAR'
1302       include 'COMMON.LOCAL'
1303       include 'COMMON.CHAIN'
1304       include 'COMMON.DERIV'
1305       include 'COMMON.NAMES'
1306       include 'COMMON.INTERACT'
1307       include 'COMMON.IOUNITS'
1308       include 'COMMON.CALC'
1309       common /srutu/ icall
1310 c     double precision rrsave(maxdim)
1311       logical lprn
1312       evdw=0.0D0
1313 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1314       evdw=0.0D0
1315 c     if (icall.eq.0) then
1316 c       lprn=.true.
1317 c     else
1318         lprn=.false.
1319 c     endif
1320       ind=0
1321       do i=iatsc_s,iatsc_e
1322         itypi=iabs(itype(i))
1323         if (itypi.eq.ntyp1) cycle
1324         itypi1=iabs(itype(i+1))
1325         xi=c(1,nres+i)
1326         yi=c(2,nres+i)
1327         zi=c(3,nres+i)
1328         dxi=dc_norm(1,nres+i)
1329         dyi=dc_norm(2,nres+i)
1330         dzi=dc_norm(3,nres+i)
1331 c        dsci_inv=dsc_inv(itypi)
1332         dsci_inv=vbld_inv(i+nres)
1333 C
1334 C Calculate SC interaction energy.
1335 C
1336         do iint=1,nint_gr(i)
1337           do j=istart(i,iint),iend(i,iint)
1338             ind=ind+1
1339             itypj=iabs(itype(j))
1340             if (itypj.eq.ntyp1) cycle
1341 c            dscj_inv=dsc_inv(itypj)
1342             dscj_inv=vbld_inv(j+nres)
1343             chi1=chi(itypi,itypj)
1344             chi2=chi(itypj,itypi)
1345             chi12=chi1*chi2
1346             chip1=chip(itypi)
1347             chip2=chip(itypj)
1348             chip12=chip1*chip2
1349             alf1=alp(itypi)
1350             alf2=alp(itypj)
1351             alf12=0.5D0*(alf1+alf2)
1352 C For diagnostics only!!!
1353 c           chi1=0.0D0
1354 c           chi2=0.0D0
1355 c           chi12=0.0D0
1356 c           chip1=0.0D0
1357 c           chip2=0.0D0
1358 c           chip12=0.0D0
1359 c           alf1=0.0D0
1360 c           alf2=0.0D0
1361 c           alf12=0.0D0
1362             xj=c(1,nres+j)-xi
1363             yj=c(2,nres+j)-yi
1364             zj=c(3,nres+j)-zi
1365             dxj=dc_norm(1,nres+j)
1366             dyj=dc_norm(2,nres+j)
1367             dzj=dc_norm(3,nres+j)
1368             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1369 cd          if (icall.eq.0) then
1370 cd            rrsave(ind)=rrij
1371 cd          else
1372 cd            rrij=rrsave(ind)
1373 cd          endif
1374             rij=dsqrt(rrij)
1375 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1376             call sc_angular
1377 C Calculate whole angle-dependent part of epsilon and contributions
1378 C to its derivatives
1379             fac=(rrij*sigsq)**expon2
1380             e1=fac*fac*aa(itypi,itypj)
1381             e2=fac*bb(itypi,itypj)
1382             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1383             eps2der=evdwij*eps3rt
1384             eps3der=evdwij*eps2rt
1385             evdwij=evdwij*eps2rt*eps3rt
1386             evdw=evdw+evdwij
1387             if (lprn) then
1388             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1389             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1390 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1391 cd     &        restyp(itypi),i,restyp(itypj),j,
1392 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1393 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1394 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1395 cd     &        evdwij
1396             endif
1397 C Calculate gradient components.
1398             e1=e1*eps1*eps2rt**2*eps3rt**2
1399             fac=-expon*(e1+evdwij)
1400             sigder=fac/sigsq
1401             fac=rrij*fac
1402 C Calculate radial part of the gradient
1403             gg(1)=xj*fac
1404             gg(2)=yj*fac
1405             gg(3)=zj*fac
1406 C Calculate the angular part of the gradient and sum add the contributions
1407 C to the appropriate components of the Cartesian gradient.
1408             call sc_grad
1409           enddo      ! j
1410         enddo        ! iint
1411       enddo          ! i
1412 c     stop
1413       return
1414       end
1415 C-----------------------------------------------------------------------------
1416       subroutine egb(evdw)
1417 C
1418 C This subroutine calculates the interaction energy of nonbonded side chains
1419 C assuming the Gay-Berne potential of interaction.
1420 C
1421       implicit real*8 (a-h,o-z)
1422       include 'DIMENSIONS'
1423       include 'COMMON.GEO'
1424       include 'COMMON.VAR'
1425       include 'COMMON.LOCAL'
1426       include 'COMMON.CHAIN'
1427       include 'COMMON.DERIV'
1428       include 'COMMON.NAMES'
1429       include 'COMMON.INTERACT'
1430       include 'COMMON.IOUNITS'
1431       include 'COMMON.CALC'
1432       include 'COMMON.CONTROL'
1433       include 'COMMON.SPLITELE'
1434       include 'COMMON.SBRIDGE'
1435       logical lprn
1436       integer xshift,yshift,zshift
1437       evdw=0.0D0
1438 ccccc      energy_dec=.false.
1439 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1440       evdw=0.0D0
1441       lprn=.false.
1442 c     if (icall.eq.0) lprn=.false.
1443       ind=0
1444 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1445 C we have the original box)
1446 C      do xshift=-1,1
1447 C      do yshift=-1,1
1448 C      do zshift=-1,1
1449       do i=iatsc_s,iatsc_e
1450         itypi=iabs(itype(i))
1451         if (itypi.eq.ntyp1) cycle
1452         itypi1=iabs(itype(i+1))
1453         xi=c(1,nres+i)
1454         yi=c(2,nres+i)
1455         zi=c(3,nres+i)
1456 C Return atom into box, boxxsize is size of box in x dimension
1457 c  134   continue
1458 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1459 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1460 C Condition for being inside the proper box
1461 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1462 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
1463 c        go to 134
1464 c        endif
1465 c  135   continue
1466 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1467 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1468 C Condition for being inside the proper box
1469 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1470 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
1471 c        go to 135
1472 c        endif
1473 c  136   continue
1474 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1475 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1476 C Condition for being inside the proper box
1477 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1478 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
1479 c        go to 136
1480 c        endif
1481           xi=mod(xi,boxxsize)
1482           if (xi.lt.0) xi=xi+boxxsize
1483           yi=mod(yi,boxysize)
1484           if (yi.lt.0) yi=yi+boxysize
1485           zi=mod(zi,boxzsize)
1486           if (zi.lt.0) zi=zi+boxzsize
1487 C          xi=xi+xshift*boxxsize
1488 C          yi=yi+yshift*boxysize
1489 C          zi=zi+zshift*boxzsize
1490
1491         dxi=dc_norm(1,nres+i)
1492         dyi=dc_norm(2,nres+i)
1493         dzi=dc_norm(3,nres+i)
1494 c        dsci_inv=dsc_inv(itypi)
1495         dsci_inv=vbld_inv(i+nres)
1496 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1497 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1498 C
1499 C Calculate SC interaction energy.
1500 C
1501         do iint=1,nint_gr(i)
1502           do j=istart(i,iint),iend(i,iint)
1503             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1504               call dyn_ssbond_ene(i,j,evdwij)
1505               evdw=evdw+evdwij
1506               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1507      &                        'evdw',i,j,evdwij,' ss'
1508             ELSE
1509             ind=ind+1
1510             itypj=iabs(itype(j))
1511             if (itypj.eq.ntyp1) cycle
1512 c            dscj_inv=dsc_inv(itypj)
1513             dscj_inv=vbld_inv(j+nres)
1514 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1515 c     &       1.0d0/vbld(j+nres)
1516 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1517             sig0ij=sigma(itypi,itypj)
1518             chi1=chi(itypi,itypj)
1519             chi2=chi(itypj,itypi)
1520             chi12=chi1*chi2
1521             chip1=chip(itypi)
1522             chip2=chip(itypj)
1523             chip12=chip1*chip2
1524             alf1=alp(itypi)
1525             alf2=alp(itypj)
1526             alf12=0.5D0*(alf1+alf2)
1527 C For diagnostics only!!!
1528 c           chi1=0.0D0
1529 c           chi2=0.0D0
1530 c           chi12=0.0D0
1531 c           chip1=0.0D0
1532 c           chip2=0.0D0
1533 c           chip12=0.0D0
1534 c           alf1=0.0D0
1535 c           alf2=0.0D0
1536 c           alf12=0.0D0
1537             xj=c(1,nres+j)
1538             yj=c(2,nres+j)
1539             zj=c(3,nres+j)
1540 C Return atom J into box the original box
1541 c  137   continue
1542 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
1543 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
1544 C Condition for being inside the proper box
1545 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
1546 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
1547 c        go to 137
1548 c        endif
1549 c  138   continue
1550 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
1551 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
1552 C Condition for being inside the proper box
1553 c        if ((yj.gt.((0.5d0)*boxysize)).or.
1554 c     &       (yj.lt.((-0.5d0)*boxysize))) then
1555 c        go to 138
1556 c        endif
1557 c  139   continue
1558 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
1559 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
1560 C Condition for being inside the proper box
1561 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
1562 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
1563 c        go to 139
1564 c        endif
1565           xj=mod(xj,boxxsize)
1566           if (xj.lt.0) xj=xj+boxxsize
1567           yj=mod(yj,boxysize)
1568           if (yj.lt.0) yj=yj+boxysize
1569           zj=mod(zj,boxzsize)
1570           if (zj.lt.0) zj=zj+boxzsize
1571       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1572       xj_safe=xj
1573       yj_safe=yj
1574       zj_safe=zj
1575       subchap=0
1576       do xshift=-1,1
1577       do yshift=-1,1
1578       do zshift=-1,1
1579           xj=xj_safe+xshift*boxxsize
1580           yj=yj_safe+yshift*boxysize
1581           zj=zj_safe+zshift*boxzsize
1582           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1583           if(dist_temp.lt.dist_init) then
1584             dist_init=dist_temp
1585             xj_temp=xj
1586             yj_temp=yj
1587             zj_temp=zj
1588             subchap=1
1589           endif
1590        enddo
1591        enddo
1592        enddo
1593        if (subchap.eq.1) then
1594           xj=xj_temp-xi
1595           yj=yj_temp-yi
1596           zj=zj_temp-zi
1597        else
1598           xj=xj_safe-xi
1599           yj=yj_safe-yi
1600           zj=zj_safe-zi
1601        endif
1602             dxj=dc_norm(1,nres+j)
1603             dyj=dc_norm(2,nres+j)
1604             dzj=dc_norm(3,nres+j)
1605 C            xj=xj-xi
1606 C            yj=yj-yi
1607 C            zj=zj-zi
1608 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1609 c            write (iout,*) "j",j," dc_norm",
1610 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1611             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1612             rij=dsqrt(rrij)
1613             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1614             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1615
1616 c            write (iout,'(a7,4f8.3)')
1617 c    &      "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
1618             if (sss.gt.0.0d0) then
1619 C Calculate angle-dependent terms of energy and contributions to their
1620 C derivatives.
1621             call sc_angular
1622             sigsq=1.0D0/sigsq
1623             sig=sig0ij*dsqrt(sigsq)
1624             rij_shift=1.0D0/rij-sig+sig0ij
1625 c for diagnostics; uncomment
1626 c            rij_shift=1.2*sig0ij
1627 C I hate to put IF's in the loops, but here don't have another choice!!!!
1628             if (rij_shift.le.0.0D0) then
1629               evdw=1.0D20
1630 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1631 cd     &        restyp(itypi),i,restyp(itypj),j,
1632 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1633               return
1634             endif
1635             sigder=-sig*sigsq
1636 c---------------------------------------------------------------
1637             rij_shift=1.0D0/rij_shift
1638             fac=rij_shift**expon
1639             e1=fac*fac*aa(itypi,itypj)
1640             e2=fac*bb(itypi,itypj)
1641             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1642             eps2der=evdwij*eps3rt
1643             eps3der=evdwij*eps2rt
1644 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1645 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1646             evdwij=evdwij*eps2rt*eps3rt
1647             evdw=evdw+evdwij*sss
1648             if (lprn) then
1649             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1650             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1651             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1652      &        restyp(itypi),i,restyp(itypj),j,
1653      &        epsi,sigm,chi1,chi2,chip1,chip2,
1654      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1655      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1656      &        evdwij
1657             endif
1658
1659             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1660      &                        'evdw',i,j,evdwij
1661
1662 C Calculate gradient components.
1663             e1=e1*eps1*eps2rt**2*eps3rt**2
1664             fac=-expon*(e1+evdwij)*rij_shift
1665             sigder=fac*sigder
1666             fac=rij*fac
1667 c            print '(2i4,6f8.4)',i,j,sss,sssgrad*
1668 c     &      evdwij,fac,sigma(itypi,itypj),expon
1669             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1670 c            fac=0.0d0
1671 C Calculate the radial part of the gradient
1672             gg(1)=xj*fac
1673             gg(2)=yj*fac
1674             gg(3)=zj*fac
1675 C Calculate angular part of the gradient.
1676             call sc_grad
1677             ENDIF    ! dyn_ss
1678           enddo      ! j
1679         enddo        ! iint
1680       enddo          ! i
1681 C      enddo          ! zshift
1682 C      enddo          ! yshift
1683 C      enddo          ! xshift
1684 c      write (iout,*) "Number of loop steps in EGB:",ind
1685 cccc      energy_dec=.false.
1686       return
1687       end
1688 C-----------------------------------------------------------------------------
1689       subroutine egbv(evdw)
1690 C
1691 C This subroutine calculates the interaction energy of nonbonded side chains
1692 C assuming the Gay-Berne-Vorobjev potential of interaction.
1693 C
1694       implicit real*8 (a-h,o-z)
1695       include 'DIMENSIONS'
1696       include 'COMMON.GEO'
1697       include 'COMMON.VAR'
1698       include 'COMMON.LOCAL'
1699       include 'COMMON.CHAIN'
1700       include 'COMMON.DERIV'
1701       include 'COMMON.NAMES'
1702       include 'COMMON.INTERACT'
1703       include 'COMMON.IOUNITS'
1704       include 'COMMON.CALC'
1705       common /srutu/ icall
1706       logical lprn
1707       evdw=0.0D0
1708 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1709       evdw=0.0D0
1710       lprn=.false.
1711 c     if (icall.eq.0) lprn=.true.
1712       ind=0
1713       do i=iatsc_s,iatsc_e
1714         itypi=iabs(itype(i))
1715         if (itypi.eq.ntyp1) cycle
1716         itypi1=iabs(itype(i+1))
1717         xi=c(1,nres+i)
1718         yi=c(2,nres+i)
1719         zi=c(3,nres+i)
1720         dxi=dc_norm(1,nres+i)
1721         dyi=dc_norm(2,nres+i)
1722         dzi=dc_norm(3,nres+i)
1723 c        dsci_inv=dsc_inv(itypi)
1724         dsci_inv=vbld_inv(i+nres)
1725 C
1726 C Calculate SC interaction energy.
1727 C
1728         do iint=1,nint_gr(i)
1729           do j=istart(i,iint),iend(i,iint)
1730             ind=ind+1
1731             itypj=iabs(itype(j))
1732             if (itypj.eq.ntyp1) cycle
1733 c            dscj_inv=dsc_inv(itypj)
1734             dscj_inv=vbld_inv(j+nres)
1735             sig0ij=sigma(itypi,itypj)
1736             r0ij=r0(itypi,itypj)
1737             chi1=chi(itypi,itypj)
1738             chi2=chi(itypj,itypi)
1739             chi12=chi1*chi2
1740             chip1=chip(itypi)
1741             chip2=chip(itypj)
1742             chip12=chip1*chip2
1743             alf1=alp(itypi)
1744             alf2=alp(itypj)
1745             alf12=0.5D0*(alf1+alf2)
1746 C For diagnostics only!!!
1747 c           chi1=0.0D0
1748 c           chi2=0.0D0
1749 c           chi12=0.0D0
1750 c           chip1=0.0D0
1751 c           chip2=0.0D0
1752 c           chip12=0.0D0
1753 c           alf1=0.0D0
1754 c           alf2=0.0D0
1755 c           alf12=0.0D0
1756             xj=c(1,nres+j)-xi
1757             yj=c(2,nres+j)-yi
1758             zj=c(3,nres+j)-zi
1759             dxj=dc_norm(1,nres+j)
1760             dyj=dc_norm(2,nres+j)
1761             dzj=dc_norm(3,nres+j)
1762             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1763             rij=dsqrt(rrij)
1764 C Calculate angle-dependent terms of energy and contributions to their
1765 C derivatives.
1766             call sc_angular
1767             sigsq=1.0D0/sigsq
1768             sig=sig0ij*dsqrt(sigsq)
1769             rij_shift=1.0D0/rij-sig+r0ij
1770 C I hate to put IF's in the loops, but here don't have another choice!!!!
1771             if (rij_shift.le.0.0D0) then
1772               evdw=1.0D20
1773               return
1774             endif
1775             sigder=-sig*sigsq
1776 c---------------------------------------------------------------
1777             rij_shift=1.0D0/rij_shift
1778             fac=rij_shift**expon
1779             e1=fac*fac*aa(itypi,itypj)
1780             e2=fac*bb(itypi,itypj)
1781             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1782             eps2der=evdwij*eps3rt
1783             eps3der=evdwij*eps2rt
1784             fac_augm=rrij**expon
1785             e_augm=augm(itypi,itypj)*fac_augm
1786             evdwij=evdwij*eps2rt*eps3rt
1787             evdw=evdw+evdwij+e_augm
1788             if (lprn) then
1789             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1790             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1791             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1792      &        restyp(itypi),i,restyp(itypj),j,
1793      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1794      &        chi1,chi2,chip1,chip2,
1795      &        eps1,eps2rt**2,eps3rt**2,
1796      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1797      &        evdwij+e_augm
1798             endif
1799 C Calculate gradient components.
1800             e1=e1*eps1*eps2rt**2*eps3rt**2
1801             fac=-expon*(e1+evdwij)*rij_shift
1802             sigder=fac*sigder
1803             fac=rij*fac-2*expon*rrij*e_augm
1804 C Calculate the radial part of the gradient
1805             gg(1)=xj*fac
1806             gg(2)=yj*fac
1807             gg(3)=zj*fac
1808 C Calculate angular part of the gradient.
1809             call sc_grad
1810           enddo      ! j
1811         enddo        ! iint
1812       enddo          ! i
1813       end
1814 C-----------------------------------------------------------------------------
1815       subroutine sc_angular
1816 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1817 C om12. Called by ebp, egb, and egbv.
1818       implicit none
1819       include 'COMMON.CALC'
1820       include 'COMMON.IOUNITS'
1821       erij(1)=xj*rij
1822       erij(2)=yj*rij
1823       erij(3)=zj*rij
1824       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1825       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1826       om12=dxi*dxj+dyi*dyj+dzi*dzj
1827       chiom12=chi12*om12
1828 C Calculate eps1(om12) and its derivative in om12
1829       faceps1=1.0D0-om12*chiom12
1830       faceps1_inv=1.0D0/faceps1
1831       eps1=dsqrt(faceps1_inv)
1832 C Following variable is eps1*deps1/dom12
1833       eps1_om12=faceps1_inv*chiom12
1834 c diagnostics only
1835 c      faceps1_inv=om12
1836 c      eps1=om12
1837 c      eps1_om12=1.0d0
1838 c      write (iout,*) "om12",om12," eps1",eps1
1839 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1840 C and om12.
1841       om1om2=om1*om2
1842       chiom1=chi1*om1
1843       chiom2=chi2*om2
1844       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1845       sigsq=1.0D0-facsig*faceps1_inv
1846       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1847       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1848       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1849 c diagnostics only
1850 c      sigsq=1.0d0
1851 c      sigsq_om1=0.0d0
1852 c      sigsq_om2=0.0d0
1853 c      sigsq_om12=0.0d0
1854 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1855 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1856 c     &    " eps1",eps1
1857 C Calculate eps2 and its derivatives in om1, om2, and om12.
1858       chipom1=chip1*om1
1859       chipom2=chip2*om2
1860       chipom12=chip12*om12
1861       facp=1.0D0-om12*chipom12
1862       facp_inv=1.0D0/facp
1863       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1864 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1865 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1866 C Following variable is the square root of eps2
1867       eps2rt=1.0D0-facp1*facp_inv
1868 C Following three variables are the derivatives of the square root of eps
1869 C in om1, om2, and om12.
1870       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1871       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1872       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1873 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1874       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1875 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1876 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1877 c     &  " eps2rt_om12",eps2rt_om12
1878 C Calculate whole angle-dependent part of epsilon and contributions
1879 C to its derivatives
1880       return
1881       end
1882 C----------------------------------------------------------------------------
1883       subroutine sc_grad
1884       implicit real*8 (a-h,o-z)
1885       include 'DIMENSIONS'
1886       include 'COMMON.CHAIN'
1887       include 'COMMON.DERIV'
1888       include 'COMMON.CALC'
1889       include 'COMMON.IOUNITS'
1890       double precision dcosom1(3),dcosom2(3)
1891 cc      print *,'sss=',sss
1892       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1893       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1894       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1895      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1896 c diagnostics only
1897 c      eom1=0.0d0
1898 c      eom2=0.0d0
1899 c      eom12=evdwij*eps1_om12
1900 c end diagnostics
1901 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1902 c     &  " sigder",sigder
1903 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1904 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1905       do k=1,3
1906         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1907         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1908       enddo
1909       do k=1,3
1910         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
1911       enddo
1912 c      write (iout,*) "gg",(gg(k),k=1,3)
1913       do k=1,3
1914         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1915      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1916      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
1917         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1918      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1919      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
1920 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1921 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1922 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1923 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1924       enddo
1925 C
1926 C Calculate the components of the gradient in DC and X
1927 C
1928 cgrad      do k=i,j-1
1929 cgrad        do l=1,3
1930 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1931 cgrad        enddo
1932 cgrad      enddo
1933       do l=1,3
1934         gvdwc(l,i)=gvdwc(l,i)-gg(l)
1935         gvdwc(l,j)=gvdwc(l,j)+gg(l)
1936       enddo
1937       return
1938       end
1939 C-----------------------------------------------------------------------
1940       subroutine e_softsphere(evdw)
1941 C
1942 C This subroutine calculates the interaction energy of nonbonded side chains
1943 C assuming the LJ potential of interaction.
1944 C
1945       implicit real*8 (a-h,o-z)
1946       include 'DIMENSIONS'
1947       parameter (accur=1.0d-10)
1948       include 'COMMON.GEO'
1949       include 'COMMON.VAR'
1950       include 'COMMON.LOCAL'
1951       include 'COMMON.CHAIN'
1952       include 'COMMON.DERIV'
1953       include 'COMMON.INTERACT'
1954       include 'COMMON.TORSION'
1955       include 'COMMON.SBRIDGE'
1956       include 'COMMON.NAMES'
1957       include 'COMMON.IOUNITS'
1958       include 'COMMON.CONTACTS'
1959       dimension gg(3)
1960 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1961       evdw=0.0D0
1962       do i=iatsc_s,iatsc_e
1963         itypi=iabs(itype(i))
1964         if (itypi.eq.ntyp1) cycle
1965         itypi1=iabs(itype(i+1))
1966         xi=c(1,nres+i)
1967         yi=c(2,nres+i)
1968         zi=c(3,nres+i)
1969 C
1970 C Calculate SC interaction energy.
1971 C
1972         do iint=1,nint_gr(i)
1973 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1974 cd   &                  'iend=',iend(i,iint)
1975           do j=istart(i,iint),iend(i,iint)
1976             itypj=iabs(itype(j))
1977             if (itypj.eq.ntyp1) cycle
1978             xj=c(1,nres+j)-xi
1979             yj=c(2,nres+j)-yi
1980             zj=c(3,nres+j)-zi
1981             rij=xj*xj+yj*yj+zj*zj
1982 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1983             r0ij=r0(itypi,itypj)
1984             r0ijsq=r0ij*r0ij
1985 c            print *,i,j,r0ij,dsqrt(rij)
1986             if (rij.lt.r0ijsq) then
1987               evdwij=0.25d0*(rij-r0ijsq)**2
1988               fac=rij-r0ijsq
1989             else
1990               evdwij=0.0d0
1991               fac=0.0d0
1992             endif
1993             evdw=evdw+evdwij
1994 C
1995 C Calculate the components of the gradient in DC and X
1996 C
1997             gg(1)=xj*fac
1998             gg(2)=yj*fac
1999             gg(3)=zj*fac
2000             do k=1,3
2001               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2002               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2003               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2004               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2005             enddo
2006 cgrad            do k=i,j-1
2007 cgrad              do l=1,3
2008 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2009 cgrad              enddo
2010 cgrad            enddo
2011           enddo ! j
2012         enddo ! iint
2013       enddo ! i
2014       return
2015       end
2016 C--------------------------------------------------------------------------
2017       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2018      &              eello_turn4)
2019 C
2020 C Soft-sphere potential of p-p interaction
2021 C
2022       implicit real*8 (a-h,o-z)
2023       include 'DIMENSIONS'
2024       include 'COMMON.CONTROL'
2025       include 'COMMON.IOUNITS'
2026       include 'COMMON.GEO'
2027       include 'COMMON.VAR'
2028       include 'COMMON.LOCAL'
2029       include 'COMMON.CHAIN'
2030       include 'COMMON.DERIV'
2031       include 'COMMON.INTERACT'
2032       include 'COMMON.CONTACTS'
2033       include 'COMMON.TORSION'
2034       include 'COMMON.VECTORS'
2035       include 'COMMON.FFIELD'
2036       dimension ggg(3)
2037 C      write(iout,*) 'In EELEC_soft_sphere'
2038       ees=0.0D0
2039       evdw1=0.0D0
2040       eel_loc=0.0d0
2041       eello_turn3=0.0d0
2042       eello_turn4=0.0d0
2043       ind=0
2044       do i=iatel_s,iatel_e
2045         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2046         dxi=dc(1,i)
2047         dyi=dc(2,i)
2048         dzi=dc(3,i)
2049         xmedi=c(1,i)+0.5d0*dxi
2050         ymedi=c(2,i)+0.5d0*dyi
2051         zmedi=c(3,i)+0.5d0*dzi
2052           xmedi=mod(xmedi,boxxsize)
2053           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2054           ymedi=mod(ymedi,boxysize)
2055           if (ymedi.lt.0) ymedi=ymedi+boxysize
2056           zmedi=mod(zmedi,boxzsize)
2057           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2058         num_conti=0
2059 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2060         do j=ielstart(i),ielend(i)
2061           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2062           ind=ind+1
2063           iteli=itel(i)
2064           itelj=itel(j)
2065           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2066           r0ij=rpp(iteli,itelj)
2067           r0ijsq=r0ij*r0ij
2068           dxj=dc(1,j)
2069           dyj=dc(2,j)
2070           dzj=dc(3,j)
2071           xj=c(1,j)+0.5D0*dxj
2072           yj=c(2,j)+0.5D0*dyj
2073           zj=c(3,j)+0.5D0*dzj
2074           xj=mod(xj,boxxsize)
2075           if (xj.lt.0) xj=xj+boxxsize
2076           yj=mod(yj,boxysize)
2077           if (yj.lt.0) yj=yj+boxysize
2078           zj=mod(zj,boxzsize)
2079           if (zj.lt.0) zj=zj+boxzsize
2080       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2081       xj_safe=xj
2082       yj_safe=yj
2083       zj_safe=zj
2084       isubchap=0
2085       do xshift=-1,1
2086       do yshift=-1,1
2087       do zshift=-1,1
2088           xj=xj_safe+xshift*boxxsize
2089           yj=yj_safe+yshift*boxysize
2090           zj=zj_safe+zshift*boxzsize
2091           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2092           if(dist_temp.lt.dist_init) then
2093             dist_init=dist_temp
2094             xj_temp=xj
2095             yj_temp=yj
2096             zj_temp=zj
2097             isubchap=1
2098           endif
2099        enddo
2100        enddo
2101        enddo
2102        if (isubchap.eq.1) then
2103           xj=xj_temp-xmedi
2104           yj=yj_temp-ymedi
2105           zj=zj_temp-zmedi
2106        else
2107           xj=xj_safe-xmedi
2108           yj=yj_safe-ymedi
2109           zj=zj_safe-zmedi
2110        endif
2111           rij=xj*xj+yj*yj+zj*zj
2112             sss=sscale(sqrt(rij))
2113             sssgrad=sscagrad(sqrt(rij))
2114           if (rij.lt.r0ijsq) then
2115             evdw1ij=0.25d0*(rij-r0ijsq)**2
2116             fac=rij-r0ijsq
2117           else
2118             evdw1ij=0.0d0
2119             fac=0.0d0
2120           endif
2121           evdw1=evdw1+evdw1ij*sss
2122 C
2123 C Calculate contributions to the Cartesian gradient.
2124 C
2125           ggg(1)=fac*xj*sssgrad
2126           ggg(2)=fac*yj*sssgrad
2127           ggg(3)=fac*zj*sssgrad
2128           do k=1,3
2129             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2130             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2131           enddo
2132 *
2133 * Loop over residues i+1 thru j-1.
2134 *
2135 cgrad          do k=i+1,j-1
2136 cgrad            do l=1,3
2137 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2138 cgrad            enddo
2139 cgrad          enddo
2140         enddo ! j
2141       enddo   ! i
2142 cgrad      do i=nnt,nct-1
2143 cgrad        do k=1,3
2144 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2145 cgrad        enddo
2146 cgrad        do j=i+1,nct-1
2147 cgrad          do k=1,3
2148 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2149 cgrad          enddo
2150 cgrad        enddo
2151 cgrad      enddo
2152       return
2153       end
2154 c------------------------------------------------------------------------------
2155       subroutine vec_and_deriv
2156       implicit real*8 (a-h,o-z)
2157       include 'DIMENSIONS'
2158 #ifdef MPI
2159       include 'mpif.h'
2160 #endif
2161       include 'COMMON.IOUNITS'
2162       include 'COMMON.GEO'
2163       include 'COMMON.VAR'
2164       include 'COMMON.LOCAL'
2165       include 'COMMON.CHAIN'
2166       include 'COMMON.VECTORS'
2167       include 'COMMON.SETUP'
2168       include 'COMMON.TIME1'
2169       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2170 C Compute the local reference systems. For reference system (i), the
2171 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2172 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2173 #ifdef PARVEC
2174       do i=ivec_start,ivec_end
2175 #else
2176       do i=1,nres-1
2177 #endif
2178           if (i.eq.nres-1) then
2179 C Case of the last full residue
2180 C Compute the Z-axis
2181             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2182             costh=dcos(pi-theta(nres))
2183             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2184             do k=1,3
2185               uz(k,i)=fac*uz(k,i)
2186             enddo
2187 C Compute the derivatives of uz
2188             uzder(1,1,1)= 0.0d0
2189             uzder(2,1,1)=-dc_norm(3,i-1)
2190             uzder(3,1,1)= dc_norm(2,i-1)
2191             uzder(1,2,1)= dc_norm(3,i-1)
2192             uzder(2,2,1)= 0.0d0
2193             uzder(3,2,1)=-dc_norm(1,i-1)
2194             uzder(1,3,1)=-dc_norm(2,i-1)
2195             uzder(2,3,1)= dc_norm(1,i-1)
2196             uzder(3,3,1)= 0.0d0
2197             uzder(1,1,2)= 0.0d0
2198             uzder(2,1,2)= dc_norm(3,i)
2199             uzder(3,1,2)=-dc_norm(2,i)
2200             uzder(1,2,2)=-dc_norm(3,i)
2201             uzder(2,2,2)= 0.0d0
2202             uzder(3,2,2)= dc_norm(1,i)
2203             uzder(1,3,2)= dc_norm(2,i)
2204             uzder(2,3,2)=-dc_norm(1,i)
2205             uzder(3,3,2)= 0.0d0
2206 C Compute the Y-axis
2207             facy=fac
2208             do k=1,3
2209               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2210             enddo
2211 C Compute the derivatives of uy
2212             do j=1,3
2213               do k=1,3
2214                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2215      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2216                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2217               enddo
2218               uyder(j,j,1)=uyder(j,j,1)-costh
2219               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2220             enddo
2221             do j=1,2
2222               do k=1,3
2223                 do l=1,3
2224                   uygrad(l,k,j,i)=uyder(l,k,j)
2225                   uzgrad(l,k,j,i)=uzder(l,k,j)
2226                 enddo
2227               enddo
2228             enddo
2229             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2230             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2231             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2232             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2233           else
2234 C Other residues
2235 C Compute the Z-axis
2236             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2237             costh=dcos(pi-theta(i+2))
2238             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2239             do k=1,3
2240               uz(k,i)=fac*uz(k,i)
2241             enddo
2242 C Compute the derivatives of uz
2243             uzder(1,1,1)= 0.0d0
2244             uzder(2,1,1)=-dc_norm(3,i+1)
2245             uzder(3,1,1)= dc_norm(2,i+1)
2246             uzder(1,2,1)= dc_norm(3,i+1)
2247             uzder(2,2,1)= 0.0d0
2248             uzder(3,2,1)=-dc_norm(1,i+1)
2249             uzder(1,3,1)=-dc_norm(2,i+1)
2250             uzder(2,3,1)= dc_norm(1,i+1)
2251             uzder(3,3,1)= 0.0d0
2252             uzder(1,1,2)= 0.0d0
2253             uzder(2,1,2)= dc_norm(3,i)
2254             uzder(3,1,2)=-dc_norm(2,i)
2255             uzder(1,2,2)=-dc_norm(3,i)
2256             uzder(2,2,2)= 0.0d0
2257             uzder(3,2,2)= dc_norm(1,i)
2258             uzder(1,3,2)= dc_norm(2,i)
2259             uzder(2,3,2)=-dc_norm(1,i)
2260             uzder(3,3,2)= 0.0d0
2261 C Compute the Y-axis
2262             facy=fac
2263             do k=1,3
2264               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2265             enddo
2266 C Compute the derivatives of uy
2267             do j=1,3
2268               do k=1,3
2269                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2270      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2271                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2272               enddo
2273               uyder(j,j,1)=uyder(j,j,1)-costh
2274               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2275             enddo
2276             do j=1,2
2277               do k=1,3
2278                 do l=1,3
2279                   uygrad(l,k,j,i)=uyder(l,k,j)
2280                   uzgrad(l,k,j,i)=uzder(l,k,j)
2281                 enddo
2282               enddo
2283             enddo
2284             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2285             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2286             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2287             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2288           endif
2289       enddo
2290       do i=1,nres-1
2291         vbld_inv_temp(1)=vbld_inv(i+1)
2292         if (i.lt.nres-1) then
2293           vbld_inv_temp(2)=vbld_inv(i+2)
2294           else
2295           vbld_inv_temp(2)=vbld_inv(i)
2296           endif
2297         do j=1,2
2298           do k=1,3
2299             do l=1,3
2300               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2301               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2302             enddo
2303           enddo
2304         enddo
2305       enddo
2306 #if defined(PARVEC) && defined(MPI)
2307       if (nfgtasks1.gt.1) then
2308         time00=MPI_Wtime()
2309 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2310 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2311 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2312         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2313      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2314      &   FG_COMM1,IERR)
2315         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2316      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2317      &   FG_COMM1,IERR)
2318         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2319      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2320      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2321         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2322      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2323      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2324         time_gather=time_gather+MPI_Wtime()-time00
2325       endif
2326 c      if (fg_rank.eq.0) then
2327 c        write (iout,*) "Arrays UY and UZ"
2328 c        do i=1,nres-1
2329 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2330 c     &     (uz(k,i),k=1,3)
2331 c        enddo
2332 c      endif
2333 #endif
2334       return
2335       end
2336 C-----------------------------------------------------------------------------
2337       subroutine check_vecgrad
2338       implicit real*8 (a-h,o-z)
2339       include 'DIMENSIONS'
2340       include 'COMMON.IOUNITS'
2341       include 'COMMON.GEO'
2342       include 'COMMON.VAR'
2343       include 'COMMON.LOCAL'
2344       include 'COMMON.CHAIN'
2345       include 'COMMON.VECTORS'
2346       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2347       dimension uyt(3,maxres),uzt(3,maxres)
2348       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2349       double precision delta /1.0d-7/
2350       call vec_and_deriv
2351 cd      do i=1,nres
2352 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2353 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2354 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2355 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2356 cd     &     (dc_norm(if90,i),if90=1,3)
2357 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2358 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2359 cd          write(iout,'(a)')
2360 cd      enddo
2361       do i=1,nres
2362         do j=1,2
2363           do k=1,3
2364             do l=1,3
2365               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2366               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2367             enddo
2368           enddo
2369         enddo
2370       enddo
2371       call vec_and_deriv
2372       do i=1,nres
2373         do j=1,3
2374           uyt(j,i)=uy(j,i)
2375           uzt(j,i)=uz(j,i)
2376         enddo
2377       enddo
2378       do i=1,nres
2379 cd        write (iout,*) 'i=',i
2380         do k=1,3
2381           erij(k)=dc_norm(k,i)
2382         enddo
2383         do j=1,3
2384           do k=1,3
2385             dc_norm(k,i)=erij(k)
2386           enddo
2387           dc_norm(j,i)=dc_norm(j,i)+delta
2388 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2389 c          do k=1,3
2390 c            dc_norm(k,i)=dc_norm(k,i)/fac
2391 c          enddo
2392 c          write (iout,*) (dc_norm(k,i),k=1,3)
2393 c          write (iout,*) (erij(k),k=1,3)
2394           call vec_and_deriv
2395           do k=1,3
2396             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2397             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2398             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2399             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2400           enddo
2401 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2402 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2403 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2404         enddo
2405         do k=1,3
2406           dc_norm(k,i)=erij(k)
2407         enddo
2408 cd        do k=1,3
2409 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2410 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2411 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2412 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2413 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2414 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2415 cd          write (iout,'(a)')
2416 cd        enddo
2417       enddo
2418       return
2419       end
2420 C--------------------------------------------------------------------------
2421       subroutine set_matrices
2422       implicit real*8 (a-h,o-z)
2423       include 'DIMENSIONS'
2424 #ifdef MPI
2425       include "mpif.h"
2426       include "COMMON.SETUP"
2427       integer IERR
2428       integer status(MPI_STATUS_SIZE)
2429 #endif
2430       include 'COMMON.IOUNITS'
2431       include 'COMMON.GEO'
2432       include 'COMMON.VAR'
2433       include 'COMMON.LOCAL'
2434       include 'COMMON.CHAIN'
2435       include 'COMMON.DERIV'
2436       include 'COMMON.INTERACT'
2437       include 'COMMON.CONTACTS'
2438       include 'COMMON.TORSION'
2439       include 'COMMON.VECTORS'
2440       include 'COMMON.FFIELD'
2441       double precision auxvec(2),auxmat(2,2)
2442 C
2443 C Compute the virtual-bond-torsional-angle dependent quantities needed
2444 C to calculate the el-loc multibody terms of various order.
2445 C
2446 #ifdef PARMAT
2447       do i=ivec_start+2,ivec_end+2
2448 #else
2449       do i=3,nres+1
2450 #endif
2451         if (i .lt. nres+1) then
2452           sin1=dsin(phi(i))
2453           cos1=dcos(phi(i))
2454           sintab(i-2)=sin1
2455           costab(i-2)=cos1
2456           obrot(1,i-2)=cos1
2457           obrot(2,i-2)=sin1
2458           sin2=dsin(2*phi(i))
2459           cos2=dcos(2*phi(i))
2460           sintab2(i-2)=sin2
2461           costab2(i-2)=cos2
2462           obrot2(1,i-2)=cos2
2463           obrot2(2,i-2)=sin2
2464           Ug(1,1,i-2)=-cos1
2465           Ug(1,2,i-2)=-sin1
2466           Ug(2,1,i-2)=-sin1
2467           Ug(2,2,i-2)= cos1
2468           Ug2(1,1,i-2)=-cos2
2469           Ug2(1,2,i-2)=-sin2
2470           Ug2(2,1,i-2)=-sin2
2471           Ug2(2,2,i-2)= cos2
2472         else
2473           costab(i-2)=1.0d0
2474           sintab(i-2)=0.0d0
2475           obrot(1,i-2)=1.0d0
2476           obrot(2,i-2)=0.0d0
2477           obrot2(1,i-2)=0.0d0
2478           obrot2(2,i-2)=0.0d0
2479           Ug(1,1,i-2)=1.0d0
2480           Ug(1,2,i-2)=0.0d0
2481           Ug(2,1,i-2)=0.0d0
2482           Ug(2,2,i-2)=1.0d0
2483           Ug2(1,1,i-2)=0.0d0
2484           Ug2(1,2,i-2)=0.0d0
2485           Ug2(2,1,i-2)=0.0d0
2486           Ug2(2,2,i-2)=0.0d0
2487         endif
2488         if (i .gt. 3 .and. i .lt. nres+1) then
2489           obrot_der(1,i-2)=-sin1
2490           obrot_der(2,i-2)= cos1
2491           Ugder(1,1,i-2)= sin1
2492           Ugder(1,2,i-2)=-cos1
2493           Ugder(2,1,i-2)=-cos1
2494           Ugder(2,2,i-2)=-sin1
2495           dwacos2=cos2+cos2
2496           dwasin2=sin2+sin2
2497           obrot2_der(1,i-2)=-dwasin2
2498           obrot2_der(2,i-2)= dwacos2
2499           Ug2der(1,1,i-2)= dwasin2
2500           Ug2der(1,2,i-2)=-dwacos2
2501           Ug2der(2,1,i-2)=-dwacos2
2502           Ug2der(2,2,i-2)=-dwasin2
2503         else
2504           obrot_der(1,i-2)=0.0d0
2505           obrot_der(2,i-2)=0.0d0
2506           Ugder(1,1,i-2)=0.0d0
2507           Ugder(1,2,i-2)=0.0d0
2508           Ugder(2,1,i-2)=0.0d0
2509           Ugder(2,2,i-2)=0.0d0
2510           obrot2_der(1,i-2)=0.0d0
2511           obrot2_der(2,i-2)=0.0d0
2512           Ug2der(1,1,i-2)=0.0d0
2513           Ug2der(1,2,i-2)=0.0d0
2514           Ug2der(2,1,i-2)=0.0d0
2515           Ug2der(2,2,i-2)=0.0d0
2516         endif
2517 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2518         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2519           iti = itortyp(itype(i-2))
2520         else
2521           iti=ntortyp
2522         endif
2523 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2524         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2525           iti1 = itortyp(itype(i-1))
2526         else
2527           iti1=ntortyp
2528         endif
2529 cd        write (iout,*) '*******i',i,' iti1',iti
2530 cd        write (iout,*) 'b1',b1(:,iti)
2531 cd        write (iout,*) 'b2',b2(:,iti)
2532 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2533 c        if (i .gt. iatel_s+2) then
2534         if (i .gt. nnt+2) then
2535           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2536           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2537           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2538      &    then
2539           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2540           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2541           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2542           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2543           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2544           endif
2545         else
2546           do k=1,2
2547             Ub2(k,i-2)=0.0d0
2548             Ctobr(k,i-2)=0.0d0
2549             Dtobr2(k,i-2)=0.0d0
2550             do l=1,2
2551               EUg(l,k,i-2)=0.0d0
2552               CUg(l,k,i-2)=0.0d0
2553               DUg(l,k,i-2)=0.0d0
2554               DtUg2(l,k,i-2)=0.0d0
2555             enddo
2556           enddo
2557         endif
2558         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2559         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2560         do k=1,2
2561           muder(k,i-2)=Ub2der(k,i-2)
2562         enddo
2563 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2564         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2565           if (itype(i-1).le.ntyp) then
2566             iti1 = itortyp(itype(i-1))
2567           else
2568             iti1=ntortyp
2569           endif
2570         else
2571           iti1=ntortyp
2572         endif
2573         do k=1,2
2574           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2575         enddo
2576 cd        write (iout,*) 'mu ',mu(:,i-2)
2577 cd        write (iout,*) 'mu1',mu1(:,i-2)
2578 cd        write (iout,*) 'mu2',mu2(:,i-2)
2579         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2580      &  then
2581         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2582         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2583         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2584         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2585         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2586 C Vectors and matrices dependent on a single virtual-bond dihedral.
2587         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2588         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2589         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2590         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2591         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2592         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2593         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2594         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2595         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2596         endif
2597       enddo
2598 C Matrices dependent on two consecutive virtual-bond dihedrals.
2599 C The order of matrices is from left to right.
2600       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2601      &then
2602 c      do i=max0(ivec_start,2),ivec_end
2603       do i=2,nres-1
2604         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2605         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2606         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2607         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2608         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2609         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2610         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2611         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2612       enddo
2613       endif
2614 #if defined(MPI) && defined(PARMAT)
2615 #ifdef DEBUG
2616 c      if (fg_rank.eq.0) then
2617         write (iout,*) "Arrays UG and UGDER before GATHER"
2618         do i=1,nres-1
2619           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2620      &     ((ug(l,k,i),l=1,2),k=1,2),
2621      &     ((ugder(l,k,i),l=1,2),k=1,2)
2622         enddo
2623         write (iout,*) "Arrays UG2 and UG2DER"
2624         do i=1,nres-1
2625           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2626      &     ((ug2(l,k,i),l=1,2),k=1,2),
2627      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2628         enddo
2629         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2630         do i=1,nres-1
2631           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2632      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2633      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2634         enddo
2635         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2636         do i=1,nres-1
2637           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2638      &     costab(i),sintab(i),costab2(i),sintab2(i)
2639         enddo
2640         write (iout,*) "Array MUDER"
2641         do i=1,nres-1
2642           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2643         enddo
2644 c      endif
2645 #endif
2646       if (nfgtasks.gt.1) then
2647         time00=MPI_Wtime()
2648 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2649 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2650 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2651 #ifdef MATGATHER
2652         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2653      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2654      &   FG_COMM1,IERR)
2655         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2656      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2657      &   FG_COMM1,IERR)
2658         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2659      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2660      &   FG_COMM1,IERR)
2661         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2662      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2663      &   FG_COMM1,IERR)
2664         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2665      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2666      &   FG_COMM1,IERR)
2667         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2668      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2669      &   FG_COMM1,IERR)
2670         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2671      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2672      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2673         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2674      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2675      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2676         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2677      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2678      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2679         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2680      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2681      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2682         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2683      &  then
2684         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2685      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2686      &   FG_COMM1,IERR)
2687         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2688      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2689      &   FG_COMM1,IERR)
2690         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2691      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2692      &   FG_COMM1,IERR)
2693        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2694      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2695      &   FG_COMM1,IERR)
2696         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2697      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2698      &   FG_COMM1,IERR)
2699         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2700      &   ivec_count(fg_rank1),
2701      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2702      &   FG_COMM1,IERR)
2703         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2704      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2705      &   FG_COMM1,IERR)
2706         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2707      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2708      &   FG_COMM1,IERR)
2709         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2710      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2711      &   FG_COMM1,IERR)
2712         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2713      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2714      &   FG_COMM1,IERR)
2715         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2716      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2717      &   FG_COMM1,IERR)
2718         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2719      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2720      &   FG_COMM1,IERR)
2721         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2722      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2723      &   FG_COMM1,IERR)
2724         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2725      &   ivec_count(fg_rank1),
2726      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2727      &   FG_COMM1,IERR)
2728         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2729      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2730      &   FG_COMM1,IERR)
2731        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2732      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2733      &   FG_COMM1,IERR)
2734         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2735      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2736      &   FG_COMM1,IERR)
2737        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2738      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2739      &   FG_COMM1,IERR)
2740         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2741      &   ivec_count(fg_rank1),
2742      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2743      &   FG_COMM1,IERR)
2744         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2745      &   ivec_count(fg_rank1),
2746      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2747      &   FG_COMM1,IERR)
2748         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2749      &   ivec_count(fg_rank1),
2750      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2751      &   MPI_MAT2,FG_COMM1,IERR)
2752         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2753      &   ivec_count(fg_rank1),
2754      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2755      &   MPI_MAT2,FG_COMM1,IERR)
2756         endif
2757 #else
2758 c Passes matrix info through the ring
2759       isend=fg_rank1
2760       irecv=fg_rank1-1
2761       if (irecv.lt.0) irecv=nfgtasks1-1
2762       iprev=irecv
2763       inext=fg_rank1+1
2764       if (inext.ge.nfgtasks1) inext=0
2765       do i=1,nfgtasks1-1
2766 c        write (iout,*) "isend",isend," irecv",irecv
2767 c        call flush(iout)
2768         lensend=lentyp(isend)
2769         lenrecv=lentyp(irecv)
2770 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2771 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2772 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2773 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2774 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2775 c        write (iout,*) "Gather ROTAT1"
2776 c        call flush(iout)
2777 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2778 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2779 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2780 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2781 c        write (iout,*) "Gather ROTAT2"
2782 c        call flush(iout)
2783         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2784      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2785      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2786      &   iprev,4400+irecv,FG_COMM,status,IERR)
2787 c        write (iout,*) "Gather ROTAT_OLD"
2788 c        call flush(iout)
2789         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2790      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2791      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2792      &   iprev,5500+irecv,FG_COMM,status,IERR)
2793 c        write (iout,*) "Gather PRECOMP11"
2794 c        call flush(iout)
2795         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2796      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2797      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2798      &   iprev,6600+irecv,FG_COMM,status,IERR)
2799 c        write (iout,*) "Gather PRECOMP12"
2800 c        call flush(iout)
2801         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2802      &  then
2803         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2804      &   MPI_ROTAT2(lensend),inext,7700+isend,
2805      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2806      &   iprev,7700+irecv,FG_COMM,status,IERR)
2807 c        write (iout,*) "Gather PRECOMP21"
2808 c        call flush(iout)
2809         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2810      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2811      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2812      &   iprev,8800+irecv,FG_COMM,status,IERR)
2813 c        write (iout,*) "Gather PRECOMP22"
2814 c        call flush(iout)
2815         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2816      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2817      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2818      &   MPI_PRECOMP23(lenrecv),
2819      &   iprev,9900+irecv,FG_COMM,status,IERR)
2820 c        write (iout,*) "Gather PRECOMP23"
2821 c        call flush(iout)
2822         endif
2823         isend=irecv
2824         irecv=irecv-1
2825         if (irecv.lt.0) irecv=nfgtasks1-1
2826       enddo
2827 #endif
2828         time_gather=time_gather+MPI_Wtime()-time00
2829       endif
2830 #ifdef DEBUG
2831 c      if (fg_rank.eq.0) then
2832         write (iout,*) "Arrays UG and UGDER"
2833         do i=1,nres-1
2834           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2835      &     ((ug(l,k,i),l=1,2),k=1,2),
2836      &     ((ugder(l,k,i),l=1,2),k=1,2)
2837         enddo
2838         write (iout,*) "Arrays UG2 and UG2DER"
2839         do i=1,nres-1
2840           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2841      &     ((ug2(l,k,i),l=1,2),k=1,2),
2842      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2843         enddo
2844         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2845         do i=1,nres-1
2846           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2847      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2848      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2849         enddo
2850         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2851         do i=1,nres-1
2852           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2853      &     costab(i),sintab(i),costab2(i),sintab2(i)
2854         enddo
2855         write (iout,*) "Array MUDER"
2856         do i=1,nres-1
2857           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2858         enddo
2859 c      endif
2860 #endif
2861 #endif
2862 cd      do i=1,nres
2863 cd        iti = itortyp(itype(i))
2864 cd        write (iout,*) i
2865 cd        do j=1,2
2866 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2867 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2868 cd        enddo
2869 cd      enddo
2870       return
2871       end
2872 C--------------------------------------------------------------------------
2873       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2874 C
2875 C This subroutine calculates the average interaction energy and its gradient
2876 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2877 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2878 C The potential depends both on the distance of peptide-group centers and on
2879 C the orientation of the CA-CA virtual bonds.
2880 C
2881       implicit real*8 (a-h,o-z)
2882 #ifdef MPI
2883       include 'mpif.h'
2884 #endif
2885       include 'DIMENSIONS'
2886       include 'COMMON.CONTROL'
2887       include 'COMMON.SETUP'
2888       include 'COMMON.IOUNITS'
2889       include 'COMMON.GEO'
2890       include 'COMMON.VAR'
2891       include 'COMMON.LOCAL'
2892       include 'COMMON.CHAIN'
2893       include 'COMMON.DERIV'
2894       include 'COMMON.INTERACT'
2895       include 'COMMON.CONTACTS'
2896       include 'COMMON.TORSION'
2897       include 'COMMON.VECTORS'
2898       include 'COMMON.FFIELD'
2899       include 'COMMON.TIME1'
2900       include 'COMMON.SPLITELE'
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 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
2984       do i=iturn3_start,iturn3_end
2985         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2986      &  .or. itype(i+2).eq.ntyp1
2987      &  .or. itype(i+3).eq.ntyp1
2988      &  .or. itype(i-1).eq.ntyp1
2989      &  .or. itype(i+4).eq.ntyp1
2990      &  ) cycle
2991         dxi=dc(1,i)
2992         dyi=dc(2,i)
2993         dzi=dc(3,i)
2994         dx_normi=dc_norm(1,i)
2995         dy_normi=dc_norm(2,i)
2996         dz_normi=dc_norm(3,i)
2997         xmedi=c(1,i)+0.5d0*dxi
2998         ymedi=c(2,i)+0.5d0*dyi
2999         zmedi=c(3,i)+0.5d0*dzi
3000           xmedi=mod(xmedi,boxxsize)
3001           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3002           ymedi=mod(ymedi,boxysize)
3003           if (ymedi.lt.0) ymedi=ymedi+boxysize
3004           zmedi=mod(zmedi,boxzsize)
3005           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3006         num_conti=0
3007         call eelecij(i,i+2,ees,evdw1,eel_loc)
3008         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3009         num_cont_hb(i)=num_conti
3010       enddo
3011       do i=iturn4_start,iturn4_end
3012         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3013      &    .or. itype(i+3).eq.ntyp1
3014      &    .or. itype(i+4).eq.ntyp1
3015      &    .or. itype(i+5).eq.ntyp1
3016      &    .or. itype(i).eq.ntyp1
3017      &    .or. itype(i-1).eq.ntyp1
3018      &                             ) cycle
3019         dxi=dc(1,i)
3020         dyi=dc(2,i)
3021         dzi=dc(3,i)
3022         dx_normi=dc_norm(1,i)
3023         dy_normi=dc_norm(2,i)
3024         dz_normi=dc_norm(3,i)
3025         xmedi=c(1,i)+0.5d0*dxi
3026         ymedi=c(2,i)+0.5d0*dyi
3027         zmedi=c(3,i)+0.5d0*dzi
3028 C Return atom into box, boxxsize is size of box in x dimension
3029 c  194   continue
3030 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3031 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3032 C Condition for being inside the proper box
3033 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3034 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3035 c        go to 194
3036 c        endif
3037 c  195   continue
3038 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3039 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3040 C Condition for being inside the proper box
3041 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3042 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3043 c        go to 195
3044 c        endif
3045 c  196   continue
3046 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3047 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3048 C Condition for being inside the proper box
3049 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3050 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3051 c        go to 196
3052 c        endif
3053           xmedi=mod(xmedi,boxxsize)
3054           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3055           ymedi=mod(ymedi,boxysize)
3056           if (ymedi.lt.0) ymedi=ymedi+boxysize
3057           zmedi=mod(zmedi,boxzsize)
3058           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3059
3060         num_conti=num_cont_hb(i)
3061         call eelecij(i,i+3,ees,evdw1,eel_loc)
3062         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3063      &   call eturn4(i,eello_turn4)
3064         num_cont_hb(i)=num_conti
3065       enddo   ! i
3066 C Loop over all neighbouring boxes
3067 C      do xshift=-1,1
3068 C      do yshift=-1,1
3069 C      do zshift=-1,1
3070 c
3071 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3072 c
3073       do i=iatel_s,iatel_e
3074         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3075      &  .or. itype(i+2).eq.ntyp1
3076      &  .or. itype(i-1).eq.ntyp1
3077      &                ) cycle
3078         dxi=dc(1,i)
3079         dyi=dc(2,i)
3080         dzi=dc(3,i)
3081         dx_normi=dc_norm(1,i)
3082         dy_normi=dc_norm(2,i)
3083         dz_normi=dc_norm(3,i)
3084         xmedi=c(1,i)+0.5d0*dxi
3085         ymedi=c(2,i)+0.5d0*dyi
3086         zmedi=c(3,i)+0.5d0*dzi
3087           xmedi=mod(xmedi,boxxsize)
3088           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3089           ymedi=mod(ymedi,boxysize)
3090           if (ymedi.lt.0) ymedi=ymedi+boxysize
3091           zmedi=mod(zmedi,boxzsize)
3092           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3093 C          xmedi=xmedi+xshift*boxxsize
3094 C          ymedi=ymedi+yshift*boxysize
3095 C          zmedi=zmedi+zshift*boxzsize
3096
3097 C Return tom into box, boxxsize is size of box in x dimension
3098 c  164   continue
3099 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3100 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3101 C Condition for being inside the proper box
3102 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3103 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3104 c        go to 164
3105 c        endif
3106 c  165   continue
3107 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3108 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3109 C Condition for being inside the proper box
3110 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3111 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3112 c        go to 165
3113 c        endif
3114 c  166   continue
3115 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3116 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3117 cC Condition for being inside the proper box
3118 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3119 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3120 c        go to 166
3121 c        endif
3122
3123 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3124         num_conti=num_cont_hb(i)
3125         do j=ielstart(i),ielend(i)
3126 c          write (iout,*) i,j,itype(i),itype(j)
3127           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3128      & .or.itype(j+2).eq.ntyp1
3129      & .or.itype(j-1).eq.ntyp1
3130      &) cycle
3131           call eelecij(i,j,ees,evdw1,eel_loc)
3132         enddo ! j
3133         num_cont_hb(i)=num_conti
3134       enddo   ! i
3135 C     enddo   ! zshift
3136 C      enddo   ! yshift
3137 C      enddo   ! xshift
3138
3139 c      write (iout,*) "Number of loop steps in EELEC:",ind
3140 cd      do i=1,nres
3141 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3142 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3143 cd      enddo
3144 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3145 ccc      eel_loc=eel_loc+eello_turn3
3146 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3147       return
3148       end
3149 C-------------------------------------------------------------------------------
3150       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3151       implicit real*8 (a-h,o-z)
3152       include 'DIMENSIONS'
3153 #ifdef MPI
3154       include "mpif.h"
3155 #endif
3156       include 'COMMON.CONTROL'
3157       include 'COMMON.IOUNITS'
3158       include 'COMMON.GEO'
3159       include 'COMMON.VAR'
3160       include 'COMMON.LOCAL'
3161       include 'COMMON.CHAIN'
3162       include 'COMMON.DERIV'
3163       include 'COMMON.INTERACT'
3164       include 'COMMON.CONTACTS'
3165       include 'COMMON.TORSION'
3166       include 'COMMON.VECTORS'
3167       include 'COMMON.FFIELD'
3168       include 'COMMON.TIME1'
3169       include 'COMMON.SPLITELE'
3170       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3171      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3172       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3173      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3174       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3175      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3176      &    num_conti,j1,j2
3177 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3178 #ifdef MOMENT
3179       double precision scal_el /1.0d0/
3180 #else
3181       double precision scal_el /0.5d0/
3182 #endif
3183 C 12/13/98
3184 C 13-go grudnia roku pamietnego...
3185       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3186      &                   0.0d0,1.0d0,0.0d0,
3187      &                   0.0d0,0.0d0,1.0d0/
3188 c          time00=MPI_Wtime()
3189 cd      write (iout,*) "eelecij",i,j
3190 c          ind=ind+1
3191           iteli=itel(i)
3192           itelj=itel(j)
3193           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3194           aaa=app(iteli,itelj)
3195           bbb=bpp(iteli,itelj)
3196           ael6i=ael6(iteli,itelj)
3197           ael3i=ael3(iteli,itelj)
3198           dxj=dc(1,j)
3199           dyj=dc(2,j)
3200           dzj=dc(3,j)
3201           dx_normj=dc_norm(1,j)
3202           dy_normj=dc_norm(2,j)
3203           dz_normj=dc_norm(3,j)
3204 C          xj=c(1,j)+0.5D0*dxj-xmedi
3205 C          yj=c(2,j)+0.5D0*dyj-ymedi
3206 C          zj=c(3,j)+0.5D0*dzj-zmedi
3207           xj=c(1,j)+0.5D0*dxj
3208           yj=c(2,j)+0.5D0*dyj
3209           zj=c(3,j)+0.5D0*dzj
3210           xj=mod(xj,boxxsize)
3211           if (xj.lt.0) xj=xj+boxxsize
3212           yj=mod(yj,boxysize)
3213           if (yj.lt.0) yj=yj+boxysize
3214           zj=mod(zj,boxzsize)
3215           if (zj.lt.0) zj=zj+boxzsize
3216           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3217       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3218       xj_safe=xj
3219       yj_safe=yj
3220       zj_safe=zj
3221       isubchap=0
3222       do xshift=-1,1
3223       do yshift=-1,1
3224       do zshift=-1,1
3225           xj=xj_safe+xshift*boxxsize
3226           yj=yj_safe+yshift*boxysize
3227           zj=zj_safe+zshift*boxzsize
3228           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3229           if(dist_temp.lt.dist_init) then
3230             dist_init=dist_temp
3231             xj_temp=xj
3232             yj_temp=yj
3233             zj_temp=zj
3234             isubchap=1
3235           endif
3236        enddo
3237        enddo
3238        enddo
3239        if (isubchap.eq.1) then
3240           xj=xj_temp-xmedi
3241           yj=yj_temp-ymedi
3242           zj=zj_temp-zmedi
3243        else
3244           xj=xj_safe-xmedi
3245           yj=yj_safe-ymedi
3246           zj=zj_safe-zmedi
3247        endif
3248 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3249 c  174   continue
3250 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3251 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3252 C Condition for being inside the proper box
3253 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
3254 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
3255 c        go to 174
3256 c        endif
3257 c  175   continue
3258 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3259 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3260 C Condition for being inside the proper box
3261 c        if ((yj.gt.((0.5d0)*boxysize)).or.
3262 c     &       (yj.lt.((-0.5d0)*boxysize))) then
3263 c        go to 175
3264 c        endif
3265 c  176   continue
3266 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3267 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3268 C Condition for being inside the proper box
3269 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
3270 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
3271 c        go to 176
3272 c        endif
3273 C        endif !endPBC condintion
3274 C        xj=xj-xmedi
3275 C        yj=yj-ymedi
3276 C        zj=zj-zmedi
3277           rij=xj*xj+yj*yj+zj*zj
3278
3279             sss=sscale(sqrt(rij))
3280             sssgrad=sscagrad(sqrt(rij))
3281 c            if (sss.gt.0.0d0) then
3282           rrmij=1.0D0/rij
3283           rij=dsqrt(rij)
3284           rmij=1.0D0/rij
3285           r3ij=rrmij*rmij
3286           r6ij=r3ij*r3ij
3287           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3288           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3289           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3290           fac=cosa-3.0D0*cosb*cosg
3291           ev1=aaa*r6ij*r6ij
3292 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3293           if (j.eq.i+2) ev1=scal_el*ev1
3294           ev2=bbb*r6ij
3295           fac3=ael6i*r6ij
3296           fac4=ael3i*r3ij
3297           evdwij=(ev1+ev2)
3298           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3299           el2=fac4*fac
3300 C MARYSIA
3301           eesij=(el1+el2)
3302 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3303           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3304           ees=ees+eesij
3305           evdw1=evdw1+evdwij*sss
3306 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3307 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3308 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3309 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3310
3311           if (energy_dec) then
3312               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
3313      &'evdw1',i,j,evdwij
3314      &,iteli,itelj,aaa,evdw1
3315               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3316           endif
3317
3318 C
3319 C Calculate contributions to the Cartesian gradient.
3320 C
3321 #ifdef SPLITELE
3322           facvdw=-6*rrmij*(ev1+evdwij)*sss
3323           facel=-3*rrmij*(el1+eesij)
3324           fac1=fac
3325           erij(1)=xj*rmij
3326           erij(2)=yj*rmij
3327           erij(3)=zj*rmij
3328 *
3329 * Radial derivatives. First process both termini of the fragment (i,j)
3330 *
3331           ggg(1)=facel*xj
3332           ggg(2)=facel*yj
3333           ggg(3)=facel*zj
3334 c          do k=1,3
3335 c            ghalf=0.5D0*ggg(k)
3336 c            gelc(k,i)=gelc(k,i)+ghalf
3337 c            gelc(k,j)=gelc(k,j)+ghalf
3338 c          enddo
3339 c 9/28/08 AL Gradient compotents will be summed only at the end
3340           do k=1,3
3341             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3342             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3343           enddo
3344 *
3345 * Loop over residues i+1 thru j-1.
3346 *
3347 cgrad          do k=i+1,j-1
3348 cgrad            do l=1,3
3349 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3350 cgrad            enddo
3351 cgrad          enddo
3352           if (sss.gt.0.0) then
3353           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3354           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3355           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3356           else
3357           ggg(1)=0.0
3358           ggg(2)=0.0
3359           ggg(3)=0.0
3360           endif
3361 c          do k=1,3
3362 c            ghalf=0.5D0*ggg(k)
3363 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3364 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3365 c          enddo
3366 c 9/28/08 AL Gradient compotents will be summed only at the end
3367           do k=1,3
3368             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3369             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3370           enddo
3371 *
3372 * Loop over residues i+1 thru j-1.
3373 *
3374 cgrad          do k=i+1,j-1
3375 cgrad            do l=1,3
3376 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3377 cgrad            enddo
3378 cgrad          enddo
3379 #else
3380 C MARYSIA
3381           facvdw=(ev1+evdwij)*sss
3382           facel=(el1+eesij)
3383           fac1=fac
3384           fac=-3*rrmij*(facvdw+facvdw+facel)
3385           erij(1)=xj*rmij
3386           erij(2)=yj*rmij
3387           erij(3)=zj*rmij
3388 *
3389 * Radial derivatives. First process both termini of the fragment (i,j)
3390 *
3391           ggg(1)=fac*xj
3392           ggg(2)=fac*yj
3393           ggg(3)=fac*zj
3394 c          do k=1,3
3395 c            ghalf=0.5D0*ggg(k)
3396 c            gelc(k,i)=gelc(k,i)+ghalf
3397 c            gelc(k,j)=gelc(k,j)+ghalf
3398 c          enddo
3399 c 9/28/08 AL Gradient compotents will be summed only at the end
3400           do k=1,3
3401             gelc_long(k,j)=gelc(k,j)+ggg(k)
3402             gelc_long(k,i)=gelc(k,i)-ggg(k)
3403           enddo
3404 *
3405 * Loop over residues i+1 thru j-1.
3406 *
3407 cgrad          do k=i+1,j-1
3408 cgrad            do l=1,3
3409 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3410 cgrad            enddo
3411 cgrad          enddo
3412 c 9/28/08 AL Gradient compotents will be summed only at the end
3413           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3414           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3415           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3416           do k=1,3
3417             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3418             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3419           enddo
3420 #endif
3421 *
3422 * Angular part
3423 *
3424           ecosa=2.0D0*fac3*fac1+fac4
3425           fac4=-3.0D0*fac4
3426           fac3=-6.0D0*fac3
3427           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3428           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3429           do k=1,3
3430             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3431             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3432           enddo
3433 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3434 cd   &          (dcosg(k),k=1,3)
3435           do k=1,3
3436             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3437           enddo
3438 c          do k=1,3
3439 c            ghalf=0.5D0*ggg(k)
3440 c            gelc(k,i)=gelc(k,i)+ghalf
3441 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3442 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3443 c            gelc(k,j)=gelc(k,j)+ghalf
3444 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3445 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3446 c          enddo
3447 cgrad          do k=i+1,j-1
3448 cgrad            do l=1,3
3449 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3450 cgrad            enddo
3451 cgrad          enddo
3452           do k=1,3
3453             gelc(k,i)=gelc(k,i)
3454      &           +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3455      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3456             gelc(k,j)=gelc(k,j)
3457      &           +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3458      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3459             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3460             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3461           enddo
3462 C MARYSIA
3463 c          endif !sscale
3464           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3465      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3466      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3467 C
3468 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3469 C   energy of a peptide unit is assumed in the form of a second-order
3470 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3471 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3472 C   are computed for EVERY pair of non-contiguous peptide groups.
3473 C
3474           if (j.lt.nres-1) then
3475             j1=j+1
3476             j2=j-1
3477           else
3478             j1=j-1
3479             j2=j-2
3480           endif
3481           kkk=0
3482           do k=1,2
3483             do l=1,2
3484               kkk=kkk+1
3485               muij(kkk)=mu(k,i)*mu(l,j)
3486             enddo
3487           enddo
3488 cd         write (iout,*) 'EELEC: i',i,' j',j
3489 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3490 cd          write(iout,*) 'muij',muij
3491           ury=scalar(uy(1,i),erij)
3492           urz=scalar(uz(1,i),erij)
3493           vry=scalar(uy(1,j),erij)
3494           vrz=scalar(uz(1,j),erij)
3495           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3496           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3497           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3498           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3499           fac=dsqrt(-ael6i)*r3ij
3500           a22=a22*fac
3501           a23=a23*fac
3502           a32=a32*fac
3503           a33=a33*fac
3504 cd          write (iout,'(4i5,4f10.5)')
3505 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3506 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3507 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3508 cd     &      uy(:,j),uz(:,j)
3509 cd          write (iout,'(4f10.5)')
3510 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3511 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3512 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3513 cd           write (iout,'(9f10.5/)')
3514 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3515 C Derivatives of the elements of A in virtual-bond vectors
3516           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3517           do k=1,3
3518             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3519             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3520             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3521             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3522             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3523             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3524             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3525             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3526             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3527             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3528             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3529             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3530           enddo
3531 C Compute radial contributions to the gradient
3532           facr=-3.0d0*rrmij
3533           a22der=a22*facr
3534           a23der=a23*facr
3535           a32der=a32*facr
3536           a33der=a33*facr
3537           agg(1,1)=a22der*xj
3538           agg(2,1)=a22der*yj
3539           agg(3,1)=a22der*zj
3540           agg(1,2)=a23der*xj
3541           agg(2,2)=a23der*yj
3542           agg(3,2)=a23der*zj
3543           agg(1,3)=a32der*xj
3544           agg(2,3)=a32der*yj
3545           agg(3,3)=a32der*zj
3546           agg(1,4)=a33der*xj
3547           agg(2,4)=a33der*yj
3548           agg(3,4)=a33der*zj
3549 C Add the contributions coming from er
3550           fac3=-3.0d0*fac
3551           do k=1,3
3552             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3553             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3554             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3555             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3556           enddo
3557           do k=1,3
3558 C Derivatives in DC(i)
3559 cgrad            ghalf1=0.5d0*agg(k,1)
3560 cgrad            ghalf2=0.5d0*agg(k,2)
3561 cgrad            ghalf3=0.5d0*agg(k,3)
3562 cgrad            ghalf4=0.5d0*agg(k,4)
3563             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3564      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3565             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3566      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3567             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3568      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3569             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3570      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3571 C Derivatives in DC(i+1)
3572             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3573      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3574             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3575      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3576             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3577      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3578             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3579      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3580 C Derivatives in DC(j)
3581             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3582      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3583             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3584      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3585             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3586      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3587             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3588      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3589 C Derivatives in DC(j+1) or DC(nres-1)
3590             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3591      &      -3.0d0*vryg(k,3)*ury)
3592             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3593      &      -3.0d0*vrzg(k,3)*ury)
3594             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3595      &      -3.0d0*vryg(k,3)*urz)
3596             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3597      &      -3.0d0*vrzg(k,3)*urz)
3598 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3599 cgrad              do l=1,4
3600 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3601 cgrad              enddo
3602 cgrad            endif
3603           enddo
3604           acipa(1,1)=a22
3605           acipa(1,2)=a23
3606           acipa(2,1)=a32
3607           acipa(2,2)=a33
3608           a22=-a22
3609           a23=-a23
3610           do l=1,2
3611             do k=1,3
3612               agg(k,l)=-agg(k,l)
3613               aggi(k,l)=-aggi(k,l)
3614               aggi1(k,l)=-aggi1(k,l)
3615               aggj(k,l)=-aggj(k,l)
3616               aggj1(k,l)=-aggj1(k,l)
3617             enddo
3618           enddo
3619           if (j.lt.nres-1) then
3620             a22=-a22
3621             a32=-a32
3622             do l=1,3,2
3623               do k=1,3
3624                 agg(k,l)=-agg(k,l)
3625                 aggi(k,l)=-aggi(k,l)
3626                 aggi1(k,l)=-aggi1(k,l)
3627                 aggj(k,l)=-aggj(k,l)
3628                 aggj1(k,l)=-aggj1(k,l)
3629               enddo
3630             enddo
3631           else
3632             a22=-a22
3633             a23=-a23
3634             a32=-a32
3635             a33=-a33
3636             do l=1,4
3637               do k=1,3
3638                 agg(k,l)=-agg(k,l)
3639                 aggi(k,l)=-aggi(k,l)
3640                 aggi1(k,l)=-aggi1(k,l)
3641                 aggj(k,l)=-aggj(k,l)
3642                 aggj1(k,l)=-aggj1(k,l)
3643               enddo
3644             enddo
3645           endif
3646           ENDIF ! WCORR
3647           IF (wel_loc.gt.0.0d0) THEN
3648 C Contribution to the local-electrostatic energy coming from the i-j pair
3649           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3650      &     +a33*muij(4)
3651 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
3652 c     &                     ' eel_loc_ij',eel_loc_ij
3653
3654           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3655      &            'eelloc',i,j,eel_loc_ij
3656 c           if (eel_loc_ij.ne.0)
3657 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
3658 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
3659
3660           eel_loc=eel_loc+eel_loc_ij
3661 C Partial derivatives in virtual-bond dihedral angles gamma
3662           if (i.gt.1)
3663      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3664      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3665      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3666           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3667      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3668      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3669 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3670           do l=1,3
3671             ggg(l)=agg(l,1)*muij(1)+
3672      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3673             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3674             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3675 cgrad            ghalf=0.5d0*ggg(l)
3676 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3677 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3678           enddo
3679 cgrad          do k=i+1,j2
3680 cgrad            do l=1,3
3681 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3682 cgrad            enddo
3683 cgrad          enddo
3684 C Remaining derivatives of eello
3685           do l=1,3
3686             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
3687      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
3688             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
3689      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
3690             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
3691      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
3692             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
3693      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
3694           enddo
3695           ENDIF
3696 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3697 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3698           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3699      &       .and. num_conti.le.maxconts) then
3700 c            write (iout,*) i,j," entered corr"
3701 C
3702 C Calculate the contact function. The ith column of the array JCONT will
3703 C contain the numbers of atoms that make contacts with the atom I (of numbers
3704 C greater than I). The arrays FACONT and GACONT will contain the values of
3705 C the contact function and its derivative.
3706 c           r0ij=1.02D0*rpp(iteli,itelj)
3707 c           r0ij=1.11D0*rpp(iteli,itelj)
3708             r0ij=2.20D0*rpp(iteli,itelj)
3709 c           r0ij=1.55D0*rpp(iteli,itelj)
3710             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3711             if (fcont.gt.0.0D0) then
3712               num_conti=num_conti+1
3713               if (num_conti.gt.maxconts) then
3714                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3715      &                         ' will skip next contacts for this conf.'
3716               else
3717                 jcont_hb(num_conti,i)=j
3718 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3719 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3720                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3721      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3722 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3723 C  terms.
3724                 d_cont(num_conti,i)=rij
3725 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3726 C     --- Electrostatic-interaction matrix ---
3727                 a_chuj(1,1,num_conti,i)=a22
3728                 a_chuj(1,2,num_conti,i)=a23
3729                 a_chuj(2,1,num_conti,i)=a32
3730                 a_chuj(2,2,num_conti,i)=a33
3731 C     --- Gradient of rij
3732                 do kkk=1,3
3733                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3734                 enddo
3735                 kkll=0
3736                 do k=1,2
3737                   do l=1,2
3738                     kkll=kkll+1
3739                     do m=1,3
3740                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3741                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3742                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3743                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3744                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3745                     enddo
3746                   enddo
3747                 enddo
3748                 ENDIF
3749                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3750 C Calculate contact energies
3751                 cosa4=4.0D0*cosa
3752                 wij=cosa-3.0D0*cosb*cosg
3753                 cosbg1=cosb+cosg
3754                 cosbg2=cosb-cosg
3755 c               fac3=dsqrt(-ael6i)/r0ij**3
3756                 fac3=dsqrt(-ael6i)*r3ij
3757 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3758                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3759                 if (ees0tmp.gt.0) then
3760                   ees0pij=dsqrt(ees0tmp)
3761                 else
3762                   ees0pij=0
3763                 endif
3764 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3765                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3766                 if (ees0tmp.gt.0) then
3767                   ees0mij=dsqrt(ees0tmp)
3768                 else
3769                   ees0mij=0
3770                 endif
3771 c               ees0mij=0.0D0
3772                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3773                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3774 C Diagnostics. Comment out or remove after debugging!
3775 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3776 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3777 c               ees0m(num_conti,i)=0.0D0
3778 C End diagnostics.
3779 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3780 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3781 C Angular derivatives of the contact function
3782                 ees0pij1=fac3/ees0pij
3783                 ees0mij1=fac3/ees0mij
3784                 fac3p=-3.0D0*fac3*rrmij
3785                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3786                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3787 c               ees0mij1=0.0D0
3788                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3789                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3790                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3791                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3792                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3793                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3794                 ecosap=ecosa1+ecosa2
3795                 ecosbp=ecosb1+ecosb2
3796                 ecosgp=ecosg1+ecosg2
3797                 ecosam=ecosa1-ecosa2
3798                 ecosbm=ecosb1-ecosb2
3799                 ecosgm=ecosg1-ecosg2
3800 C Diagnostics
3801 c               ecosap=ecosa1
3802 c               ecosbp=ecosb1
3803 c               ecosgp=ecosg1
3804 c               ecosam=0.0D0
3805 c               ecosbm=0.0D0
3806 c               ecosgm=0.0D0
3807 C End diagnostics
3808                 facont_hb(num_conti,i)=fcont
3809                 fprimcont=fprimcont/rij
3810 cd              facont_hb(num_conti,i)=1.0D0
3811 C Following line is for diagnostics.
3812 cd              fprimcont=0.0D0
3813                 do k=1,3
3814                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3815                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3816                 enddo
3817                 do k=1,3
3818                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3819                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3820                 enddo
3821                 gggp(1)=gggp(1)+ees0pijp*xj
3822                 gggp(2)=gggp(2)+ees0pijp*yj
3823                 gggp(3)=gggp(3)+ees0pijp*zj
3824                 gggm(1)=gggm(1)+ees0mijp*xj
3825                 gggm(2)=gggm(2)+ees0mijp*yj
3826                 gggm(3)=gggm(3)+ees0mijp*zj
3827 C Derivatives due to the contact function
3828                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3829                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3830                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3831                 do k=1,3
3832 c
3833 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3834 c          following the change of gradient-summation algorithm.
3835 c
3836 cgrad                  ghalfp=0.5D0*gggp(k)
3837 cgrad                  ghalfm=0.5D0*gggm(k)
3838                   gacontp_hb1(k,num_conti,i)=!ghalfp
3839      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3840      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3841                   gacontp_hb2(k,num_conti,i)=!ghalfp
3842      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3843      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3844                   gacontp_hb3(k,num_conti,i)=gggp(k)
3845                   gacontm_hb1(k,num_conti,i)=!ghalfm
3846      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3847      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3848                   gacontm_hb2(k,num_conti,i)=!ghalfm
3849      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3850      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3851                   gacontm_hb3(k,num_conti,i)=gggm(k)
3852                 enddo
3853 C Diagnostics. Comment out or remove after debugging!
3854 cdiag           do k=1,3
3855 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3856 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3857 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3858 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3859 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3860 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3861 cdiag           enddo
3862               ENDIF ! wcorr
3863               endif  ! num_conti.le.maxconts
3864             endif  ! fcont.gt.0
3865           endif    ! j.gt.i+1
3866           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3867             do k=1,4
3868               do l=1,3
3869                 ghalf=0.5d0*agg(l,k)
3870                 aggi(l,k)=aggi(l,k)+ghalf
3871                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3872                 aggj(l,k)=aggj(l,k)+ghalf
3873               enddo
3874             enddo
3875             if (j.eq.nres-1 .and. i.lt.j-2) then
3876               do k=1,4
3877                 do l=1,3
3878                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3879                 enddo
3880               enddo
3881             endif
3882           endif
3883 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3884       return
3885       end
3886 C-----------------------------------------------------------------------------
3887       subroutine eturn3(i,eello_turn3)
3888 C Third- and fourth-order contributions from turns
3889       implicit real*8 (a-h,o-z)
3890       include 'DIMENSIONS'
3891       include 'COMMON.IOUNITS'
3892       include 'COMMON.GEO'
3893       include 'COMMON.VAR'
3894       include 'COMMON.LOCAL'
3895       include 'COMMON.CHAIN'
3896       include 'COMMON.DERIV'
3897       include 'COMMON.INTERACT'
3898       include 'COMMON.CONTACTS'
3899       include 'COMMON.TORSION'
3900       include 'COMMON.VECTORS'
3901       include 'COMMON.FFIELD'
3902       include 'COMMON.CONTROL'
3903       dimension ggg(3)
3904       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3905      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3906      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3907       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3908      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3909       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3910      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3911      &    num_conti,j1,j2
3912       j=i+2
3913 c      write (iout,*) "eturn3",i,j,j1,j2
3914       a_temp(1,1)=a22
3915       a_temp(1,2)=a23
3916       a_temp(2,1)=a32
3917       a_temp(2,2)=a33
3918 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3919 C
3920 C               Third-order contributions
3921 C
3922 C                 (i+2)o----(i+3)
3923 C                      | |
3924 C                      | |
3925 C                 (i+1)o----i
3926 C
3927 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3928 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3929         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3930         call transpose2(auxmat(1,1),auxmat1(1,1))
3931         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3932         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3933         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3934      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3935 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3936 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3937 cd     &    ' eello_turn3_num',4*eello_turn3_num
3938 C Derivatives in gamma(i)
3939         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3940         call transpose2(auxmat2(1,1),auxmat3(1,1))
3941         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3942         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3943 C Derivatives in gamma(i+1)
3944         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3945         call transpose2(auxmat2(1,1),auxmat3(1,1))
3946         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3947         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3948      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3949 C Cartesian derivatives
3950         do l=1,3
3951 c            ghalf1=0.5d0*agg(l,1)
3952 c            ghalf2=0.5d0*agg(l,2)
3953 c            ghalf3=0.5d0*agg(l,3)
3954 c            ghalf4=0.5d0*agg(l,4)
3955           a_temp(1,1)=aggi(l,1)!+ghalf1
3956           a_temp(1,2)=aggi(l,2)!+ghalf2
3957           a_temp(2,1)=aggi(l,3)!+ghalf3
3958           a_temp(2,2)=aggi(l,4)!+ghalf4
3959           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3960           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3961      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3962           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3963           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3964           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3965           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3966           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3967           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3968      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3969           a_temp(1,1)=aggj(l,1)!+ghalf1
3970           a_temp(1,2)=aggj(l,2)!+ghalf2
3971           a_temp(2,1)=aggj(l,3)!+ghalf3
3972           a_temp(2,2)=aggj(l,4)!+ghalf4
3973           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3974           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3975      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3976           a_temp(1,1)=aggj1(l,1)
3977           a_temp(1,2)=aggj1(l,2)
3978           a_temp(2,1)=aggj1(l,3)
3979           a_temp(2,2)=aggj1(l,4)
3980           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3981           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3982      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3983         enddo
3984       return
3985       end
3986 C-------------------------------------------------------------------------------
3987       subroutine eturn4(i,eello_turn4)
3988 C Third- and fourth-order contributions from turns
3989       implicit real*8 (a-h,o-z)
3990       include 'DIMENSIONS'
3991       include 'COMMON.IOUNITS'
3992       include 'COMMON.GEO'
3993       include 'COMMON.VAR'
3994       include 'COMMON.LOCAL'
3995       include 'COMMON.CHAIN'
3996       include 'COMMON.DERIV'
3997       include 'COMMON.INTERACT'
3998       include 'COMMON.CONTACTS'
3999       include 'COMMON.TORSION'
4000       include 'COMMON.VECTORS'
4001       include 'COMMON.FFIELD'
4002       include 'COMMON.CONTROL'
4003       dimension ggg(3)
4004       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4005      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4006      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
4007       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4008      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4009       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4010      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4011      &    num_conti,j1,j2
4012       j=i+3
4013 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4014 C
4015 C               Fourth-order contributions
4016 C
4017 C                 (i+3)o----(i+4)
4018 C                     /  |
4019 C               (i+2)o   |
4020 C                     \  |
4021 C                 (i+1)o----i
4022 C
4023 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4024 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
4025 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4026         a_temp(1,1)=a22
4027         a_temp(1,2)=a23
4028         a_temp(2,1)=a32
4029         a_temp(2,2)=a33
4030         iti1=itortyp(itype(i+1))
4031         iti2=itortyp(itype(i+2))
4032         iti3=itortyp(itype(i+3))
4033 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4034         call transpose2(EUg(1,1,i+1),e1t(1,1))
4035         call transpose2(Eug(1,1,i+2),e2t(1,1))
4036         call transpose2(Eug(1,1,i+3),e3t(1,1))
4037         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4038         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4039         s1=scalar2(b1(1,iti2),auxvec(1))
4040         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4041         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4042         s2=scalar2(b1(1,iti1),auxvec(1))
4043         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4044         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4045         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4046         eello_turn4=eello_turn4-(s1+s2+s3)
4047 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
4048         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
4049      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
4050 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4051 cd     &    ' eello_turn4_num',8*eello_turn4_num
4052 C Derivatives in gamma(i)
4053         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4054         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4055         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4056         s1=scalar2(b1(1,iti2),auxvec(1))
4057         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4058         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4059         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
4060 C Derivatives in gamma(i+1)
4061         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4062         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4063         s2=scalar2(b1(1,iti1),auxvec(1))
4064         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4065         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4066         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4067         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
4068 C Derivatives in gamma(i+2)
4069         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4070         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4071         s1=scalar2(b1(1,iti2),auxvec(1))
4072         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4073         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4074         s2=scalar2(b1(1,iti1),auxvec(1))
4075         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
4076         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
4077         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4078         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
4079 C Cartesian derivatives
4080 C Derivatives of this turn contributions in DC(i+2)
4081         if (j.lt.nres-1) then
4082           do l=1,3
4083             a_temp(1,1)=agg(l,1)
4084             a_temp(1,2)=agg(l,2)
4085             a_temp(2,1)=agg(l,3)
4086             a_temp(2,2)=agg(l,4)
4087             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4088             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4089             s1=scalar2(b1(1,iti2),auxvec(1))
4090             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4091             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4092             s2=scalar2(b1(1,iti1),auxvec(1))
4093             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4094             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4095             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4096             ggg(l)=-(s1+s2+s3)
4097             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
4098           enddo
4099         endif
4100 C Remaining derivatives of this turn contribution
4101         do l=1,3
4102           a_temp(1,1)=aggi(l,1)
4103           a_temp(1,2)=aggi(l,2)
4104           a_temp(2,1)=aggi(l,3)
4105           a_temp(2,2)=aggi(l,4)
4106           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4107           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4108           s1=scalar2(b1(1,iti2),auxvec(1))
4109           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4110           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4111           s2=scalar2(b1(1,iti1),auxvec(1))
4112           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4113           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4114           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4115           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
4116           a_temp(1,1)=aggi1(l,1)
4117           a_temp(1,2)=aggi1(l,2)
4118           a_temp(2,1)=aggi1(l,3)
4119           a_temp(2,2)=aggi1(l,4)
4120           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4121           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4122           s1=scalar2(b1(1,iti2),auxvec(1))
4123           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4124           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4125           s2=scalar2(b1(1,iti1),auxvec(1))
4126           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4127           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4128           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4129           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
4130           a_temp(1,1)=aggj(l,1)
4131           a_temp(1,2)=aggj(l,2)
4132           a_temp(2,1)=aggj(l,3)
4133           a_temp(2,2)=aggj(l,4)
4134           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4135           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4136           s1=scalar2(b1(1,iti2),auxvec(1))
4137           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4138           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4139           s2=scalar2(b1(1,iti1),auxvec(1))
4140           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4141           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4142           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4143           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
4144           a_temp(1,1)=aggj1(l,1)
4145           a_temp(1,2)=aggj1(l,2)
4146           a_temp(2,1)=aggj1(l,3)
4147           a_temp(2,2)=aggj1(l,4)
4148           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4149           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4150           s1=scalar2(b1(1,iti2),auxvec(1))
4151           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4152           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4153           s2=scalar2(b1(1,iti1),auxvec(1))
4154           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4155           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4156           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4157 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4158           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4159         enddo
4160       return
4161       end
4162 C-----------------------------------------------------------------------------
4163       subroutine vecpr(u,v,w)
4164       implicit real*8(a-h,o-z)
4165       dimension u(3),v(3),w(3)
4166       w(1)=u(2)*v(3)-u(3)*v(2)
4167       w(2)=-u(1)*v(3)+u(3)*v(1)
4168       w(3)=u(1)*v(2)-u(2)*v(1)
4169       return
4170       end
4171 C-----------------------------------------------------------------------------
4172       subroutine unormderiv(u,ugrad,unorm,ungrad)
4173 C This subroutine computes the derivatives of a normalized vector u, given
4174 C the derivatives computed without normalization conditions, ugrad. Returns
4175 C ungrad.
4176       implicit none
4177       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4178       double precision vec(3)
4179       double precision scalar
4180       integer i,j
4181 c      write (2,*) 'ugrad',ugrad
4182 c      write (2,*) 'u',u
4183       do i=1,3
4184         vec(i)=scalar(ugrad(1,i),u(1))
4185       enddo
4186 c      write (2,*) 'vec',vec
4187       do i=1,3
4188         do j=1,3
4189           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4190         enddo
4191       enddo
4192 c      write (2,*) 'ungrad',ungrad
4193       return
4194       end
4195 C-----------------------------------------------------------------------------
4196       subroutine escp_soft_sphere(evdw2,evdw2_14)
4197 C
4198 C This subroutine calculates the excluded-volume interaction energy between
4199 C peptide-group centers and side chains and its gradient in virtual-bond and
4200 C side-chain vectors.
4201 C
4202       implicit real*8 (a-h,o-z)
4203       include 'DIMENSIONS'
4204       include 'COMMON.GEO'
4205       include 'COMMON.VAR'
4206       include 'COMMON.LOCAL'
4207       include 'COMMON.CHAIN'
4208       include 'COMMON.DERIV'
4209       include 'COMMON.INTERACT'
4210       include 'COMMON.FFIELD'
4211       include 'COMMON.IOUNITS'
4212       include 'COMMON.CONTROL'
4213       dimension ggg(3)
4214       evdw2=0.0D0
4215       evdw2_14=0.0d0
4216       r0_scp=4.5d0
4217 cd    print '(a)','Enter ESCP'
4218 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4219 C      do xshift=-1,1
4220 C      do yshift=-1,1
4221 C      do zshift=-1,1
4222       do i=iatscp_s,iatscp_e
4223         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4224         iteli=itel(i)
4225         xi=0.5D0*(c(1,i)+c(1,i+1))
4226         yi=0.5D0*(c(2,i)+c(2,i+1))
4227         zi=0.5D0*(c(3,i)+c(3,i+1))
4228 C Return atom into box, boxxsize is size of box in x dimension
4229 c  134   continue
4230 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4231 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4232 C Condition for being inside the proper box
4233 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4234 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4235 c        go to 134
4236 c        endif
4237 c  135   continue
4238 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4239 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4240 C Condition for being inside the proper box
4241 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4242 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4243 c        go to 135
4244 c c       endif
4245 c  136   continue
4246 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4247 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4248 cC Condition for being inside the proper box
4249 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4250 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4251 c        go to 136
4252 c        endif
4253           xi=mod(xi,boxxsize)
4254           if (xi.lt.0) xi=xi+boxxsize
4255           yi=mod(yi,boxysize)
4256           if (yi.lt.0) yi=yi+boxysize
4257           zi=mod(zi,boxzsize)
4258           if (zi.lt.0) zi=zi+boxzsize
4259 C          xi=xi+xshift*boxxsize
4260 C          yi=yi+yshift*boxysize
4261 C          zi=zi+zshift*boxzsize
4262         do iint=1,nscp_gr(i)
4263
4264         do j=iscpstart(i,iint),iscpend(i,iint)
4265           if (itype(j).eq.ntyp1) cycle
4266           itypj=iabs(itype(j))
4267 C Uncomment following three lines for SC-p interactions
4268 c         xj=c(1,nres+j)-xi
4269 c         yj=c(2,nres+j)-yi
4270 c         zj=c(3,nres+j)-zi
4271 C Uncomment following three lines for Ca-p interactions
4272           xj=c(1,j)
4273           yj=c(2,j)
4274           zj=c(3,j)
4275 c  174   continue
4276 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4277 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4278 C Condition for being inside the proper box
4279 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
4280 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
4281 c        go to 174
4282 c        endif
4283 c  175   continue
4284 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4285 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4286 cC Condition for being inside the proper box
4287 c        if ((yj.gt.((0.5d0)*boxysize)).or.
4288 c     &       (yj.lt.((-0.5d0)*boxysize))) then
4289 c        go to 175
4290 c        endif
4291 c  176   continue
4292 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4293 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4294 C Condition for being inside the proper box
4295 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
4296 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
4297 c        go to 176
4298           xj=mod(xj,boxxsize)
4299           if (xj.lt.0) xj=xj+boxxsize
4300           yj=mod(yj,boxysize)
4301           if (yj.lt.0) yj=yj+boxysize
4302           zj=mod(zj,boxzsize)
4303           if (zj.lt.0) zj=zj+boxzsize
4304       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4305       xj_safe=xj
4306       yj_safe=yj
4307       zj_safe=zj
4308       subchap=0
4309       do xshift=-1,1
4310       do yshift=-1,1
4311       do zshift=-1,1
4312           xj=xj_safe+xshift*boxxsize
4313           yj=yj_safe+yshift*boxysize
4314           zj=zj_safe+zshift*boxzsize
4315           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4316           if(dist_temp.lt.dist_init) then
4317             dist_init=dist_temp
4318             xj_temp=xj
4319             yj_temp=yj
4320             zj_temp=zj
4321             subchap=1
4322           endif
4323        enddo
4324        enddo
4325        enddo
4326        if (subchap.eq.1) then
4327           xj=xj_temp-xi
4328           yj=yj_temp-yi
4329           zj=zj_temp-zi
4330        else
4331           xj=xj_safe-xi
4332           yj=yj_safe-yi
4333           zj=zj_safe-zi
4334        endif
4335 c c       endif
4336 C          xj=xj-xi
4337 C          yj=yj-yi
4338 C          zj=zj-zi
4339           rij=xj*xj+yj*yj+zj*zj
4340
4341           r0ij=r0_scp
4342           r0ijsq=r0ij*r0ij
4343           if (rij.lt.r0ijsq) then
4344             evdwij=0.25d0*(rij-r0ijsq)**2
4345             fac=rij-r0ijsq
4346           else
4347             evdwij=0.0d0
4348             fac=0.0d0
4349           endif
4350           evdw2=evdw2+evdwij
4351 C
4352 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4353 C
4354           ggg(1)=xj*fac
4355           ggg(2)=yj*fac
4356           ggg(3)=zj*fac
4357 cgrad          if (j.lt.i) then
4358 cd          write (iout,*) 'j<i'
4359 C Uncomment following three lines for SC-p interactions
4360 c           do k=1,3
4361 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4362 c           enddo
4363 cgrad          else
4364 cd          write (iout,*) 'j>i'
4365 cgrad            do k=1,3
4366 cgrad              ggg(k)=-ggg(k)
4367 C Uncomment following line for SC-p interactions
4368 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4369 cgrad            enddo
4370 cgrad          endif
4371 cgrad          do k=1,3
4372 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4373 cgrad          enddo
4374 cgrad          kstart=min0(i+1,j)
4375 cgrad          kend=max0(i-1,j-1)
4376 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4377 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4378 cgrad          do k=kstart,kend
4379 cgrad            do l=1,3
4380 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4381 cgrad            enddo
4382 cgrad          enddo
4383           do k=1,3
4384             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4385             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4386           enddo
4387         enddo
4388
4389         enddo ! iint
4390       enddo ! i
4391 C      enddo !zshift
4392 C      enddo !yshift
4393 C      enddo !xshift
4394       return
4395       end
4396 C-----------------------------------------------------------------------------
4397       subroutine escp(evdw2,evdw2_14)
4398 C
4399 C This subroutine calculates the excluded-volume interaction energy between
4400 C peptide-group centers and side chains and its gradient in virtual-bond and
4401 C side-chain vectors.
4402 C
4403       implicit real*8 (a-h,o-z)
4404       include 'DIMENSIONS'
4405       include 'COMMON.GEO'
4406       include 'COMMON.VAR'
4407       include 'COMMON.LOCAL'
4408       include 'COMMON.CHAIN'
4409       include 'COMMON.DERIV'
4410       include 'COMMON.INTERACT'
4411       include 'COMMON.FFIELD'
4412       include 'COMMON.IOUNITS'
4413       include 'COMMON.CONTROL'
4414       include 'COMMON.SPLITELE'
4415       dimension ggg(3)
4416       evdw2=0.0D0
4417       evdw2_14=0.0d0
4418 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
4419 cd    print '(a)','Enter ESCP'
4420 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4421 C      do xshift=-1,1
4422 C      do yshift=-1,1
4423 C      do zshift=-1,1
4424       do i=iatscp_s,iatscp_e
4425         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4426         iteli=itel(i)
4427         xi=0.5D0*(c(1,i)+c(1,i+1))
4428         yi=0.5D0*(c(2,i)+c(2,i+1))
4429         zi=0.5D0*(c(3,i)+c(3,i+1))
4430           xi=mod(xi,boxxsize)
4431           if (xi.lt.0) xi=xi+boxxsize
4432           yi=mod(yi,boxysize)
4433           if (yi.lt.0) yi=yi+boxysize
4434           zi=mod(zi,boxzsize)
4435           if (zi.lt.0) zi=zi+boxzsize
4436 c          xi=xi+xshift*boxxsize
4437 c          yi=yi+yshift*boxysize
4438 c          zi=zi+zshift*boxzsize
4439 c        print *,xi,yi,zi,'polozenie i'
4440 C Return atom into box, boxxsize is size of box in x dimension
4441 c  134   continue
4442 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4443 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4444 C Condition for being inside the proper box
4445 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4446 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4447 c        go to 134
4448 c        endif
4449 c  135   continue
4450 c          print *,xi,boxxsize,"pierwszy"
4451
4452 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4453 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4454 C Condition for being inside the proper box
4455 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4456 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4457 c        go to 135
4458 c        endif
4459 c  136   continue
4460 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4461 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4462 C Condition for being inside the proper box
4463 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4464 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4465 c        go to 136
4466 c        endif
4467         do iint=1,nscp_gr(i)
4468
4469         do j=iscpstart(i,iint),iscpend(i,iint)
4470           itypj=iabs(itype(j))
4471           if (itypj.eq.ntyp1) cycle
4472 C Uncomment following three lines for SC-p interactions
4473 c         xj=c(1,nres+j)-xi
4474 c         yj=c(2,nres+j)-yi
4475 c         zj=c(3,nres+j)-zi
4476 C Uncomment following three lines for Ca-p interactions
4477           xj=c(1,j)
4478           yj=c(2,j)
4479           zj=c(3,j)
4480           xj=mod(xj,boxxsize)
4481           if (xj.lt.0) xj=xj+boxxsize
4482           yj=mod(yj,boxysize)
4483           if (yj.lt.0) yj=yj+boxysize
4484           zj=mod(zj,boxzsize)
4485           if (zj.lt.0) zj=zj+boxzsize
4486 c  174   continue
4487 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4488 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4489 C Condition for being inside the proper box
4490 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
4491 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
4492 c        go to 174
4493 c        endif
4494 c  175   continue
4495 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4496 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4497 cC Condition for being inside the proper box
4498 c        if ((yj.gt.((0.5d0)*boxysize)).or.
4499 c     &       (yj.lt.((-0.5d0)*boxysize))) then
4500 c        go to 175
4501 c        endif
4502 c  176   continue
4503 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4504 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4505 C Condition for being inside the proper box
4506 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
4507 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
4508 c        go to 176
4509 c        endif
4510 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
4511       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4512       xj_safe=xj
4513       yj_safe=yj
4514       zj_safe=zj
4515       subchap=0
4516       do xshift=-1,1
4517       do yshift=-1,1
4518       do zshift=-1,1
4519           xj=xj_safe+xshift*boxxsize
4520           yj=yj_safe+yshift*boxysize
4521           zj=zj_safe+zshift*boxzsize
4522           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4523           if(dist_temp.lt.dist_init) then
4524             dist_init=dist_temp
4525             xj_temp=xj
4526             yj_temp=yj
4527             zj_temp=zj
4528             subchap=1
4529           endif
4530        enddo
4531        enddo
4532        enddo
4533        if (subchap.eq.1) then
4534           xj=xj_temp-xi
4535           yj=yj_temp-yi
4536           zj=zj_temp-zi
4537        else
4538           xj=xj_safe-xi
4539           yj=yj_safe-yi
4540           zj=zj_safe-zi
4541        endif
4542 c          print *,xj,yj,zj,'polozenie j'
4543           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4544 c          print *,rrij
4545           sss=sscale(1.0d0/(dsqrt(rrij)))
4546 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
4547 c          if (sss.eq.0) print *,'czasem jest OK'
4548           if (sss.le.0.0d0) cycle
4549           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
4550           fac=rrij**expon2
4551           e1=fac*fac*aad(itypj,iteli)
4552           e2=fac*bad(itypj,iteli)
4553           if (iabs(j-i) .le. 2) then
4554             e1=scal14*e1
4555             e2=scal14*e2
4556             evdw2_14=evdw2_14+(e1+e2)*sss
4557           endif
4558           evdwij=e1+e2
4559           evdw2=evdw2+evdwij*sss
4560           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
4561      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
4562      &       bad(itypj,iteli)
4563 C
4564 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4565 C
4566           fac=-(evdwij+e1)*rrij*sss
4567           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
4568           ggg(1)=xj*fac
4569           ggg(2)=yj*fac
4570           ggg(3)=zj*fac
4571 cgrad          if (j.lt.i) then
4572 cd          write (iout,*) 'j<i'
4573 C Uncomment following three lines for SC-p interactions
4574 c           do k=1,3
4575 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4576 c           enddo
4577 cgrad          else
4578 cd          write (iout,*) 'j>i'
4579 cgrad            do k=1,3
4580 cgrad              ggg(k)=-ggg(k)
4581 C Uncomment following line for SC-p interactions
4582 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4583 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4584 cgrad            enddo
4585 cgrad          endif
4586 cgrad          do k=1,3
4587 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4588 cgrad          enddo
4589 cgrad          kstart=min0(i+1,j)
4590 cgrad          kend=max0(i-1,j-1)
4591 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4592 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4593 cgrad          do k=kstart,kend
4594 cgrad            do l=1,3
4595 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4596 cgrad            enddo
4597 cgrad          enddo
4598           do k=1,3
4599             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4600             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4601           enddo
4602 c        endif !endif for sscale cutoff
4603         enddo ! j
4604
4605         enddo ! iint
4606       enddo ! i
4607 c      enddo !zshift
4608 c      enddo !yshift
4609 c      enddo !xshift
4610       do i=1,nct
4611         do j=1,3
4612           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4613           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4614           gradx_scp(j,i)=expon*gradx_scp(j,i)
4615         enddo
4616       enddo
4617 C******************************************************************************
4618 C
4619 C                              N O T E !!!
4620 C
4621 C To save time the factor EXPON has been extracted from ALL components
4622 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4623 C use!
4624 C
4625 C******************************************************************************
4626       return
4627       end
4628 C--------------------------------------------------------------------------
4629       subroutine edis(ehpb)
4630 C
4631 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4632 C
4633       implicit real*8 (a-h,o-z)
4634       include 'DIMENSIONS'
4635       include 'COMMON.SBRIDGE'
4636       include 'COMMON.CHAIN'
4637       include 'COMMON.DERIV'
4638       include 'COMMON.VAR'
4639       include 'COMMON.INTERACT'
4640       include 'COMMON.IOUNITS'
4641       dimension ggg(3)
4642       ehpb=0.0D0
4643 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4644 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4645       if (link_end.eq.0) return
4646       do i=link_start,link_end
4647 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4648 C CA-CA distance used in regularization of structure.
4649         ii=ihpb(i)
4650         jj=jhpb(i)
4651 C iii and jjj point to the residues for which the distance is assigned.
4652         if (ii.gt.nres) then
4653           iii=ii-nres
4654           jjj=jj-nres
4655         else
4656           iii=ii
4657           jjj=jj
4658         endif
4659 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4660 c     &    dhpb(i),dhpb1(i),forcon(i)
4661 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4662 C    distance and angle dependent SS bond potential.
4663         if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4664      & iabs(itype(jjj)).eq.1) then
4665 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4666 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4667         if (.not.dyn_ss .and. i.le.nss) then
4668 C 15/02/13 CC dynamic SSbond - additional check
4669          if (ii.gt.nres
4670      &       .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4671 >>>>>>> f5379d3246c4bd95e946c4d35d4a1c13e329c4cb
4672           call ssbond_ene(iii,jjj,eij)
4673           ehpb=ehpb+2*eij
4674          endif
4675 cd          write (iout,*) "eij",eij
4676         else
4677 C Calculate the distance between the two points and its difference from the
4678 C target distance.
4679           dd=dist(ii,jj)
4680             rdis=dd-dhpb(i)
4681 C Get the force constant corresponding to this distance.
4682             waga=forcon(i)
4683 C Calculate the contribution to energy.
4684             ehpb=ehpb+waga*rdis*rdis
4685 C
4686 C Evaluate gradient.
4687 C
4688             fac=waga*rdis/dd
4689 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4690 cd   &   ' waga=',waga,' fac=',fac
4691             do j=1,3
4692               ggg(j)=fac*(c(j,jj)-c(j,ii))
4693             enddo
4694 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4695 C If this is a SC-SC distance, we need to calculate the contributions to the
4696 C Cartesian gradient in the SC vectors (ghpbx).
4697           if (iii.lt.ii) then
4698           do j=1,3
4699             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4700             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4701           enddo
4702           endif
4703 cgrad        do j=iii,jjj-1
4704 cgrad          do k=1,3
4705 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4706 cgrad          enddo
4707 cgrad        enddo
4708           do k=1,3
4709             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4710             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4711           enddo
4712         endif
4713       enddo
4714       ehpb=0.5D0*ehpb
4715       return
4716       end
4717 C--------------------------------------------------------------------------
4718       subroutine ssbond_ene(i,j,eij)
4719 C
4720 C Calculate the distance and angle dependent SS-bond potential energy
4721 C using a free-energy function derived based on RHF/6-31G** ab initio
4722 C calculations of diethyl disulfide.
4723 C
4724 C A. Liwo and U. Kozlowska, 11/24/03
4725 C
4726       implicit real*8 (a-h,o-z)
4727       include 'DIMENSIONS'
4728       include 'COMMON.SBRIDGE'
4729       include 'COMMON.CHAIN'
4730       include 'COMMON.DERIV'
4731       include 'COMMON.LOCAL'
4732       include 'COMMON.INTERACT'
4733       include 'COMMON.VAR'
4734       include 'COMMON.IOUNITS'
4735       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4736       itypi=iabs(itype(i))
4737       xi=c(1,nres+i)
4738       yi=c(2,nres+i)
4739       zi=c(3,nres+i)
4740       dxi=dc_norm(1,nres+i)
4741       dyi=dc_norm(2,nres+i)
4742       dzi=dc_norm(3,nres+i)
4743 c      dsci_inv=dsc_inv(itypi)
4744       dsci_inv=vbld_inv(nres+i)
4745       itypj=iabs(itype(j))
4746 c      dscj_inv=dsc_inv(itypj)
4747       dscj_inv=vbld_inv(nres+j)
4748       xj=c(1,nres+j)-xi
4749       yj=c(2,nres+j)-yi
4750       zj=c(3,nres+j)-zi
4751       dxj=dc_norm(1,nres+j)
4752       dyj=dc_norm(2,nres+j)
4753       dzj=dc_norm(3,nres+j)
4754       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4755       rij=dsqrt(rrij)
4756       erij(1)=xj*rij
4757       erij(2)=yj*rij
4758       erij(3)=zj*rij
4759       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4760       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4761       om12=dxi*dxj+dyi*dyj+dzi*dzj
4762       do k=1,3
4763         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4764         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4765       enddo
4766       rij=1.0d0/rij
4767       deltad=rij-d0cm
4768       deltat1=1.0d0-om1
4769       deltat2=1.0d0+om2
4770       deltat12=om2-om1+2.0d0
4771       cosphi=om12-om1*om2
4772       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4773      &  +akct*deltad*deltat12
4774      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
4775 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4776 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4777 c     &  " deltat12",deltat12," eij",eij
4778       ed=2*akcm*deltad+akct*deltat12
4779       pom1=akct*deltad
4780       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4781       eom1=-2*akth*deltat1-pom1-om2*pom2
4782       eom2= 2*akth*deltat2+pom1-om1*pom2
4783       eom12=pom2
4784       do k=1,3
4785         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4786         ghpbx(k,i)=ghpbx(k,i)-ggk
4787      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4788      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4789         ghpbx(k,j)=ghpbx(k,j)+ggk
4790      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4791      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4792         ghpbc(k,i)=ghpbc(k,i)-ggk
4793         ghpbc(k,j)=ghpbc(k,j)+ggk
4794       enddo
4795 C
4796 C Calculate the components of the gradient in DC and X
4797 C
4798 cgrad      do k=i,j-1
4799 cgrad        do l=1,3
4800 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4801 cgrad        enddo
4802 cgrad      enddo
4803       return
4804       end
4805 C--------------------------------------------------------------------------
4806       subroutine ebond(estr)
4807 c
4808 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4809 c
4810       implicit real*8 (a-h,o-z)
4811       include 'DIMENSIONS'
4812       include 'COMMON.LOCAL'
4813       include 'COMMON.GEO'
4814       include 'COMMON.INTERACT'
4815       include 'COMMON.DERIV'
4816       include 'COMMON.VAR'
4817       include 'COMMON.CHAIN'
4818       include 'COMMON.IOUNITS'
4819       include 'COMMON.NAMES'
4820       include 'COMMON.FFIELD'
4821       include 'COMMON.CONTROL'
4822       include 'COMMON.SETUP'
4823       double precision u(3),ud(3)
4824       estr=0.0d0
4825       estr1=0.0d0
4826       do i=ibondp_start,ibondp_end
4827         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
4828 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4829 c          do j=1,3
4830 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4831 c     &      *dc(j,i-1)/vbld(i)
4832 c          enddo
4833 c          if (energy_dec) write(iout,*)
4834 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
4835 c        else
4836 C       Checking if it involves dummy (NH3+ or COO-) group
4837          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4838 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
4839         diff = vbld(i)-vbldpDUM
4840          else
4841 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
4842         diff = vbld(i)-vbldp0
4843          endif
4844         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
4845      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4846         estr=estr+diff*diff
4847         do j=1,3
4848           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4849         enddo
4850 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4851 c        endif
4852       enddo
4853       estr=0.5d0*AKP*estr+estr1
4854 c
4855 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4856 c
4857       do i=ibond_start,ibond_end
4858         iti=iabs(itype(i))
4859         if (iti.ne.10 .and. iti.ne.ntyp1) then
4860           nbi=nbondterm(iti)
4861           if (nbi.eq.1) then
4862             diff=vbld(i+nres)-vbldsc0(1,iti)
4863             if (energy_dec)  write (iout,*)
4864      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4865      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4866             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4867             do j=1,3
4868               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4869             enddo
4870           else
4871             do j=1,nbi
4872               diff=vbld(i+nres)-vbldsc0(j,iti)
4873               ud(j)=aksc(j,iti)*diff
4874               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4875             enddo
4876             uprod=u(1)
4877             do j=2,nbi
4878               uprod=uprod*u(j)
4879             enddo
4880             usum=0.0d0
4881             usumsqder=0.0d0
4882             do j=1,nbi
4883               uprod1=1.0d0
4884               uprod2=1.0d0
4885               do k=1,nbi
4886                 if (k.ne.j) then
4887                   uprod1=uprod1*u(k)
4888                   uprod2=uprod2*u(k)*u(k)
4889                 endif
4890               enddo
4891               usum=usum+uprod1
4892               usumsqder=usumsqder+ud(j)*uprod2
4893             enddo
4894             estr=estr+uprod/usum
4895             do j=1,3
4896              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4897             enddo
4898           endif
4899         endif
4900       enddo
4901       return
4902       end
4903 #ifdef CRYST_THETA
4904 C--------------------------------------------------------------------------
4905       subroutine ebend(etheta)
4906 C
4907 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4908 C angles gamma and its derivatives in consecutive thetas and gammas.
4909 C
4910       implicit real*8 (a-h,o-z)
4911       include 'DIMENSIONS'
4912       include 'COMMON.LOCAL'
4913       include 'COMMON.GEO'
4914       include 'COMMON.INTERACT'
4915       include 'COMMON.DERIV'
4916       include 'COMMON.VAR'
4917       include 'COMMON.CHAIN'
4918       include 'COMMON.IOUNITS'
4919       include 'COMMON.NAMES'
4920       include 'COMMON.FFIELD'
4921       include 'COMMON.CONTROL'
4922       common /calcthet/ term1,term2,termm,diffak,ratak,
4923      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4924      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4925       double precision y(2),z(2)
4926       delta=0.02d0*pi
4927 c      time11=dexp(-2*time)
4928 c      time12=1.0d0
4929       etheta=0.0D0
4930 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4931       do i=ithet_start,ithet_end
4932         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
4933      &  .or.itype(i).eq.ntyp1) cycle
4934 C Zero the energy function and its derivative at 0 or pi.
4935         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4936         it=itype(i-1)
4937         ichir1=isign(1,itype(i-2))
4938         ichir2=isign(1,itype(i))
4939          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4940          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4941          if (itype(i-1).eq.10) then
4942           itype1=isign(10,itype(i-2))
4943           ichir11=isign(1,itype(i-2))
4944           ichir12=isign(1,itype(i-2))
4945           itype2=isign(10,itype(i))
4946           ichir21=isign(1,itype(i))
4947           ichir22=isign(1,itype(i))
4948          endif
4949
4950         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4951 #ifdef OSF
4952           phii=phi(i)
4953           if (phii.ne.phii) phii=150.0
4954 #else
4955           phii=phi(i)
4956 #endif
4957           y(1)=dcos(phii)
4958           y(2)=dsin(phii)
4959         else
4960           y(1)=0.0D0
4961           y(2)=0.0D0
4962         endif
4963         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4964 #ifdef OSF
4965           phii1=phi(i+1)
4966           if (phii1.ne.phii1) phii1=150.0
4967           phii1=pinorm(phii1)
4968           z(1)=cos(phii1)
4969 #else
4970           phii1=phi(i+1)
4971 #endif
4972           z(1)=dcos(phii1)
4973           z(2)=dsin(phii1)
4974         else
4975           z(1)=0.0D0
4976           z(2)=0.0D0
4977         endif
4978 C Calculate the "mean" value of theta from the part of the distribution
4979 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4980 C In following comments this theta will be referred to as t_c.
4981         thet_pred_mean=0.0d0
4982         do k=1,2
4983             athetk=athet(k,it,ichir1,ichir2)
4984             bthetk=bthet(k,it,ichir1,ichir2)
4985           if (it.eq.10) then
4986              athetk=athet(k,itype1,ichir11,ichir12)
4987              bthetk=bthet(k,itype2,ichir21,ichir22)
4988           endif
4989          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4990 c         write(iout,*) 'chuj tu', y(k),z(k)
4991         enddo
4992         dthett=thet_pred_mean*ssd
4993         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4994 C Derivatives of the "mean" values in gamma1 and gamma2.
4995         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4996      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4997          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4998      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4999          if (it.eq.10) then
5000       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
5001      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
5002         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
5003      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5004          endif
5005         if (theta(i).gt.pi-delta) then
5006           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
5007      &         E_tc0)
5008           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5009           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5010           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
5011      &        E_theta)
5012           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
5013      &        E_tc)
5014         else if (theta(i).lt.delta) then
5015           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5016           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5017           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
5018      &        E_theta)
5019           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5020           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
5021      &        E_tc)
5022         else
5023           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
5024      &        E_theta,E_tc)
5025         endif
5026         etheta=etheta+ethetai
5027         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
5028      &      'ebend',i,ethetai,theta(i),itype(i)
5029         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5030         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5031         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
5032       enddo
5033 C Ufff.... We've done all this!!!
5034       return
5035       end
5036 C---------------------------------------------------------------------------
5037       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
5038      &     E_tc)
5039       implicit real*8 (a-h,o-z)
5040       include 'DIMENSIONS'
5041       include 'COMMON.LOCAL'
5042       include 'COMMON.IOUNITS'
5043       common /calcthet/ term1,term2,termm,diffak,ratak,
5044      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5045      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5046 C Calculate the contributions to both Gaussian lobes.
5047 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5048 C The "polynomial part" of the "standard deviation" of this part of
5049 C the distributioni.
5050 ccc        write (iout,*) thetai,thet_pred_mean
5051         sig=polthet(3,it)
5052         do j=2,0,-1
5053           sig=sig*thet_pred_mean+polthet(j,it)
5054         enddo
5055 C Derivative of the "interior part" of the "standard deviation of the"
5056 C gamma-dependent Gaussian lobe in t_c.
5057         sigtc=3*polthet(3,it)
5058         do j=2,1,-1
5059           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5060         enddo
5061         sigtc=sig*sigtc
5062 C Set the parameters of both Gaussian lobes of the distribution.
5063 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5064         fac=sig*sig+sigc0(it)
5065         sigcsq=fac+fac
5066         sigc=1.0D0/sigcsq
5067 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5068         sigsqtc=-4.0D0*sigcsq*sigtc
5069 c       print *,i,sig,sigtc,sigsqtc
5070 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
5071         sigtc=-sigtc/(fac*fac)
5072 C Following variable is sigma(t_c)**(-2)
5073         sigcsq=sigcsq*sigcsq
5074         sig0i=sig0(it)
5075         sig0inv=1.0D0/sig0i**2
5076         delthec=thetai-thet_pred_mean
5077         delthe0=thetai-theta0i
5078         term1=-0.5D0*sigcsq*delthec*delthec
5079         term2=-0.5D0*sig0inv*delthe0*delthe0
5080 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
5081 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5082 C NaNs in taking the logarithm. We extract the largest exponent which is added
5083 C to the energy (this being the log of the distribution) at the end of energy
5084 C term evaluation for this virtual-bond angle.
5085         if (term1.gt.term2) then
5086           termm=term1
5087           term2=dexp(term2-termm)
5088           term1=1.0d0
5089         else
5090           termm=term2
5091           term1=dexp(term1-termm)
5092           term2=1.0d0
5093         endif
5094 C The ratio between the gamma-independent and gamma-dependent lobes of
5095 C the distribution is a Gaussian function of thet_pred_mean too.
5096         diffak=gthet(2,it)-thet_pred_mean
5097         ratak=diffak/gthet(3,it)**2
5098         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5099 C Let's differentiate it in thet_pred_mean NOW.
5100         aktc=ak*ratak
5101 C Now put together the distribution terms to make complete distribution.
5102         termexp=term1+ak*term2
5103         termpre=sigc+ak*sig0i
5104 C Contribution of the bending energy from this theta is just the -log of
5105 C the sum of the contributions from the two lobes and the pre-exponential
5106 C factor. Simple enough, isn't it?
5107         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5108 C       write (iout,*) 'termexp',termexp,termm,termpre,i
5109 C NOW the derivatives!!!
5110 C 6/6/97 Take into account the deformation.
5111         E_theta=(delthec*sigcsq*term1
5112      &       +ak*delthe0*sig0inv*term2)/termexp
5113         E_tc=((sigtc+aktc*sig0i)/termpre
5114      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
5115      &       aktc*term2)/termexp)
5116       return
5117       end
5118 c-----------------------------------------------------------------------------
5119       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
5120       implicit real*8 (a-h,o-z)
5121       include 'DIMENSIONS'
5122       include 'COMMON.LOCAL'
5123       include 'COMMON.IOUNITS'
5124       common /calcthet/ term1,term2,termm,diffak,ratak,
5125      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5126      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5127       delthec=thetai-thet_pred_mean
5128       delthe0=thetai-theta0i
5129 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
5130       t3 = thetai-thet_pred_mean
5131       t6 = t3**2
5132       t9 = term1
5133       t12 = t3*sigcsq
5134       t14 = t12+t6*sigsqtc
5135       t16 = 1.0d0
5136       t21 = thetai-theta0i
5137       t23 = t21**2
5138       t26 = term2
5139       t27 = t21*t26
5140       t32 = termexp
5141       t40 = t32**2
5142       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
5143      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
5144      & *(-t12*t9-ak*sig0inv*t27)
5145       return
5146       end
5147 #else
5148 C--------------------------------------------------------------------------
5149       subroutine ebend(etheta)
5150 C
5151 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5152 C angles gamma and its derivatives in consecutive thetas and gammas.
5153 C ab initio-derived potentials from
5154 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5155 C
5156       implicit real*8 (a-h,o-z)
5157       include 'DIMENSIONS'
5158       include 'COMMON.LOCAL'
5159       include 'COMMON.GEO'
5160       include 'COMMON.INTERACT'
5161       include 'COMMON.DERIV'
5162       include 'COMMON.VAR'
5163       include 'COMMON.CHAIN'
5164       include 'COMMON.IOUNITS'
5165       include 'COMMON.NAMES'
5166       include 'COMMON.FFIELD'
5167       include 'COMMON.CONTROL'
5168       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
5169      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
5170      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
5171      & sinph1ph2(maxdouble,maxdouble)
5172       logical lprn /.false./, lprn1 /.false./
5173       etheta=0.0D0
5174       do i=ithet_start,ithet_end
5175 c        print *,i,itype(i-1),itype(i),itype(i-2)
5176         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5177      &  .or.itype(i).eq.ntyp1) cycle
5178 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
5179
5180         if (iabs(itype(i+1)).eq.20) iblock=2
5181         if (iabs(itype(i+1)).ne.20) iblock=1
5182         dethetai=0.0d0
5183         dephii=0.0d0
5184         dephii1=0.0d0
5185         theti2=0.5d0*theta(i)
5186         ityp2=ithetyp((itype(i-1)))
5187         do k=1,nntheterm
5188           coskt(k)=dcos(k*theti2)
5189           sinkt(k)=dsin(k*theti2)
5190         enddo
5191         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5192 #ifdef OSF
5193           phii=phi(i)
5194           if (phii.ne.phii) phii=150.0
5195 #else
5196           phii=phi(i)
5197 #endif
5198           ityp1=ithetyp((itype(i-2)))
5199 C propagation of chirality for glycine type
5200           do k=1,nsingle
5201             cosph1(k)=dcos(k*phii)
5202             sinph1(k)=dsin(k*phii)
5203           enddo
5204         else
5205           phii=0.0d0
5206           ityp1=nthetyp+1
5207           do k=1,nsingle
5208             cosph1(k)=0.0d0
5209             sinph1(k)=0.0d0
5210           enddo
5211         endif
5212         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5213 #ifdef OSF
5214           phii1=phi(i+1)
5215           if (phii1.ne.phii1) phii1=150.0
5216           phii1=pinorm(phii1)
5217 #else
5218           phii1=phi(i+1)
5219 #endif
5220           ityp3=ithetyp((itype(i)))
5221           do k=1,nsingle
5222             cosph2(k)=dcos(k*phii1)
5223             sinph2(k)=dsin(k*phii1)
5224           enddo
5225         else
5226           phii1=0.0d0
5227           ityp3=nthetyp+1
5228           do k=1,nsingle
5229             cosph2(k)=0.0d0
5230             sinph2(k)=0.0d0
5231           enddo
5232         endif
5233         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5234         do k=1,ndouble
5235           do l=1,k-1
5236             ccl=cosph1(l)*cosph2(k-l)
5237             ssl=sinph1(l)*sinph2(k-l)
5238             scl=sinph1(l)*cosph2(k-l)
5239             csl=cosph1(l)*sinph2(k-l)
5240             cosph1ph2(l,k)=ccl-ssl
5241             cosph1ph2(k,l)=ccl+ssl
5242             sinph1ph2(l,k)=scl+csl
5243             sinph1ph2(k,l)=scl-csl
5244           enddo
5245         enddo
5246         if (lprn) then
5247         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
5248      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5249         write (iout,*) "coskt and sinkt"
5250         do k=1,nntheterm
5251           write (iout,*) k,coskt(k),sinkt(k)
5252         enddo
5253         endif
5254         do k=1,ntheterm
5255           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5256           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
5257      &      *coskt(k)
5258           if (lprn)
5259      &    write (iout,*) "k",k,"
5260      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
5261      &     " ethetai",ethetai
5262         enddo
5263         if (lprn) then
5264         write (iout,*) "cosph and sinph"
5265         do k=1,nsingle
5266           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5267         enddo
5268         write (iout,*) "cosph1ph2 and sinph2ph2"
5269         do k=2,ndouble
5270           do l=1,k-1
5271             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
5272      &         sinph1ph2(l,k),sinph1ph2(k,l)
5273           enddo
5274         enddo
5275         write(iout,*) "ethetai",ethetai
5276         endif
5277         do m=1,ntheterm2
5278           do k=1,nsingle
5279             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
5280      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
5281      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
5282      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5283             ethetai=ethetai+sinkt(m)*aux
5284             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5285             dephii=dephii+k*sinkt(m)*(
5286      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
5287      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5288             dephii1=dephii1+k*sinkt(m)*(
5289      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
5290      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5291             if (lprn)
5292      &      write (iout,*) "m",m," k",k," bbthet",
5293      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
5294      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
5295      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
5296      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5297           enddo
5298         enddo
5299         if (lprn)
5300      &  write(iout,*) "ethetai",ethetai
5301         do m=1,ntheterm3
5302           do k=2,ndouble
5303             do l=1,k-1
5304               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5305      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
5306      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5307      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5308               ethetai=ethetai+sinkt(m)*aux
5309               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5310               dephii=dephii+l*sinkt(m)*(
5311      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
5312      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5313      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5314      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5315               dephii1=dephii1+(k-l)*sinkt(m)*(
5316      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5317      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5318      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
5319      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5320               if (lprn) then
5321               write (iout,*) "m",m," k",k," l",l," ffthet",
5322      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5323      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
5324      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5325      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
5326      &            " ethetai",ethetai
5327               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5328      &            cosph1ph2(k,l)*sinkt(m),
5329      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5330               endif
5331             enddo
5332           enddo
5333         enddo
5334 10      continue
5335 c        lprn1=.true.
5336         if (lprn1)
5337      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
5338      &   i,theta(i)*rad2deg,phii*rad2deg,
5339      &   phii1*rad2deg,ethetai
5340 c        lprn1=.false.
5341         etheta=etheta+ethetai
5342         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5343         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5344         gloc(nphi+i-2,icg)=wang*dethetai+ gloc(nphi+i-2,icg)
5345       enddo
5346       return
5347       end
5348 #endif
5349 #ifdef CRYST_SC
5350 c-----------------------------------------------------------------------------
5351       subroutine esc(escloc)
5352 C Calculate the local energy of a side chain and its derivatives in the
5353 C corresponding virtual-bond valence angles THETA and the spherical angles
5354 C ALPHA and OMEGA.
5355       implicit real*8 (a-h,o-z)
5356       include 'DIMENSIONS'
5357       include 'COMMON.GEO'
5358       include 'COMMON.LOCAL'
5359       include 'COMMON.VAR'
5360       include 'COMMON.INTERACT'
5361       include 'COMMON.DERIV'
5362       include 'COMMON.CHAIN'
5363       include 'COMMON.IOUNITS'
5364       include 'COMMON.NAMES'
5365       include 'COMMON.FFIELD'
5366       include 'COMMON.CONTROL'
5367       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5368      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5369       common /sccalc/ time11,time12,time112,theti,it,nlobit
5370       delta=0.02d0*pi
5371       escloc=0.0D0
5372 c     write (iout,'(a)') 'ESC'
5373       do i=loc_start,loc_end
5374         it=itype(i)
5375         if (it.eq.ntyp1) cycle
5376         if (it.eq.10) goto 1
5377         nlobit=nlob(iabs(it))
5378 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5379 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5380         theti=theta(i+1)-pipol
5381         x(1)=dtan(theti)
5382         x(2)=alph(i)
5383         x(3)=omeg(i)
5384
5385         if (x(2).gt.pi-delta) then
5386           xtemp(1)=x(1)
5387           xtemp(2)=pi-delta
5388           xtemp(3)=x(3)
5389           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5390           xtemp(2)=pi
5391           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5392           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5393      &        escloci,dersc(2))
5394           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5395      &        ddersc0(1),dersc(1))
5396           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5397      &        ddersc0(3),dersc(3))
5398           xtemp(2)=pi-delta
5399           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5400           xtemp(2)=pi
5401           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5402           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5403      &            dersc0(2),esclocbi,dersc02)
5404           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5405      &            dersc12,dersc01)
5406           call splinthet(x(2),0.5d0*delta,ss,ssd)
5407           dersc0(1)=dersc01
5408           dersc0(2)=dersc02
5409           dersc0(3)=0.0d0
5410           do k=1,3
5411             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5412           enddo
5413           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5414 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5415 c    &             esclocbi,ss,ssd
5416           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5417 c         escloci=esclocbi
5418 c         write (iout,*) escloci
5419         else if (x(2).lt.delta) then
5420           xtemp(1)=x(1)
5421           xtemp(2)=delta
5422           xtemp(3)=x(3)
5423           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5424           xtemp(2)=0.0d0
5425           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5426           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5427      &        escloci,dersc(2))
5428           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5429      &        ddersc0(1),dersc(1))
5430           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5431      &        ddersc0(3),dersc(3))
5432           xtemp(2)=delta
5433           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5434           xtemp(2)=0.0d0
5435           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5436           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5437      &            dersc0(2),esclocbi,dersc02)
5438           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5439      &            dersc12,dersc01)
5440           dersc0(1)=dersc01
5441           dersc0(2)=dersc02
5442           dersc0(3)=0.0d0
5443           call splinthet(x(2),0.5d0*delta,ss,ssd)
5444           do k=1,3
5445             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5446           enddo
5447           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5448 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5449 c    &             esclocbi,ss,ssd
5450           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5451 c         write (iout,*) escloci
5452         else
5453           call enesc(x,escloci,dersc,ddummy,.false.)
5454         endif
5455
5456         escloc=escloc+escloci
5457         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5458      &     'escloc',i,escloci
5459 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5460
5461         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5462      &   wscloc*dersc(1)
5463         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5464         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5465     1   continue
5466       enddo
5467       return
5468       end
5469 C---------------------------------------------------------------------------
5470       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5471       implicit real*8 (a-h,o-z)
5472       include 'DIMENSIONS'
5473       include 'COMMON.GEO'
5474       include 'COMMON.LOCAL'
5475       include 'COMMON.IOUNITS'
5476       common /sccalc/ time11,time12,time112,theti,it,nlobit
5477       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5478       double precision contr(maxlob,-1:1)
5479       logical mixed
5480 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5481         escloc_i=0.0D0
5482         do j=1,3
5483           dersc(j)=0.0D0
5484           if (mixed) ddersc(j)=0.0d0
5485         enddo
5486         x3=x(3)
5487
5488 C Because of periodicity of the dependence of the SC energy in omega we have
5489 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5490 C To avoid underflows, first compute & store the exponents.
5491
5492         do iii=-1,1
5493
5494           x(3)=x3+iii*dwapi
5495
5496           do j=1,nlobit
5497             do k=1,3
5498               z(k)=x(k)-censc(k,j,it)
5499             enddo
5500             do k=1,3
5501               Axk=0.0D0
5502               do l=1,3
5503                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5504               enddo
5505               Ax(k,j,iii)=Axk
5506             enddo
5507             expfac=0.0D0
5508             do k=1,3
5509               expfac=expfac+Ax(k,j,iii)*z(k)
5510             enddo
5511             contr(j,iii)=expfac
5512           enddo ! j
5513
5514         enddo ! iii
5515
5516         x(3)=x3
5517 C As in the case of ebend, we want to avoid underflows in exponentiation and
5518 C subsequent NaNs and INFs in energy calculation.
5519 C Find the largest exponent
5520         emin=contr(1,-1)
5521         do iii=-1,1
5522           do j=1,nlobit
5523             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5524           enddo
5525         enddo
5526         emin=0.5D0*emin
5527 cd      print *,'it=',it,' emin=',emin
5528
5529 C Compute the contribution to SC energy and derivatives
5530         do iii=-1,1
5531
5532           do j=1,nlobit
5533 #ifdef OSF
5534             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
5535             if(adexp.ne.adexp) adexp=1.0
5536             expfac=dexp(adexp)
5537 #else
5538             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5539 #endif
5540 cd          print *,'j=',j,' expfac=',expfac
5541             escloc_i=escloc_i+expfac
5542             do k=1,3
5543               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5544             enddo
5545             if (mixed) then
5546               do k=1,3,2
5547                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5548      &            +gaussc(k,2,j,it))*expfac
5549               enddo
5550             endif
5551           enddo
5552
5553         enddo ! iii
5554
5555         dersc(1)=dersc(1)/cos(theti)**2
5556         ddersc(1)=ddersc(1)/cos(theti)**2
5557         ddersc(3)=ddersc(3)
5558
5559         escloci=-(dlog(escloc_i)-emin)
5560         do j=1,3
5561           dersc(j)=dersc(j)/escloc_i
5562         enddo
5563         if (mixed) then
5564           do j=1,3,2
5565             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5566           enddo
5567         endif
5568       return
5569       end
5570 C------------------------------------------------------------------------------
5571       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5572       implicit real*8 (a-h,o-z)
5573       include 'DIMENSIONS'
5574       include 'COMMON.GEO'
5575       include 'COMMON.LOCAL'
5576       include 'COMMON.IOUNITS'
5577       common /sccalc/ time11,time12,time112,theti,it,nlobit
5578       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5579       double precision contr(maxlob)
5580       logical mixed
5581
5582       escloc_i=0.0D0
5583
5584       do j=1,3
5585         dersc(j)=0.0D0
5586       enddo
5587
5588       do j=1,nlobit
5589         do k=1,2
5590           z(k)=x(k)-censc(k,j,it)
5591         enddo
5592         z(3)=dwapi
5593         do k=1,3
5594           Axk=0.0D0
5595           do l=1,3
5596             Axk=Axk+gaussc(l,k,j,it)*z(l)
5597           enddo
5598           Ax(k,j)=Axk
5599         enddo
5600         expfac=0.0D0
5601         do k=1,3
5602           expfac=expfac+Ax(k,j)*z(k)
5603         enddo
5604         contr(j)=expfac
5605       enddo ! j
5606
5607 C As in the case of ebend, we want to avoid underflows in exponentiation and
5608 C subsequent NaNs and INFs in energy calculation.
5609 C Find the largest exponent
5610       emin=contr(1)
5611       do j=1,nlobit
5612         if (emin.gt.contr(j)) emin=contr(j)
5613       enddo
5614       emin=0.5D0*emin
5615
5616 C Compute the contribution to SC energy and derivatives
5617
5618       dersc12=0.0d0
5619       do j=1,nlobit
5620         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5621         escloc_i=escloc_i+expfac
5622         do k=1,2
5623           dersc(k)=dersc(k)+Ax(k,j)*expfac
5624         enddo
5625         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5626      &            +gaussc(1,2,j,it))*expfac
5627         dersc(3)=0.0d0
5628       enddo
5629
5630       dersc(1)=dersc(1)/cos(theti)**2
5631       dersc12=dersc12/cos(theti)**2
5632       escloci=-(dlog(escloc_i)-emin)
5633       do j=1,2
5634         dersc(j)=dersc(j)/escloc_i
5635       enddo
5636       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5637       return
5638       end
5639 #else
5640 c----------------------------------------------------------------------------------
5641       subroutine esc(escloc)
5642 C Calculate the local energy of a side chain and its derivatives in the
5643 C corresponding virtual-bond valence angles THETA and the spherical angles
5644 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5645 C added by Urszula Kozlowska. 07/11/2007
5646 C
5647       implicit real*8 (a-h,o-z)
5648       include 'DIMENSIONS'
5649       include 'COMMON.GEO'
5650       include 'COMMON.LOCAL'
5651       include 'COMMON.VAR'
5652       include 'COMMON.SCROT'
5653       include 'COMMON.INTERACT'
5654       include 'COMMON.DERIV'
5655       include 'COMMON.CHAIN'
5656       include 'COMMON.IOUNITS'
5657       include 'COMMON.NAMES'
5658       include 'COMMON.FFIELD'
5659       include 'COMMON.CONTROL'
5660       include 'COMMON.VECTORS'
5661       double precision x_prime(3),y_prime(3),z_prime(3)
5662      &    , sumene,dsc_i,dp2_i,x(65),
5663      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5664      &    de_dxx,de_dyy,de_dzz,de_dt
5665       double precision s1_t,s1_6_t,s2_t,s2_6_t
5666       double precision
5667      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5668      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5669      & dt_dCi(3),dt_dCi1(3)
5670       common /sccalc/ time11,time12,time112,theti,it,nlobit
5671       delta=0.02d0*pi
5672       escloc=0.0D0
5673       do i=loc_start,loc_end
5674         if (itype(i).eq.ntyp1) cycle
5675         costtab(i+1) =dcos(theta(i+1))
5676         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5677         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5678         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5679         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5680         cosfac=dsqrt(cosfac2)
5681         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5682         sinfac=dsqrt(sinfac2)
5683         it=iabs(itype(i))
5684         if (it.eq.10) goto 1
5685 c
5686 C  Compute the axes of tghe local cartesian coordinates system; store in
5687 c   x_prime, y_prime and z_prime
5688 c
5689         do j=1,3
5690           x_prime(j) = 0.00
5691           y_prime(j) = 0.00
5692           z_prime(j) = 0.00
5693         enddo
5694 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5695 C     &   dc_norm(3,i+nres)
5696         do j = 1,3
5697           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5698           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5699         enddo
5700         do j = 1,3
5701           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5702         enddo
5703 c       write (2,*) "i",i
5704 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5705 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5706 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5707 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5708 c      & " xy",scalar(x_prime(1),y_prime(1)),
5709 c      & " xz",scalar(x_prime(1),z_prime(1)),
5710 c      & " yy",scalar(y_prime(1),y_prime(1)),
5711 c      & " yz",scalar(y_prime(1),z_prime(1)),
5712 c      & " zz",scalar(z_prime(1),z_prime(1))
5713 c
5714 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5715 C to local coordinate system. Store in xx, yy, zz.
5716 c
5717         xx=0.0d0
5718         yy=0.0d0
5719         zz=0.0d0
5720         do j = 1,3
5721           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5722           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5723           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5724         enddo
5725
5726         xxtab(i)=xx
5727         yytab(i)=yy
5728         zztab(i)=zz
5729 C
5730 C Compute the energy of the ith side cbain
5731 C
5732 c        write (2,*) "xx",xx," yy",yy," zz",zz
5733         it=iabs(itype(i))
5734         do j = 1,65
5735           x(j) = sc_parmin(j,it)
5736         enddo
5737 #ifdef CHECK_COORD
5738 Cc diagnostics - remove later
5739         xx1 = dcos(alph(2))
5740         yy1 = dsin(alph(2))*dcos(omeg(2))
5741         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
5742         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5743      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5744      &    xx1,yy1,zz1
5745 C,"  --- ", xx_w,yy_w,zz_w
5746 c end diagnostics
5747 #endif
5748         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5749      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5750      &   + x(10)*yy*zz
5751         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5752      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5753      & + x(20)*yy*zz
5754         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5755      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5756      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5757      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5758      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5759      &  +x(40)*xx*yy*zz
5760         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5761      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5762      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5763      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5764      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5765      &  +x(60)*xx*yy*zz
5766         dsc_i   = 0.743d0+x(61)
5767         dp2_i   = 1.9d0+x(62)
5768         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5769      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5770         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5771      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5772         s1=(1+x(63))/(0.1d0 + dscp1)
5773         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5774         s2=(1+x(65))/(0.1d0 + dscp2)
5775         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5776         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5777      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5778 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5779 c     &   sumene4,
5780 c     &   dscp1,dscp2,sumene
5781 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5782         escloc = escloc + sumene
5783 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
5784 c     & ,zz,xx,yy
5785 c#define DEBUG
5786 #ifdef DEBUG
5787 C
5788 C This section to check the numerical derivatives of the energy of ith side
5789 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5790 C #define DEBUG in the code to turn it on.
5791 C
5792         write (2,*) "sumene               =",sumene
5793         aincr=1.0d-7
5794         xxsave=xx
5795         xx=xx+aincr
5796         write (2,*) xx,yy,zz
5797         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5798         de_dxx_num=(sumenep-sumene)/aincr
5799         xx=xxsave
5800         write (2,*) "xx+ sumene from enesc=",sumenep
5801         yysave=yy
5802         yy=yy+aincr
5803         write (2,*) xx,yy,zz
5804         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5805         de_dyy_num=(sumenep-sumene)/aincr
5806         yy=yysave
5807         write (2,*) "yy+ sumene from enesc=",sumenep
5808         zzsave=zz
5809         zz=zz+aincr
5810         write (2,*) xx,yy,zz
5811         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5812         de_dzz_num=(sumenep-sumene)/aincr
5813         zz=zzsave
5814         write (2,*) "zz+ sumene from enesc=",sumenep
5815         costsave=cost2tab(i+1)
5816         sintsave=sint2tab(i+1)
5817         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5818         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5819         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5820         de_dt_num=(sumenep-sumene)/aincr
5821         write (2,*) " t+ sumene from enesc=",sumenep
5822         cost2tab(i+1)=costsave
5823         sint2tab(i+1)=sintsave
5824 C End of diagnostics section.
5825 #endif
5826 C
5827 C Compute the gradient of esc
5828 C
5829 c        zz=zz*dsign(1.0,dfloat(itype(i)))
5830         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5831         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5832         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5833         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5834         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5835         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5836         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5837         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5838         pom1=(sumene3*sint2tab(i+1)+sumene1)
5839      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5840         pom2=(sumene4*cost2tab(i+1)+sumene2)
5841      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5842         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5843         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5844      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5845      &  +x(40)*yy*zz
5846         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5847         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5848      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5849      &  +x(60)*yy*zz
5850         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5851      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5852      &        +(pom1+pom2)*pom_dx
5853 #ifdef DEBUG
5854         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
5855 #endif
5856 C
5857         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5858         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5859      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5860      &  +x(40)*xx*zz
5861         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5862         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5863      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5864      &  +x(59)*zz**2 +x(60)*xx*zz
5865         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5866      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5867      &        +(pom1-pom2)*pom_dy
5868 #ifdef DEBUG
5869         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
5870 #endif
5871 C
5872         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5873      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5874      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5875      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5876      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5877      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5878      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5879      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5880 #ifdef DEBUG
5881         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
5882 #endif
5883 C
5884         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5885      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5886      &  +pom1*pom_dt1+pom2*pom_dt2
5887 #ifdef DEBUG
5888         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
5889 #endif
5890 c#undef DEBUG
5891 c
5892 C
5893        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5894        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5895        cosfac2xx=cosfac2*xx
5896        sinfac2yy=sinfac2*yy
5897        do k = 1,3
5898          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5899      &      vbld_inv(i+1)
5900          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5901      &      vbld_inv(i)
5902          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5903          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5904 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5905 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5906 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5907 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5908          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5909          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5910          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5911          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5912          dZZ_Ci1(k)=0.0d0
5913          dZZ_Ci(k)=0.0d0
5914          do j=1,3
5915            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5916      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5917            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5918      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5919          enddo
5920
5921          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5922          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5923          dZZ_XYZ(k)=vbld_inv(i+nres)*
5924      &   (z_prime(k)-zz*dC_norm(k,i+nres))
5925 c
5926          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5927          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5928        enddo
5929
5930        do k=1,3
5931          dXX_Ctab(k,i)=dXX_Ci(k)
5932          dXX_C1tab(k,i)=dXX_Ci1(k)
5933          dYY_Ctab(k,i)=dYY_Ci(k)
5934          dYY_C1tab(k,i)=dYY_Ci1(k)
5935          dZZ_Ctab(k,i)=dZZ_Ci(k)
5936          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5937          dXX_XYZtab(k,i)=dXX_XYZ(k)
5938          dYY_XYZtab(k,i)=dYY_XYZ(k)
5939          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5940        enddo
5941
5942        do k = 1,3
5943 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5944 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5945 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5946 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5947 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5948 c     &    dt_dci(k)
5949 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5950 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5951          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5952      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5953          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5954      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5955          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5956      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5957        enddo
5958 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5959 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5960
5961 C to check gradient call subroutine check_grad
5962
5963     1 continue
5964       enddo
5965       return
5966       end
5967 c------------------------------------------------------------------------------
5968       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5969       implicit none
5970       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5971      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5972       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5973      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5974      &   + x(10)*yy*zz
5975       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5976      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5977      & + x(20)*yy*zz
5978       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5979      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5980      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5981      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5982      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5983      &  +x(40)*xx*yy*zz
5984       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5985      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5986      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5987      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5988      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5989      &  +x(60)*xx*yy*zz
5990       dsc_i   = 0.743d0+x(61)
5991       dp2_i   = 1.9d0+x(62)
5992       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5993      &          *(xx*cost2+yy*sint2))
5994       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5995      &          *(xx*cost2-yy*sint2))
5996       s1=(1+x(63))/(0.1d0 + dscp1)
5997       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5998       s2=(1+x(65))/(0.1d0 + dscp2)
5999       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6000       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
6001      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
6002       enesc=sumene
6003       return
6004       end
6005 #endif
6006 c------------------------------------------------------------------------------
6007       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6008 C
6009 C This procedure calculates two-body contact function g(rij) and its derivative:
6010 C
6011 C           eps0ij                                     !       x < -1
6012 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6013 C            0                                         !       x > 1
6014 C
6015 C where x=(rij-r0ij)/delta
6016 C
6017 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6018 C
6019       implicit none
6020       double precision rij,r0ij,eps0ij,fcont,fprimcont
6021       double precision x,x2,x4,delta
6022 c     delta=0.02D0*r0ij
6023 c      delta=0.2D0*r0ij
6024       x=(rij-r0ij)/delta
6025       if (x.lt.-1.0D0) then
6026         fcont=eps0ij
6027         fprimcont=0.0D0
6028       else if (x.le.1.0D0) then
6029         x2=x*x
6030         x4=x2*x2
6031         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6032         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6033       else
6034         fcont=0.0D0
6035         fprimcont=0.0D0
6036       endif
6037       return
6038       end
6039 c------------------------------------------------------------------------------
6040       subroutine splinthet(theti,delta,ss,ssder)
6041       implicit real*8 (a-h,o-z)
6042       include 'DIMENSIONS'
6043       include 'COMMON.VAR'
6044       include 'COMMON.GEO'
6045       thetup=pi-delta
6046       thetlow=delta
6047       if (theti.gt.pipol) then
6048         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6049       else
6050         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6051         ssder=-ssder
6052       endif
6053       return
6054       end
6055 c------------------------------------------------------------------------------
6056       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6057       implicit none
6058       double precision x,x0,delta,f0,f1,fprim0,f,fprim
6059       double precision ksi,ksi2,ksi3,a1,a2,a3
6060       a1=fprim0*delta/(f1-f0)
6061       a2=3.0d0-2.0d0*a1
6062       a3=a1-2.0d0
6063       ksi=(x-x0)/delta
6064       ksi2=ksi*ksi
6065       ksi3=ksi2*ksi
6066       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6067       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6068       return
6069       end
6070 c------------------------------------------------------------------------------
6071       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6072       implicit none
6073       double precision x,x0,delta,f0x,f1x,fprim0x,fx
6074       double precision ksi,ksi2,ksi3,a1,a2,a3
6075       ksi=(x-x0)/delta
6076       ksi2=ksi*ksi
6077       ksi3=ksi2*ksi
6078       a1=fprim0x*delta
6079       a2=3*(f1x-f0x)-2*fprim0x*delta
6080       a3=fprim0x*delta-2*(f1x-f0x)
6081       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6082       return
6083       end
6084 C-----------------------------------------------------------------------------
6085 #ifdef CRYST_TOR
6086 C-----------------------------------------------------------------------------
6087       subroutine etor(etors,edihcnstr)
6088       implicit real*8 (a-h,o-z)
6089       include 'DIMENSIONS'
6090       include 'COMMON.VAR'
6091       include 'COMMON.GEO'
6092       include 'COMMON.LOCAL'
6093       include 'COMMON.TORSION'
6094       include 'COMMON.INTERACT'
6095       include 'COMMON.DERIV'
6096       include 'COMMON.CHAIN'
6097       include 'COMMON.NAMES'
6098       include 'COMMON.IOUNITS'
6099       include 'COMMON.FFIELD'
6100       include 'COMMON.TORCNSTR'
6101       include 'COMMON.CONTROL'
6102       logical lprn
6103 C Set lprn=.true. for debugging
6104       lprn=.false.
6105 c      lprn=.true.
6106       etors=0.0D0
6107       do i=iphi_start,iphi_end
6108       etors_ii=0.0D0
6109         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6110      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6111         itori=itortyp(itype(i-2))
6112         itori1=itortyp(itype(i-1))
6113         phii=phi(i)
6114         gloci=0.0D0
6115 C Proline-Proline pair is a special case...
6116         if (itori.eq.3 .and. itori1.eq.3) then
6117           if (phii.gt.-dwapi3) then
6118             cosphi=dcos(3*phii)
6119             fac=1.0D0/(1.0D0-cosphi)
6120             etorsi=v1(1,3,3)*fac
6121             etorsi=etorsi+etorsi
6122             etors=etors+etorsi-v1(1,3,3)
6123             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
6124             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6125           endif
6126           do j=1,3
6127             v1ij=v1(j+1,itori,itori1)
6128             v2ij=v2(j+1,itori,itori1)
6129             cosphi=dcos(j*phii)
6130             sinphi=dsin(j*phii)
6131             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6132             if (energy_dec) etors_ii=etors_ii+
6133      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6134             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6135           enddo
6136         else
6137           do j=1,nterm_old
6138             v1ij=v1(j,itori,itori1)
6139             v2ij=v2(j,itori,itori1)
6140             cosphi=dcos(j*phii)
6141             sinphi=dsin(j*phii)
6142             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6143             if (energy_dec) etors_ii=etors_ii+
6144      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6145             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6146           enddo
6147         endif
6148         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6149              'etor',i,etors_ii
6150         if (lprn)
6151      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6152      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6153      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6154         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6155 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6156       enddo
6157 ! 6/20/98 - dihedral angle constraints
6158       edihcnstr=0.0d0
6159       do i=1,ndih_constr
6160         itori=idih_constr(i)
6161         phii=phi(itori)
6162         difi=phii-phi0(i)
6163         if (difi.gt.drange(i)) then
6164           difi=difi-drange(i)
6165           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6166           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6167         else if (difi.lt.-drange(i)) then
6168           difi=difi+drange(i)
6169           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6170           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6171         endif
6172 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6173 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6174       enddo
6175 !      write (iout,*) 'edihcnstr',edihcnstr
6176       return
6177       end
6178 c------------------------------------------------------------------------------
6179       subroutine etor_d(etors_d)
6180       etors_d=0.0d0
6181       return
6182       end
6183 c----------------------------------------------------------------------------
6184 #else
6185       subroutine etor(etors,edihcnstr)
6186       implicit real*8 (a-h,o-z)
6187       include 'DIMENSIONS'
6188       include 'COMMON.VAR'
6189       include 'COMMON.GEO'
6190       include 'COMMON.LOCAL'
6191       include 'COMMON.TORSION'
6192       include 'COMMON.INTERACT'
6193       include 'COMMON.DERIV'
6194       include 'COMMON.CHAIN'
6195       include 'COMMON.NAMES'
6196       include 'COMMON.IOUNITS'
6197       include 'COMMON.FFIELD'
6198       include 'COMMON.TORCNSTR'
6199       include 'COMMON.CONTROL'
6200       logical lprn
6201 C Set lprn=.true. for debugging
6202       lprn=.false.
6203 c     lprn=.true.
6204       etors=0.0D0
6205       do i=iphi_start,iphi_end
6206 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6207 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6208 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
6209 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
6210         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6211      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6212 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
6213 C For introducing the NH3+ and COO- group please check the etor_d for reference
6214 C and guidance
6215         etors_ii=0.0D0
6216          if (iabs(itype(i)).eq.20) then
6217          iblock=2
6218          else
6219          iblock=1
6220          endif
6221         itori=itortyp(itype(i-2))
6222         itori1=itortyp(itype(i-1))
6223         phii=phi(i)
6224         gloci=0.0D0
6225 C Regular cosine and sine terms
6226         do j=1,nterm(itori,itori1,iblock)
6227           v1ij=v1(j,itori,itori1,iblock)
6228           v2ij=v2(j,itori,itori1,iblock)
6229           cosphi=dcos(j*phii)
6230           sinphi=dsin(j*phii)
6231           etors=etors+v1ij*cosphi+v2ij*sinphi
6232           if (energy_dec) etors_ii=etors_ii+
6233      &                v1ij*cosphi+v2ij*sinphi
6234           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6235         enddo
6236 C Lorentz terms
6237 C                         v1
6238 C  E = SUM ----------------------------------- - v1
6239 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6240 C
6241         cosphi=dcos(0.5d0*phii)
6242         sinphi=dsin(0.5d0*phii)
6243         do j=1,nlor(itori,itori1,iblock)
6244           vl1ij=vlor1(j,itori,itori1)
6245           vl2ij=vlor2(j,itori,itori1)
6246           vl3ij=vlor3(j,itori,itori1)
6247           pom=vl2ij*cosphi+vl3ij*sinphi
6248           pom1=1.0d0/(pom*pom+1.0d0)
6249           etors=etors+vl1ij*pom1
6250           if (energy_dec) etors_ii=etors_ii+
6251      &                vl1ij*pom1
6252           pom=-pom*pom1*pom1
6253           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6254         enddo
6255 C Subtract the constant term
6256         etors=etors-v0(itori,itori1,iblock)
6257           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6258      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
6259         if (lprn)
6260      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6261      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6262      &  (v1(j,itori,itori1,iblock),j=1,6),
6263      &  (v2(j,itori,itori1,iblock),j=1,6)
6264         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6265 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6266       enddo
6267 ! 6/20/98 - dihedral angle constraints
6268       edihcnstr=0.0d0
6269 c      do i=1,ndih_constr
6270       do i=idihconstr_start,idihconstr_end
6271         itori=idih_constr(i)
6272         phii=phi(itori)
6273         difi=pinorm(phii-phi0(i))
6274         if (difi.gt.drange(i)) then
6275           difi=difi-drange(i)
6276           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6277           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6278         else if (difi.lt.-drange(i)) then
6279           difi=difi+drange(i)
6280           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6281           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6282         else
6283           difi=0.0
6284         endif
6285 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
6286 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
6287 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6288       enddo
6289 cd       write (iout,*) 'edihcnstr',edihcnstr
6290       return
6291       end
6292 c----------------------------------------------------------------------------
6293       subroutine etor_d(etors_d)
6294 C 6/23/01 Compute double torsional energy
6295       implicit real*8 (a-h,o-z)
6296       include 'DIMENSIONS'
6297       include 'COMMON.VAR'
6298       include 'COMMON.GEO'
6299       include 'COMMON.LOCAL'
6300       include 'COMMON.TORSION'
6301       include 'COMMON.INTERACT'
6302       include 'COMMON.DERIV'
6303       include 'COMMON.CHAIN'
6304       include 'COMMON.NAMES'
6305       include 'COMMON.IOUNITS'
6306       include 'COMMON.FFIELD'
6307       include 'COMMON.TORCNSTR'
6308       logical lprn
6309 C Set lprn=.true. for debugging
6310       lprn=.false.
6311 c     lprn=.true.
6312       etors_d=0.0D0
6313 c      write(iout,*) "a tu??"
6314       do i=iphid_start,iphid_end
6315 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6316 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6317 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
6318 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
6319 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
6320          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
6321      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
6322      &  (itype(i+1).eq.ntyp1)) cycle
6323 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
6324         itori=itortyp(itype(i-2))
6325         itori1=itortyp(itype(i-1))
6326         itori2=itortyp(itype(i))
6327         phii=phi(i)
6328         phii1=phi(i+1)
6329         gloci1=0.0D0
6330         gloci2=0.0D0
6331         iblock=1
6332         if (iabs(itype(i+1)).eq.20) iblock=2
6333 C Iblock=2 Proline type
6334 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
6335 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
6336 C        if (itype(i+1).eq.ntyp1) iblock=3
6337 C The problem of NH3+ group can be resolved by adding new parameters please note if there
6338 C IS or IS NOT need for this
6339 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
6340 C        is (itype(i-3).eq.ntyp1) ntblock=2
6341 C        ntblock is N-terminal blocking group
6342
6343 C Regular cosine and sine terms
6344         do j=1,ntermd_1(itori,itori1,itori2,iblock)
6345 C Example of changes for NH3+ blocking group
6346 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
6347 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
6348           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
6349           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
6350           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
6351           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
6352           cosphi1=dcos(j*phii)
6353           sinphi1=dsin(j*phii)
6354           cosphi2=dcos(j*phii1)
6355           sinphi2=dsin(j*phii1)
6356           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
6357      &     v2cij*cosphi2+v2sij*sinphi2
6358           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6359           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6360         enddo
6361         do k=2,ntermd_2(itori,itori1,itori2,iblock)
6362           do l=1,k-1
6363             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
6364             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
6365             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
6366             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
6367             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6368             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6369             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6370             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6371             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6372      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6373             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
6374      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6375             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
6376      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6377           enddo
6378         enddo
6379         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
6380         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
6381       enddo
6382       return
6383       end
6384 #endif
6385 c------------------------------------------------------------------------------
6386       subroutine eback_sc_corr(esccor)
6387 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6388 c        conformational states; temporarily implemented as differences
6389 c        between UNRES torsional potentials (dependent on three types of
6390 c        residues) and the torsional potentials dependent on all 20 types
6391 c        of residues computed from AM1  energy surfaces of terminally-blocked
6392 c        amino-acid residues.
6393       implicit real*8 (a-h,o-z)
6394       include 'DIMENSIONS'
6395       include 'COMMON.VAR'
6396       include 'COMMON.GEO'
6397       include 'COMMON.LOCAL'
6398       include 'COMMON.TORSION'
6399       include 'COMMON.SCCOR'
6400       include 'COMMON.INTERACT'
6401       include 'COMMON.DERIV'
6402       include 'COMMON.CHAIN'
6403       include 'COMMON.NAMES'
6404       include 'COMMON.IOUNITS'
6405       include 'COMMON.FFIELD'
6406       include 'COMMON.CONTROL'
6407       logical lprn
6408 C Set lprn=.true. for debugging
6409       lprn=.false.
6410 c      lprn=.true.
6411 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
6412       esccor=0.0D0
6413       do i=itau_start,itau_end
6414         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6415         esccor_ii=0.0D0
6416         isccori=isccortyp(itype(i-2))
6417         isccori1=isccortyp(itype(i-1))
6418 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
6419         phii=phi(i)
6420         do intertyp=1,3 !intertyp
6421 cc Added 09 May 2012 (Adasko)
6422 cc  Intertyp means interaction type of backbone mainchain correlation:
6423 c   1 = SC...Ca...Ca...Ca
6424 c   2 = Ca...Ca...Ca...SC
6425 c   3 = SC...Ca...Ca...SCi
6426         gloci=0.0D0
6427         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6428      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
6429      &      (itype(i-1).eq.ntyp1)))
6430      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6431      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
6432      &     .or.(itype(i).eq.ntyp1)))
6433      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6434      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
6435      &      (itype(i-3).eq.ntyp1)))) cycle
6436         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
6437         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
6438      & cycle
6439        do j=1,nterm_sccor(isccori,isccori1)
6440           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6441           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6442           cosphi=dcos(j*tauangle(intertyp,i))
6443           sinphi=dsin(j*tauangle(intertyp,i))
6444           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6445           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6446         enddo
6447 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
6448         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6449         if (lprn)
6450      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6451      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
6452      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
6453      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
6454         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6455        enddo !intertyp
6456       enddo
6457
6458       return
6459       end
6460 c----------------------------------------------------------------------------
6461       subroutine multibody(ecorr)
6462 C This subroutine calculates multi-body contributions to energy following
6463 C the idea of Skolnick et al. If side chains I and J make a contact and
6464 C at the same time side chains I+1 and J+1 make a contact, an extra
6465 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6466       implicit real*8 (a-h,o-z)
6467       include 'DIMENSIONS'
6468       include 'COMMON.IOUNITS'
6469       include 'COMMON.DERIV'
6470       include 'COMMON.INTERACT'
6471       include 'COMMON.CONTACTS'
6472       double precision gx(3),gx1(3)
6473       logical lprn
6474
6475 C Set lprn=.true. for debugging
6476       lprn=.false.
6477
6478       if (lprn) then
6479         write (iout,'(a)') 'Contact function values:'
6480         do i=nnt,nct-2
6481           write (iout,'(i2,20(1x,i2,f10.5))')
6482      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6483         enddo
6484       endif
6485       ecorr=0.0D0
6486       do i=nnt,nct
6487         do j=1,3
6488           gradcorr(j,i)=0.0D0
6489           gradxorr(j,i)=0.0D0
6490         enddo
6491       enddo
6492       do i=nnt,nct-2
6493
6494         DO ISHIFT = 3,4
6495
6496         i1=i+ishift
6497         num_conti=num_cont(i)
6498         num_conti1=num_cont(i1)
6499         do jj=1,num_conti
6500           j=jcont(jj,i)
6501           do kk=1,num_conti1
6502             j1=jcont(kk,i1)
6503             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6504 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6505 cd   &                   ' ishift=',ishift
6506 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6507 C The system gains extra energy.
6508               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6509             endif   ! j1==j+-ishift
6510           enddo     ! kk
6511         enddo       ! jj
6512
6513         ENDDO ! ISHIFT
6514
6515       enddo         ! i
6516       return
6517       end
6518 c------------------------------------------------------------------------------
6519       double precision function esccorr(i,j,k,l,jj,kk)
6520       implicit real*8 (a-h,o-z)
6521       include 'DIMENSIONS'
6522       include 'COMMON.IOUNITS'
6523       include 'COMMON.DERIV'
6524       include 'COMMON.INTERACT'
6525       include 'COMMON.CONTACTS'
6526       double precision gx(3),gx1(3)
6527       logical lprn
6528       lprn=.false.
6529       eij=facont(jj,i)
6530       ekl=facont(kk,k)
6531 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6532 C Calculate the multi-body contribution to energy.
6533 C Calculate multi-body contributions to the gradient.
6534 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6535 cd   & k,l,(gacont(m,kk,k),m=1,3)
6536       do m=1,3
6537         gx(m) =ekl*gacont(m,jj,i)
6538         gx1(m)=eij*gacont(m,kk,k)
6539         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6540         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6541         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6542         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6543       enddo
6544       do m=i,j-1
6545         do ll=1,3
6546           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6547         enddo
6548       enddo
6549       do m=k,l-1
6550         do ll=1,3
6551           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6552         enddo
6553       enddo
6554       esccorr=-eij*ekl
6555       return
6556       end
6557 c------------------------------------------------------------------------------
6558       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6559 C This subroutine calculates multi-body contributions to hydrogen-bonding
6560       implicit real*8 (a-h,o-z)
6561       include 'DIMENSIONS'
6562       include 'COMMON.IOUNITS'
6563 #ifdef MPI
6564       include "mpif.h"
6565       parameter (max_cont=maxconts)
6566       parameter (max_dim=26)
6567       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6568       double precision zapas(max_dim,maxconts,max_fg_procs),
6569      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6570       common /przechowalnia/ zapas
6571       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6572      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6573 #endif
6574       include 'COMMON.SETUP'
6575       include 'COMMON.FFIELD'
6576       include 'COMMON.DERIV'
6577       include 'COMMON.INTERACT'
6578       include 'COMMON.CONTACTS'
6579       include 'COMMON.CONTROL'
6580       include 'COMMON.LOCAL'
6581       double precision gx(3),gx1(3),time00
6582       logical lprn,ldone
6583
6584 C Set lprn=.true. for debugging
6585       lprn=.false.
6586 #ifdef MPI
6587       n_corr=0
6588       n_corr1=0
6589       if (nfgtasks.le.1) goto 30
6590       if (lprn) then
6591         write (iout,'(a)') 'Contact function values before RECEIVE:'
6592         do i=nnt,nct-2
6593           write (iout,'(2i3,50(1x,i2,f5.2))')
6594      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6595      &    j=1,num_cont_hb(i))
6596         enddo
6597       endif
6598       call flush(iout)
6599       do i=1,ntask_cont_from
6600         ncont_recv(i)=0
6601       enddo
6602       do i=1,ntask_cont_to
6603         ncont_sent(i)=0
6604       enddo
6605 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6606 c     & ntask_cont_to
6607 C Make the list of contacts to send to send to other procesors
6608 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6609 c      call flush(iout)
6610       do i=iturn3_start,iturn3_end
6611 c        write (iout,*) "make contact list turn3",i," num_cont",
6612 c     &    num_cont_hb(i)
6613         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6614       enddo
6615       do i=iturn4_start,iturn4_end
6616 c        write (iout,*) "make contact list turn4",i," num_cont",
6617 c     &   num_cont_hb(i)
6618         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6619       enddo
6620       do ii=1,nat_sent
6621         i=iat_sent(ii)
6622 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6623 c     &    num_cont_hb(i)
6624         do j=1,num_cont_hb(i)
6625         do k=1,4
6626           jjc=jcont_hb(j,i)
6627           iproc=iint_sent_local(k,jjc,ii)
6628 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6629           if (iproc.gt.0) then
6630             ncont_sent(iproc)=ncont_sent(iproc)+1
6631             nn=ncont_sent(iproc)
6632             zapas(1,nn,iproc)=i
6633             zapas(2,nn,iproc)=jjc
6634             zapas(3,nn,iproc)=facont_hb(j,i)
6635             zapas(4,nn,iproc)=ees0p(j,i)
6636             zapas(5,nn,iproc)=ees0m(j,i)
6637             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6638             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6639             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6640             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6641             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6642             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6643             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6644             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6645             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6646             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6647             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6648             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6649             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6650             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6651             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6652             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6653             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6654             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6655             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6656             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6657             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6658           endif
6659         enddo
6660         enddo
6661       enddo
6662       if (lprn) then
6663       write (iout,*)
6664      &  "Numbers of contacts to be sent to other processors",
6665      &  (ncont_sent(i),i=1,ntask_cont_to)
6666       write (iout,*) "Contacts sent"
6667       do ii=1,ntask_cont_to
6668         nn=ncont_sent(ii)
6669         iproc=itask_cont_to(ii)
6670         write (iout,*) nn," contacts to processor",iproc,
6671      &   " of CONT_TO_COMM group"
6672         do i=1,nn
6673           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6674         enddo
6675       enddo
6676       call flush(iout)
6677       endif
6678       CorrelType=477
6679       CorrelID=fg_rank+1
6680       CorrelType1=478
6681       CorrelID1=nfgtasks+fg_rank+1
6682       ireq=0
6683 C Receive the numbers of needed contacts from other processors
6684       do ii=1,ntask_cont_from
6685         iproc=itask_cont_from(ii)
6686         ireq=ireq+1
6687         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6688      &    FG_COMM,req(ireq),IERR)
6689       enddo
6690 c      write (iout,*) "IRECV ended"
6691 c      call flush(iout)
6692 C Send the number of contacts needed by other processors
6693       do ii=1,ntask_cont_to
6694         iproc=itask_cont_to(ii)
6695         ireq=ireq+1
6696         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6697      &    FG_COMM,req(ireq),IERR)
6698       enddo
6699 c      write (iout,*) "ISEND ended"
6700 c      write (iout,*) "number of requests (nn)",ireq
6701       call flush(iout)
6702       if (ireq.gt.0)
6703      &  call MPI_Waitall(ireq,req,status_array,ierr)
6704 c      write (iout,*)
6705 c     &  "Numbers of contacts to be received from other processors",
6706 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6707 c      call flush(iout)
6708 C Receive contacts
6709       ireq=0
6710       do ii=1,ntask_cont_from
6711         iproc=itask_cont_from(ii)
6712         nn=ncont_recv(ii)
6713 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6714 c     &   " of CONT_TO_COMM group"
6715         call flush(iout)
6716         if (nn.gt.0) then
6717           ireq=ireq+1
6718           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6719      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6720 c          write (iout,*) "ireq,req",ireq,req(ireq)
6721         endif
6722       enddo
6723 C Send the contacts to processors that need them
6724       do ii=1,ntask_cont_to
6725         iproc=itask_cont_to(ii)
6726         nn=ncont_sent(ii)
6727 c        write (iout,*) nn," contacts to processor",iproc,
6728 c     &   " of CONT_TO_COMM group"
6729         if (nn.gt.0) then
6730           ireq=ireq+1
6731           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6732      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6733 c          write (iout,*) "ireq,req",ireq,req(ireq)
6734 c          do i=1,nn
6735 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6736 c          enddo
6737         endif
6738       enddo
6739 c      write (iout,*) "number of requests (contacts)",ireq
6740 c      write (iout,*) "req",(req(i),i=1,4)
6741 c      call flush(iout)
6742       if (ireq.gt.0)
6743      & call MPI_Waitall(ireq,req,status_array,ierr)
6744       do iii=1,ntask_cont_from
6745         iproc=itask_cont_from(iii)
6746         nn=ncont_recv(iii)
6747         if (lprn) then
6748         write (iout,*) "Received",nn," contacts from processor",iproc,
6749      &   " of CONT_FROM_COMM group"
6750         call flush(iout)
6751         do i=1,nn
6752           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6753         enddo
6754         call flush(iout)
6755         endif
6756         do i=1,nn
6757           ii=zapas_recv(1,i,iii)
6758 c Flag the received contacts to prevent double-counting
6759           jj=-zapas_recv(2,i,iii)
6760 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6761 c          call flush(iout)
6762           nnn=num_cont_hb(ii)+1
6763           num_cont_hb(ii)=nnn
6764           jcont_hb(nnn,ii)=jj
6765           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6766           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6767           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6768           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6769           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6770           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6771           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6772           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6773           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6774           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6775           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6776           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6777           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6778           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6779           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6780           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6781           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6782           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6783           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6784           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6785           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6786           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6787           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6788           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6789         enddo
6790       enddo
6791       call flush(iout)
6792       if (lprn) then
6793         write (iout,'(a)') 'Contact function values after receive:'
6794         do i=nnt,nct-2
6795           write (iout,'(2i3,50(1x,i3,f5.2))')
6796      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6797      &    j=1,num_cont_hb(i))
6798         enddo
6799         call flush(iout)
6800       endif
6801    30 continue
6802 #endif
6803       if (lprn) then
6804         write (iout,'(a)') 'Contact function values:'
6805         do i=nnt,nct-2
6806           write (iout,'(2i3,50(1x,i3,f5.2))')
6807      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6808      &    j=1,num_cont_hb(i))
6809         enddo
6810       endif
6811       ecorr=0.0D0
6812 C Remove the loop below after debugging !!!
6813       do i=nnt,nct
6814         do j=1,3
6815           gradcorr(j,i)=0.0D0
6816           gradxorr(j,i)=0.0D0
6817         enddo
6818       enddo
6819 C Calculate the local-electrostatic correlation terms
6820       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6821         i1=i+1
6822         num_conti=num_cont_hb(i)
6823         num_conti1=num_cont_hb(i+1)
6824         do jj=1,num_conti
6825           j=jcont_hb(jj,i)
6826           jp=iabs(j)
6827           do kk=1,num_conti1
6828             j1=jcont_hb(kk,i1)
6829             jp1=iabs(j1)
6830 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6831 c     &         ' jj=',jj,' kk=',kk
6832             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6833      &          .or. j.lt.0 .and. j1.gt.0) .and.
6834      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6835 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6836 C The system gains extra energy.
6837               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6838               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6839      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6840               n_corr=n_corr+1
6841             else if (j1.eq.j) then
6842 C Contacts I-J and I-(J+1) occur simultaneously.
6843 C The system loses extra energy.
6844 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6845             endif
6846           enddo ! kk
6847           do kk=1,num_conti
6848             j1=jcont_hb(kk,i)
6849 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6850 c    &         ' jj=',jj,' kk=',kk
6851             if (j1.eq.j+1) then
6852 C Contacts I-J and (I+1)-J occur simultaneously.
6853 C The system loses extra energy.
6854 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6855             endif ! j1==j+1
6856           enddo ! kk
6857         enddo ! jj
6858       enddo ! i
6859       return
6860       end
6861 c------------------------------------------------------------------------------
6862       subroutine add_hb_contact(ii,jj,itask)
6863       implicit real*8 (a-h,o-z)
6864       include "DIMENSIONS"
6865       include "COMMON.IOUNITS"
6866       integer max_cont
6867       integer max_dim
6868       parameter (max_cont=maxconts)
6869       parameter (max_dim=26)
6870       include "COMMON.CONTACTS"
6871       double precision zapas(max_dim,maxconts,max_fg_procs),
6872      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6873       common /przechowalnia/ zapas
6874       integer i,j,ii,jj,iproc,itask(4),nn
6875 c      write (iout,*) "itask",itask
6876       do i=1,2
6877         iproc=itask(i)
6878         if (iproc.gt.0) then
6879           do j=1,num_cont_hb(ii)
6880             jjc=jcont_hb(j,ii)
6881 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6882             if (jjc.eq.jj) then
6883               ncont_sent(iproc)=ncont_sent(iproc)+1
6884               nn=ncont_sent(iproc)
6885               zapas(1,nn,iproc)=ii
6886               zapas(2,nn,iproc)=jjc
6887               zapas(3,nn,iproc)=facont_hb(j,ii)
6888               zapas(4,nn,iproc)=ees0p(j,ii)
6889               zapas(5,nn,iproc)=ees0m(j,ii)
6890               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6891               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6892               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6893               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6894               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6895               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6896               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6897               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6898               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6899               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6900               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6901               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6902               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6903               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6904               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6905               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6906               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6907               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6908               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6909               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6910               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6911               exit
6912             endif
6913           enddo
6914         endif
6915       enddo
6916       return
6917       end
6918 c------------------------------------------------------------------------------
6919       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6920      &  n_corr1)
6921 C This subroutine calculates multi-body contributions to hydrogen-bonding
6922       implicit real*8 (a-h,o-z)
6923       include 'DIMENSIONS'
6924       include 'COMMON.IOUNITS'
6925 #ifdef MPI
6926       include "mpif.h"
6927       parameter (max_cont=maxconts)
6928       parameter (max_dim=70)
6929       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6930       double precision zapas(max_dim,maxconts,max_fg_procs),
6931      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6932       common /przechowalnia/ zapas
6933       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6934      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6935 #endif
6936       include 'COMMON.SETUP'
6937       include 'COMMON.FFIELD'
6938       include 'COMMON.DERIV'
6939       include 'COMMON.LOCAL'
6940       include 'COMMON.INTERACT'
6941       include 'COMMON.CONTACTS'
6942       include 'COMMON.CHAIN'
6943       include 'COMMON.CONTROL'
6944       double precision gx(3),gx1(3)
6945       integer num_cont_hb_old(maxres)
6946       logical lprn,ldone
6947       double precision eello4,eello5,eelo6,eello_turn6
6948       external eello4,eello5,eello6,eello_turn6
6949 C Set lprn=.true. for debugging
6950       lprn=.false.
6951       eturn6=0.0d0
6952 #ifdef MPI
6953       do i=1,nres
6954         num_cont_hb_old(i)=num_cont_hb(i)
6955       enddo
6956       n_corr=0
6957       n_corr1=0
6958       if (nfgtasks.le.1) goto 30
6959       if (lprn) then
6960         write (iout,'(a)') 'Contact function values before RECEIVE:'
6961         do i=nnt,nct-2
6962           write (iout,'(2i3,50(1x,i2,f5.2))')
6963      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6964      &    j=1,num_cont_hb(i))
6965         enddo
6966       endif
6967       call flush(iout)
6968       do i=1,ntask_cont_from
6969         ncont_recv(i)=0
6970       enddo
6971       do i=1,ntask_cont_to
6972         ncont_sent(i)=0
6973       enddo
6974 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6975 c     & ntask_cont_to
6976 C Make the list of contacts to send to send to other procesors
6977       do i=iturn3_start,iturn3_end
6978 c        write (iout,*) "make contact list turn3",i," num_cont",
6979 c     &    num_cont_hb(i)
6980         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6981       enddo
6982       do i=iturn4_start,iturn4_end
6983 c        write (iout,*) "make contact list turn4",i," num_cont",
6984 c     &   num_cont_hb(i)
6985         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6986       enddo
6987       do ii=1,nat_sent
6988         i=iat_sent(ii)
6989 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6990 c     &    num_cont_hb(i)
6991         do j=1,num_cont_hb(i)
6992         do k=1,4
6993           jjc=jcont_hb(j,i)
6994           iproc=iint_sent_local(k,jjc,ii)
6995 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6996           if (iproc.ne.0) then
6997             ncont_sent(iproc)=ncont_sent(iproc)+1
6998             nn=ncont_sent(iproc)
6999             zapas(1,nn,iproc)=i
7000             zapas(2,nn,iproc)=jjc
7001             zapas(3,nn,iproc)=d_cont(j,i)
7002             ind=3
7003             do kk=1,3
7004               ind=ind+1
7005               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
7006             enddo
7007             do kk=1,2
7008               do ll=1,2
7009                 ind=ind+1
7010                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
7011               enddo
7012             enddo
7013             do jj=1,5
7014               do kk=1,3
7015                 do ll=1,2
7016                   do mm=1,2
7017                     ind=ind+1
7018                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
7019                   enddo
7020                 enddo
7021               enddo
7022             enddo
7023           endif
7024         enddo
7025         enddo
7026       enddo
7027       if (lprn) then
7028       write (iout,*)
7029      &  "Numbers of contacts to be sent to other processors",
7030      &  (ncont_sent(i),i=1,ntask_cont_to)
7031       write (iout,*) "Contacts sent"
7032       do ii=1,ntask_cont_to
7033         nn=ncont_sent(ii)
7034         iproc=itask_cont_to(ii)
7035         write (iout,*) nn," contacts to processor",iproc,
7036      &   " of CONT_TO_COMM group"
7037         do i=1,nn
7038           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
7039         enddo
7040       enddo
7041       call flush(iout)
7042       endif
7043       CorrelType=477
7044       CorrelID=fg_rank+1
7045       CorrelType1=478
7046       CorrelID1=nfgtasks+fg_rank+1
7047       ireq=0
7048 C Receive the numbers of needed contacts from other processors
7049       do ii=1,ntask_cont_from
7050         iproc=itask_cont_from(ii)
7051         ireq=ireq+1
7052         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7053      &    FG_COMM,req(ireq),IERR)
7054       enddo
7055 c      write (iout,*) "IRECV ended"
7056 c      call flush(iout)
7057 C Send the number of contacts needed by other processors
7058       do ii=1,ntask_cont_to
7059         iproc=itask_cont_to(ii)
7060         ireq=ireq+1
7061         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7062      &    FG_COMM,req(ireq),IERR)
7063       enddo
7064 c      write (iout,*) "ISEND ended"
7065 c      write (iout,*) "number of requests (nn)",ireq
7066       call flush(iout)
7067       if (ireq.gt.0)
7068      &  call MPI_Waitall(ireq,req,status_array,ierr)
7069 c      write (iout,*)
7070 c     &  "Numbers of contacts to be received from other processors",
7071 c     &  (ncont_recv(i),i=1,ntask_cont_from)
7072 c      call flush(iout)
7073 C Receive contacts
7074       ireq=0
7075       do ii=1,ntask_cont_from
7076         iproc=itask_cont_from(ii)
7077         nn=ncont_recv(ii)
7078 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7079 c     &   " of CONT_TO_COMM group"
7080         call flush(iout)
7081         if (nn.gt.0) then
7082           ireq=ireq+1
7083           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
7084      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7085 c          write (iout,*) "ireq,req",ireq,req(ireq)
7086         endif
7087       enddo
7088 C Send the contacts to processors that need them
7089       do ii=1,ntask_cont_to
7090         iproc=itask_cont_to(ii)
7091         nn=ncont_sent(ii)
7092 c        write (iout,*) nn," contacts to processor",iproc,
7093 c     &   " of CONT_TO_COMM group"
7094         if (nn.gt.0) then
7095           ireq=ireq+1
7096           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
7097      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7098 c          write (iout,*) "ireq,req",ireq,req(ireq)
7099 c          do i=1,nn
7100 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7101 c          enddo
7102         endif
7103       enddo
7104 c      write (iout,*) "number of requests (contacts)",ireq
7105 c      write (iout,*) "req",(req(i),i=1,4)
7106 c      call flush(iout)
7107       if (ireq.gt.0)
7108      & call MPI_Waitall(ireq,req,status_array,ierr)
7109       do iii=1,ntask_cont_from
7110         iproc=itask_cont_from(iii)
7111         nn=ncont_recv(iii)
7112         if (lprn) then
7113         write (iout,*) "Received",nn," contacts from processor",iproc,
7114      &   " of CONT_FROM_COMM group"
7115         call flush(iout)
7116         do i=1,nn
7117           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
7118         enddo
7119         call flush(iout)
7120         endif
7121         do i=1,nn
7122           ii=zapas_recv(1,i,iii)
7123 c Flag the received contacts to prevent double-counting
7124           jj=-zapas_recv(2,i,iii)
7125 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7126 c          call flush(iout)
7127           nnn=num_cont_hb(ii)+1
7128           num_cont_hb(ii)=nnn
7129           jcont_hb(nnn,ii)=jj
7130           d_cont(nnn,ii)=zapas_recv(3,i,iii)
7131           ind=3
7132           do kk=1,3
7133             ind=ind+1
7134             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
7135           enddo
7136           do kk=1,2
7137             do ll=1,2
7138               ind=ind+1
7139               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
7140             enddo
7141           enddo
7142           do jj=1,5
7143             do kk=1,3
7144               do ll=1,2
7145                 do mm=1,2
7146                   ind=ind+1
7147                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
7148                 enddo
7149               enddo
7150             enddo
7151           enddo
7152         enddo
7153       enddo
7154       call flush(iout)
7155       if (lprn) then
7156         write (iout,'(a)') 'Contact function values after receive:'
7157         do i=nnt,nct-2
7158           write (iout,'(2i3,50(1x,i3,5f6.3))')
7159      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7160      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7161         enddo
7162         call flush(iout)
7163       endif
7164    30 continue
7165 #endif
7166       if (lprn) then
7167         write (iout,'(a)') 'Contact function values:'
7168         do i=nnt,nct-2
7169           write (iout,'(2i3,50(1x,i2,5f6.3))')
7170      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7171      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7172         enddo
7173       endif
7174       ecorr=0.0D0
7175       ecorr5=0.0d0
7176       ecorr6=0.0d0
7177 C Remove the loop below after debugging !!!
7178       do i=nnt,nct
7179         do j=1,3
7180           gradcorr(j,i)=0.0D0
7181           gradxorr(j,i)=0.0D0
7182         enddo
7183       enddo
7184 C Calculate the dipole-dipole interaction energies
7185       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7186       do i=iatel_s,iatel_e+1
7187         num_conti=num_cont_hb(i)
7188         do jj=1,num_conti
7189           j=jcont_hb(jj,i)
7190 #ifdef MOMENT
7191           call dipole(i,j,jj)
7192 #endif
7193         enddo
7194       enddo
7195       endif
7196 C Calculate the local-electrostatic correlation terms
7197 c                write (iout,*) "gradcorr5 in eello5 before loop"
7198 c                do iii=1,nres
7199 c                  write (iout,'(i5,3f10.5)')
7200 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7201 c                enddo
7202       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7203 c        write (iout,*) "corr loop i",i
7204         i1=i+1
7205         num_conti=num_cont_hb(i)
7206         num_conti1=num_cont_hb(i+1)
7207         do jj=1,num_conti
7208           j=jcont_hb(jj,i)
7209           jp=iabs(j)
7210           do kk=1,num_conti1
7211             j1=jcont_hb(kk,i1)
7212             jp1=iabs(j1)
7213 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7214 c     &         ' jj=',jj,' kk=',kk
7215 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
7216             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7217      &          .or. j.lt.0 .and. j1.gt.0) .and.
7218      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7219 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7220 C The system gains extra energy.
7221               n_corr=n_corr+1
7222               sqd1=dsqrt(d_cont(jj,i))
7223               sqd2=dsqrt(d_cont(kk,i1))
7224               sred_geom = sqd1*sqd2
7225               IF (sred_geom.lt.cutoff_corr) THEN
7226                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
7227      &            ekont,fprimcont)
7228 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7229 cd     &         ' jj=',jj,' kk=',kk
7230                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7231                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7232                 do l=1,3
7233                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7234                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7235                 enddo
7236                 n_corr1=n_corr1+1
7237 cd               write (iout,*) 'sred_geom=',sred_geom,
7238 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
7239 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7240 cd               write (iout,*) "g_contij",g_contij
7241 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7242 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7243                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7244                 if (wcorr4.gt.0.0d0)
7245      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7246                   if (energy_dec.and.wcorr4.gt.0.0d0)
7247      1                 write (iout,'(a6,4i5,0pf7.3)')
7248      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7249 c                write (iout,*) "gradcorr5 before eello5"
7250 c                do iii=1,nres
7251 c                  write (iout,'(i5,3f10.5)')
7252 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7253 c                enddo
7254                 if (wcorr5.gt.0.0d0)
7255      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7256 c                write (iout,*) "gradcorr5 after eello5"
7257 c                do iii=1,nres
7258 c                  write (iout,'(i5,3f10.5)')
7259 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7260 c                enddo
7261                   if (energy_dec.and.wcorr5.gt.0.0d0)
7262      1                 write (iout,'(a6,4i5,0pf7.3)')
7263      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7264 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7265 cd                write(2,*)'ijkl',i,jp,i+1,jp1
7266                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
7267      &               .or. wturn6.eq.0.0d0))then
7268 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7269                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7270                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7271      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7272 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7273 cd     &            'ecorr6=',ecorr6
7274 cd                write (iout,'(4e15.5)') sred_geom,
7275 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7276 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7277 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7278                 else if (wturn6.gt.0.0d0
7279      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7280 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7281                   eturn6=eturn6+eello_turn6(i,jj,kk)
7282                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7283      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7284 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
7285                 endif
7286               ENDIF
7287 1111          continue
7288             endif
7289           enddo ! kk
7290         enddo ! jj
7291       enddo ! i
7292       do i=1,nres
7293         num_cont_hb(i)=num_cont_hb_old(i)
7294       enddo
7295 c                write (iout,*) "gradcorr5 in eello5"
7296 c                do iii=1,nres
7297 c                  write (iout,'(i5,3f10.5)')
7298 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7299 c                enddo
7300       return
7301       end
7302 c------------------------------------------------------------------------------
7303       subroutine add_hb_contact_eello(ii,jj,itask)
7304       implicit real*8 (a-h,o-z)
7305       include "DIMENSIONS"
7306       include "COMMON.IOUNITS"
7307       integer max_cont
7308       integer max_dim
7309       parameter (max_cont=maxconts)
7310       parameter (max_dim=70)
7311       include "COMMON.CONTACTS"
7312       double precision zapas(max_dim,maxconts,max_fg_procs),
7313      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7314       common /przechowalnia/ zapas
7315       integer i,j,ii,jj,iproc,itask(4),nn
7316 c      write (iout,*) "itask",itask
7317       do i=1,2
7318         iproc=itask(i)
7319         if (iproc.gt.0) then
7320           do j=1,num_cont_hb(ii)
7321             jjc=jcont_hb(j,ii)
7322 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
7323             if (jjc.eq.jj) then
7324               ncont_sent(iproc)=ncont_sent(iproc)+1
7325               nn=ncont_sent(iproc)
7326               zapas(1,nn,iproc)=ii
7327               zapas(2,nn,iproc)=jjc
7328               zapas(3,nn,iproc)=d_cont(j,ii)
7329               ind=3
7330               do kk=1,3
7331                 ind=ind+1
7332                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
7333               enddo
7334               do kk=1,2
7335                 do ll=1,2
7336                   ind=ind+1
7337                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
7338                 enddo
7339               enddo
7340               do jj=1,5
7341                 do kk=1,3
7342                   do ll=1,2
7343                     do mm=1,2
7344                       ind=ind+1
7345                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
7346                     enddo
7347                   enddo
7348                 enddo
7349               enddo
7350               exit
7351             endif
7352           enddo
7353         endif
7354       enddo
7355       return
7356       end
7357 c------------------------------------------------------------------------------
7358       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7359       implicit real*8 (a-h,o-z)
7360       include 'DIMENSIONS'
7361       include 'COMMON.IOUNITS'
7362       include 'COMMON.DERIV'
7363       include 'COMMON.INTERACT'
7364       include 'COMMON.CONTACTS'
7365       double precision gx(3),gx1(3)
7366       logical lprn
7367       lprn=.false.
7368       eij=facont_hb(jj,i)
7369       ekl=facont_hb(kk,k)
7370       ees0pij=ees0p(jj,i)
7371       ees0pkl=ees0p(kk,k)
7372       ees0mij=ees0m(jj,i)
7373       ees0mkl=ees0m(kk,k)
7374       ekont=eij*ekl
7375       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7376 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7377 C Following 4 lines for diagnostics.
7378 cd    ees0pkl=0.0D0
7379 cd    ees0pij=1.0D0
7380 cd    ees0mkl=0.0D0
7381 cd    ees0mij=1.0D0
7382 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7383 c     & 'Contacts ',i,j,
7384 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7385 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7386 c     & 'gradcorr_long'
7387 C Calculate the multi-body contribution to energy.
7388 c      ecorr=ecorr+ekont*ees
7389 C Calculate multi-body contributions to the gradient.
7390       coeffpees0pij=coeffp*ees0pij
7391       coeffmees0mij=coeffm*ees0mij
7392       coeffpees0pkl=coeffp*ees0pkl
7393       coeffmees0mkl=coeffm*ees0mkl
7394       do ll=1,3
7395 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7396         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
7397      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
7398      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
7399         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
7400      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
7401      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
7402 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7403         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
7404      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
7405      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
7406         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
7407      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
7408      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
7409         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
7410      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
7411      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
7412         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7413         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7414         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
7415      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
7416      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
7417         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7418         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7419 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7420       enddo
7421 c      write (iout,*)
7422 cgrad      do m=i+1,j-1
7423 cgrad        do ll=1,3
7424 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7425 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7426 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7427 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7428 cgrad        enddo
7429 cgrad      enddo
7430 cgrad      do m=k+1,l-1
7431 cgrad        do ll=1,3
7432 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7433 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7434 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7435 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7436 cgrad        enddo
7437 cgrad      enddo
7438 c      write (iout,*) "ehbcorr",ekont*ees
7439       ehbcorr=ekont*ees
7440       return
7441       end
7442 #ifdef MOMENT
7443 C---------------------------------------------------------------------------
7444       subroutine dipole(i,j,jj)
7445       implicit real*8 (a-h,o-z)
7446       include 'DIMENSIONS'
7447       include 'COMMON.IOUNITS'
7448       include 'COMMON.CHAIN'
7449       include 'COMMON.FFIELD'
7450       include 'COMMON.DERIV'
7451       include 'COMMON.INTERACT'
7452       include 'COMMON.CONTACTS'
7453       include 'COMMON.TORSION'
7454       include 'COMMON.VAR'
7455       include 'COMMON.GEO'
7456       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7457      &  auxmat(2,2)
7458       iti1 = itortyp(itype(i+1))
7459       if (j.lt.nres-1) then
7460         itj1 = itortyp(itype(j+1))
7461       else
7462         itj1=ntortyp
7463       endif
7464       do iii=1,2
7465         dipi(iii,1)=Ub2(iii,i)
7466         dipderi(iii)=Ub2der(iii,i)
7467         dipi(iii,2)=b1(iii,iti1)
7468         dipj(iii,1)=Ub2(iii,j)
7469         dipderj(iii)=Ub2der(iii,j)
7470         dipj(iii,2)=b1(iii,itj1)
7471       enddo
7472       kkk=0
7473       do iii=1,2
7474         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7475         do jjj=1,2
7476           kkk=kkk+1
7477           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7478         enddo
7479       enddo
7480       do kkk=1,5
7481         do lll=1,3
7482           mmm=0
7483           do iii=1,2
7484             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7485      &        auxvec(1))
7486             do jjj=1,2
7487               mmm=mmm+1
7488               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7489             enddo
7490           enddo
7491         enddo
7492       enddo
7493       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7494       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7495       do iii=1,2
7496         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7497       enddo
7498       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7499       do iii=1,2
7500         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7501       enddo
7502       return
7503       end
7504 #endif
7505 C---------------------------------------------------------------------------
7506       subroutine calc_eello(i,j,k,l,jj,kk)
7507 C
7508 C This subroutine computes matrices and vectors needed to calculate
7509 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7510 C
7511       implicit real*8 (a-h,o-z)
7512       include 'DIMENSIONS'
7513       include 'COMMON.IOUNITS'
7514       include 'COMMON.CHAIN'
7515       include 'COMMON.DERIV'
7516       include 'COMMON.INTERACT'
7517       include 'COMMON.CONTACTS'
7518       include 'COMMON.TORSION'
7519       include 'COMMON.VAR'
7520       include 'COMMON.GEO'
7521       include 'COMMON.FFIELD'
7522       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7523      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7524       logical lprn
7525       common /kutas/ lprn
7526 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7527 cd     & ' jj=',jj,' kk=',kk
7528 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7529 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7530 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7531       do iii=1,2
7532         do jjj=1,2
7533           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7534           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7535         enddo
7536       enddo
7537       call transpose2(aa1(1,1),aa1t(1,1))
7538       call transpose2(aa2(1,1),aa2t(1,1))
7539       do kkk=1,5
7540         do lll=1,3
7541           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7542      &      aa1tder(1,1,lll,kkk))
7543           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7544      &      aa2tder(1,1,lll,kkk))
7545         enddo
7546       enddo
7547       if (l.eq.j+1) then
7548 C parallel orientation of the two CA-CA-CA frames.
7549         if (i.gt.1) then
7550           iti=itortyp(itype(i))
7551         else
7552           iti=ntortyp
7553         endif
7554         itk1=itortyp(itype(k+1))
7555         itj=itortyp(itype(j))
7556         if (l.lt.nres-1) then
7557           itl1=itortyp(itype(l+1))
7558         else
7559           itl1=ntortyp
7560         endif
7561 C A1 kernel(j+1) A2T
7562 cd        do iii=1,2
7563 cd          write (iout,'(3f10.5,5x,3f10.5)')
7564 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7565 cd        enddo
7566         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7567      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7568      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7569 C Following matrices are needed only for 6-th order cumulants
7570         IF (wcorr6.gt.0.0d0) THEN
7571         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7572      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7573      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7574         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7575      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7576      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7577      &   ADtEAderx(1,1,1,1,1,1))
7578         lprn=.false.
7579         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7580      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7581      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7582      &   ADtEA1derx(1,1,1,1,1,1))
7583         ENDIF
7584 C End 6-th order cumulants
7585 cd        lprn=.false.
7586 cd        if (lprn) then
7587 cd        write (2,*) 'In calc_eello6'
7588 cd        do iii=1,2
7589 cd          write (2,*) 'iii=',iii
7590 cd          do kkk=1,5
7591 cd            write (2,*) 'kkk=',kkk
7592 cd            do jjj=1,2
7593 cd              write (2,'(3(2f10.5),5x)')
7594 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7595 cd            enddo
7596 cd          enddo
7597 cd        enddo
7598 cd        endif
7599         call transpose2(EUgder(1,1,k),auxmat(1,1))
7600         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7601         call transpose2(EUg(1,1,k),auxmat(1,1))
7602         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7603         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7604         do iii=1,2
7605           do kkk=1,5
7606             do lll=1,3
7607               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7608      &          EAEAderx(1,1,lll,kkk,iii,1))
7609             enddo
7610           enddo
7611         enddo
7612 C A1T kernel(i+1) A2
7613         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7614      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7615      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7616 C Following matrices are needed only for 6-th order cumulants
7617         IF (wcorr6.gt.0.0d0) THEN
7618         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7619      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7620      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7621         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7622      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7623      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7624      &   ADtEAderx(1,1,1,1,1,2))
7625         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7626      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7627      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7628      &   ADtEA1derx(1,1,1,1,1,2))
7629         ENDIF
7630 C End 6-th order cumulants
7631         call transpose2(EUgder(1,1,l),auxmat(1,1))
7632         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7633         call transpose2(EUg(1,1,l),auxmat(1,1))
7634         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7635         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7636         do iii=1,2
7637           do kkk=1,5
7638             do lll=1,3
7639               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7640      &          EAEAderx(1,1,lll,kkk,iii,2))
7641             enddo
7642           enddo
7643         enddo
7644 C AEAb1 and AEAb2
7645 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7646 C They are needed only when the fifth- or the sixth-order cumulants are
7647 C indluded.
7648         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7649         call transpose2(AEA(1,1,1),auxmat(1,1))
7650         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7651         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7652         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7653         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7654         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7655         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7656         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7657         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7658         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7659         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7660         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7661         call transpose2(AEA(1,1,2),auxmat(1,1))
7662         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7663         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7664         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7665         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7666         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7667         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7668         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7669         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7670         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7671         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7672         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7673 C Calculate the Cartesian derivatives of the vectors.
7674         do iii=1,2
7675           do kkk=1,5
7676             do lll=1,3
7677               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7678               call matvec2(auxmat(1,1),b1(1,iti),
7679      &          AEAb1derx(1,lll,kkk,iii,1,1))
7680               call matvec2(auxmat(1,1),Ub2(1,i),
7681      &          AEAb2derx(1,lll,kkk,iii,1,1))
7682               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7683      &          AEAb1derx(1,lll,kkk,iii,2,1))
7684               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7685      &          AEAb2derx(1,lll,kkk,iii,2,1))
7686               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7687               call matvec2(auxmat(1,1),b1(1,itj),
7688      &          AEAb1derx(1,lll,kkk,iii,1,2))
7689               call matvec2(auxmat(1,1),Ub2(1,j),
7690      &          AEAb2derx(1,lll,kkk,iii,1,2))
7691               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7692      &          AEAb1derx(1,lll,kkk,iii,2,2))
7693               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7694      &          AEAb2derx(1,lll,kkk,iii,2,2))
7695             enddo
7696           enddo
7697         enddo
7698         ENDIF
7699 C End vectors
7700       else
7701 C Antiparallel orientation of the two CA-CA-CA frames.
7702         if (i.gt.1) then
7703           iti=itortyp(itype(i))
7704         else
7705           iti=ntortyp
7706         endif
7707         itk1=itortyp(itype(k+1))
7708         itl=itortyp(itype(l))
7709         itj=itortyp(itype(j))
7710         if (j.lt.nres-1) then
7711           itj1=itortyp(itype(j+1))
7712         else
7713           itj1=ntortyp
7714         endif
7715 C A2 kernel(j-1)T A1T
7716         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7717      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7718      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7719 C Following matrices are needed only for 6-th order cumulants
7720         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7721      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7722         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7723      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7724      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7725         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7726      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7727      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7728      &   ADtEAderx(1,1,1,1,1,1))
7729         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7730      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7731      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7732      &   ADtEA1derx(1,1,1,1,1,1))
7733         ENDIF
7734 C End 6-th order cumulants
7735         call transpose2(EUgder(1,1,k),auxmat(1,1))
7736         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7737         call transpose2(EUg(1,1,k),auxmat(1,1))
7738         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7739         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7740         do iii=1,2
7741           do kkk=1,5
7742             do lll=1,3
7743               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7744      &          EAEAderx(1,1,lll,kkk,iii,1))
7745             enddo
7746           enddo
7747         enddo
7748 C A2T kernel(i+1)T A1
7749         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7750      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7751      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7752 C Following matrices are needed only for 6-th order cumulants
7753         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7754      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7755         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7756      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7757      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7758         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7759      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7760      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7761      &   ADtEAderx(1,1,1,1,1,2))
7762         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7763      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7764      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7765      &   ADtEA1derx(1,1,1,1,1,2))
7766         ENDIF
7767 C End 6-th order cumulants
7768         call transpose2(EUgder(1,1,j),auxmat(1,1))
7769         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7770         call transpose2(EUg(1,1,j),auxmat(1,1))
7771         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7772         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7773         do iii=1,2
7774           do kkk=1,5
7775             do lll=1,3
7776               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7777      &          EAEAderx(1,1,lll,kkk,iii,2))
7778             enddo
7779           enddo
7780         enddo
7781 C AEAb1 and AEAb2
7782 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7783 C They are needed only when the fifth- or the sixth-order cumulants are
7784 C indluded.
7785         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7786      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7787         call transpose2(AEA(1,1,1),auxmat(1,1))
7788         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7789         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7790         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7791         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7792         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7793         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7794         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7795         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7796         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7797         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7798         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7799         call transpose2(AEA(1,1,2),auxmat(1,1))
7800         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7801         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7802         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7803         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7804         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7805         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7806         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7807         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7808         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7809         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7810         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7811 C Calculate the Cartesian derivatives of the vectors.
7812         do iii=1,2
7813           do kkk=1,5
7814             do lll=1,3
7815               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7816               call matvec2(auxmat(1,1),b1(1,iti),
7817      &          AEAb1derx(1,lll,kkk,iii,1,1))
7818               call matvec2(auxmat(1,1),Ub2(1,i),
7819      &          AEAb2derx(1,lll,kkk,iii,1,1))
7820               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7821      &          AEAb1derx(1,lll,kkk,iii,2,1))
7822               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7823      &          AEAb2derx(1,lll,kkk,iii,2,1))
7824               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7825               call matvec2(auxmat(1,1),b1(1,itl),
7826      &          AEAb1derx(1,lll,kkk,iii,1,2))
7827               call matvec2(auxmat(1,1),Ub2(1,l),
7828      &          AEAb2derx(1,lll,kkk,iii,1,2))
7829               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7830      &          AEAb1derx(1,lll,kkk,iii,2,2))
7831               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7832      &          AEAb2derx(1,lll,kkk,iii,2,2))
7833             enddo
7834           enddo
7835         enddo
7836         ENDIF
7837 C End vectors
7838       endif
7839       return
7840       end
7841 C---------------------------------------------------------------------------
7842       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7843      &  KK,KKderg,AKA,AKAderg,AKAderx)
7844       implicit none
7845       integer nderg
7846       logical transp
7847       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7848      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7849      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7850       integer iii,kkk,lll
7851       integer jjj,mmm
7852       logical lprn
7853       common /kutas/ lprn
7854       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7855       do iii=1,nderg
7856         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7857      &    AKAderg(1,1,iii))
7858       enddo
7859 cd      if (lprn) write (2,*) 'In kernel'
7860       do kkk=1,5
7861 cd        if (lprn) write (2,*) 'kkk=',kkk
7862         do lll=1,3
7863           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7864      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7865 cd          if (lprn) then
7866 cd            write (2,*) 'lll=',lll
7867 cd            write (2,*) 'iii=1'
7868 cd            do jjj=1,2
7869 cd              write (2,'(3(2f10.5),5x)')
7870 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7871 cd            enddo
7872 cd          endif
7873           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7874      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7875 cd          if (lprn) then
7876 cd            write (2,*) 'lll=',lll
7877 cd            write (2,*) 'iii=2'
7878 cd            do jjj=1,2
7879 cd              write (2,'(3(2f10.5),5x)')
7880 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7881 cd            enddo
7882 cd          endif
7883         enddo
7884       enddo
7885       return
7886       end
7887 C---------------------------------------------------------------------------
7888       double precision function eello4(i,j,k,l,jj,kk)
7889       implicit real*8 (a-h,o-z)
7890       include 'DIMENSIONS'
7891       include 'COMMON.IOUNITS'
7892       include 'COMMON.CHAIN'
7893       include 'COMMON.DERIV'
7894       include 'COMMON.INTERACT'
7895       include 'COMMON.CONTACTS'
7896       include 'COMMON.TORSION'
7897       include 'COMMON.VAR'
7898       include 'COMMON.GEO'
7899       double precision pizda(2,2),ggg1(3),ggg2(3)
7900 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7901 cd        eello4=0.0d0
7902 cd        return
7903 cd      endif
7904 cd      print *,'eello4:',i,j,k,l,jj,kk
7905 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7906 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7907 cold      eij=facont_hb(jj,i)
7908 cold      ekl=facont_hb(kk,k)
7909 cold      ekont=eij*ekl
7910       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7911 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7912       gcorr_loc(k-1)=gcorr_loc(k-1)
7913      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7914       if (l.eq.j+1) then
7915         gcorr_loc(l-1)=gcorr_loc(l-1)
7916      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7917       else
7918         gcorr_loc(j-1)=gcorr_loc(j-1)
7919      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7920       endif
7921       do iii=1,2
7922         do kkk=1,5
7923           do lll=1,3
7924             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7925      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7926 cd            derx(lll,kkk,iii)=0.0d0
7927           enddo
7928         enddo
7929       enddo
7930 cd      gcorr_loc(l-1)=0.0d0
7931 cd      gcorr_loc(j-1)=0.0d0
7932 cd      gcorr_loc(k-1)=0.0d0
7933 cd      eel4=1.0d0
7934 cd      write (iout,*)'Contacts have occurred for peptide groups',
7935 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7936 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7937       if (j.lt.nres-1) then
7938         j1=j+1
7939         j2=j-1
7940       else
7941         j1=j-1
7942         j2=j-2
7943       endif
7944       if (l.lt.nres-1) then
7945         l1=l+1
7946         l2=l-1
7947       else
7948         l1=l-1
7949         l2=l-2
7950       endif
7951       do ll=1,3
7952 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7953 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7954         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7955         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7956 cgrad        ghalf=0.5d0*ggg1(ll)
7957         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7958         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7959         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7960         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7961         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7962         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7963 cgrad        ghalf=0.5d0*ggg2(ll)
7964         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7965         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7966         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7967         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7968         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7969         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7970       enddo
7971 cgrad      do m=i+1,j-1
7972 cgrad        do ll=1,3
7973 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7974 cgrad        enddo
7975 cgrad      enddo
7976 cgrad      do m=k+1,l-1
7977 cgrad        do ll=1,3
7978 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7979 cgrad        enddo
7980 cgrad      enddo
7981 cgrad      do m=i+2,j2
7982 cgrad        do ll=1,3
7983 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7984 cgrad        enddo
7985 cgrad      enddo
7986 cgrad      do m=k+2,l2
7987 cgrad        do ll=1,3
7988 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7989 cgrad        enddo
7990 cgrad      enddo
7991 cd      do iii=1,nres-3
7992 cd        write (2,*) iii,gcorr_loc(iii)
7993 cd      enddo
7994       eello4=ekont*eel4
7995 cd      write (2,*) 'ekont',ekont
7996 cd      write (iout,*) 'eello4',ekont*eel4
7997       return
7998       end
7999 C---------------------------------------------------------------------------
8000       double precision function eello5(i,j,k,l,jj,kk)
8001       implicit real*8 (a-h,o-z)
8002       include 'DIMENSIONS'
8003       include 'COMMON.IOUNITS'
8004       include 'COMMON.CHAIN'
8005       include 'COMMON.DERIV'
8006       include 'COMMON.INTERACT'
8007       include 'COMMON.CONTACTS'
8008       include 'COMMON.TORSION'
8009       include 'COMMON.VAR'
8010       include 'COMMON.GEO'
8011       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
8012       double precision ggg1(3),ggg2(3)
8013 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8014 C                                                                              C
8015 C                            Parallel chains                                   C
8016 C                                                                              C
8017 C          o             o                   o             o                   C
8018 C         /l\           / \             \   / \           / \   /              C
8019 C        /   \         /   \             \ /   \         /   \ /               C
8020 C       j| o |l1       | o |              o| o |         | o |o                C
8021 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8022 C      \i/   \         /   \ /             /   \         /   \                 C
8023 C       o    k1             o                                                  C
8024 C         (I)          (II)                (III)          (IV)                 C
8025 C                                                                              C
8026 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8027 C                                                                              C
8028 C                            Antiparallel chains                               C
8029 C                                                                              C
8030 C          o             o                   o             o                   C
8031 C         /j\           / \             \   / \           / \   /              C
8032 C        /   \         /   \             \ /   \         /   \ /               C
8033 C      j1| o |l        | o |              o| o |         | o |o                C
8034 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8035 C      \i/   \         /   \ /             /   \         /   \                 C
8036 C       o     k1            o                                                  C
8037 C         (I)          (II)                (III)          (IV)                 C
8038 C                                                                              C
8039 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8040 C                                                                              C
8041 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
8042 C                                                                              C
8043 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8044 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8045 cd        eello5=0.0d0
8046 cd        return
8047 cd      endif
8048 cd      write (iout,*)
8049 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8050 cd     &   ' and',k,l
8051       itk=itortyp(itype(k))
8052       itl=itortyp(itype(l))
8053       itj=itortyp(itype(j))
8054       eello5_1=0.0d0
8055       eello5_2=0.0d0
8056       eello5_3=0.0d0
8057       eello5_4=0.0d0
8058 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8059 cd     &   eel5_3_num,eel5_4_num)
8060       do iii=1,2
8061         do kkk=1,5
8062           do lll=1,3
8063             derx(lll,kkk,iii)=0.0d0
8064           enddo
8065         enddo
8066       enddo
8067 cd      eij=facont_hb(jj,i)
8068 cd      ekl=facont_hb(kk,k)
8069 cd      ekont=eij*ekl
8070 cd      write (iout,*)'Contacts have occurred for peptide groups',
8071 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
8072 cd      goto 1111
8073 C Contribution from the graph I.
8074 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8075 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8076       call transpose2(EUg(1,1,k),auxmat(1,1))
8077       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8078       vv(1)=pizda(1,1)-pizda(2,2)
8079       vv(2)=pizda(1,2)+pizda(2,1)
8080       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
8081      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8082 C Explicit gradient in virtual-dihedral angles.
8083       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
8084      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
8085      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8086       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8087       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8088       vv(1)=pizda(1,1)-pizda(2,2)
8089       vv(2)=pizda(1,2)+pizda(2,1)
8090       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8091      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
8092      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8093       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8094       vv(1)=pizda(1,1)-pizda(2,2)
8095       vv(2)=pizda(1,2)+pizda(2,1)
8096       if (l.eq.j+1) then
8097         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
8098      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8099      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8100       else
8101         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
8102      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8103      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8104       endif
8105 C Cartesian gradient
8106       do iii=1,2
8107         do kkk=1,5
8108           do lll=1,3
8109             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
8110      &        pizda(1,1))
8111             vv(1)=pizda(1,1)-pizda(2,2)
8112             vv(2)=pizda(1,2)+pizda(2,1)
8113             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8114      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
8115      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8116           enddo
8117         enddo
8118       enddo
8119 c      goto 1112
8120 c1111  continue
8121 C Contribution from graph II
8122       call transpose2(EE(1,1,itk),auxmat(1,1))
8123       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8124       vv(1)=pizda(1,1)+pizda(2,2)
8125       vv(2)=pizda(2,1)-pizda(1,2)
8126       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
8127      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
8128 C Explicit gradient in virtual-dihedral angles.
8129       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8130      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8131       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8132       vv(1)=pizda(1,1)+pizda(2,2)
8133       vv(2)=pizda(2,1)-pizda(1,2)
8134       if (l.eq.j+1) then
8135         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8136      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
8137      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8138       else
8139         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8140      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
8141      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8142       endif
8143 C Cartesian gradient
8144       do iii=1,2
8145         do kkk=1,5
8146           do lll=1,3
8147             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8148      &        pizda(1,1))
8149             vv(1)=pizda(1,1)+pizda(2,2)
8150             vv(2)=pizda(2,1)-pizda(1,2)
8151             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8152      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
8153      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
8154           enddo
8155         enddo
8156       enddo
8157 cd      goto 1112
8158 cd1111  continue
8159       if (l.eq.j+1) then
8160 cd        goto 1110
8161 C Parallel orientation
8162 C Contribution from graph III
8163         call transpose2(EUg(1,1,l),auxmat(1,1))
8164         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8165         vv(1)=pizda(1,1)-pizda(2,2)
8166         vv(2)=pizda(1,2)+pizda(2,1)
8167         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
8168      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8169 C Explicit gradient in virtual-dihedral angles.
8170         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8171      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
8172      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8173         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8174         vv(1)=pizda(1,1)-pizda(2,2)
8175         vv(2)=pizda(1,2)+pizda(2,1)
8176         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8177      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
8178      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8179         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8180         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8181         vv(1)=pizda(1,1)-pizda(2,2)
8182         vv(2)=pizda(1,2)+pizda(2,1)
8183         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8184      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
8185      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8186 C Cartesian gradient
8187         do iii=1,2
8188           do kkk=1,5
8189             do lll=1,3
8190               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8191      &          pizda(1,1))
8192               vv(1)=pizda(1,1)-pizda(2,2)
8193               vv(2)=pizda(1,2)+pizda(2,1)
8194               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8195      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
8196      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8197             enddo
8198           enddo
8199         enddo
8200 cd        goto 1112
8201 C Contribution from graph IV
8202 cd1110    continue
8203         call transpose2(EE(1,1,itl),auxmat(1,1))
8204         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8205         vv(1)=pizda(1,1)+pizda(2,2)
8206         vv(2)=pizda(2,1)-pizda(1,2)
8207         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
8208      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
8209 C Explicit gradient in virtual-dihedral angles.
8210         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8211      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8212         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8213         vv(1)=pizda(1,1)+pizda(2,2)
8214         vv(2)=pizda(2,1)-pizda(1,2)
8215         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8216      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
8217      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8218 C Cartesian gradient
8219         do iii=1,2
8220           do kkk=1,5
8221             do lll=1,3
8222               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8223      &          pizda(1,1))
8224               vv(1)=pizda(1,1)+pizda(2,2)
8225               vv(2)=pizda(2,1)-pizda(1,2)
8226               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8227      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
8228      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
8229             enddo
8230           enddo
8231         enddo
8232       else
8233 C Antiparallel orientation
8234 C Contribution from graph III
8235 c        goto 1110
8236         call transpose2(EUg(1,1,j),auxmat(1,1))
8237         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8238         vv(1)=pizda(1,1)-pizda(2,2)
8239         vv(2)=pizda(1,2)+pizda(2,1)
8240         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
8241      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8242 C Explicit gradient in virtual-dihedral angles.
8243         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8244      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
8245      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8246         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8247         vv(1)=pizda(1,1)-pizda(2,2)
8248         vv(2)=pizda(1,2)+pizda(2,1)
8249         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8250      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
8251      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8252         call transpose2(EUgder(1,1,j),auxmat1(1,1))
8253         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8254         vv(1)=pizda(1,1)-pizda(2,2)
8255         vv(2)=pizda(1,2)+pizda(2,1)
8256         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8257      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
8258      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8259 C Cartesian gradient
8260         do iii=1,2
8261           do kkk=1,5
8262             do lll=1,3
8263               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8264      &          pizda(1,1))
8265               vv(1)=pizda(1,1)-pizda(2,2)
8266               vv(2)=pizda(1,2)+pizda(2,1)
8267               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8268      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
8269      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8270             enddo
8271           enddo
8272         enddo
8273 cd        goto 1112
8274 C Contribution from graph IV
8275 1110    continue
8276         call transpose2(EE(1,1,itj),auxmat(1,1))
8277         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8278         vv(1)=pizda(1,1)+pizda(2,2)
8279         vv(2)=pizda(2,1)-pizda(1,2)
8280         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
8281      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
8282 C Explicit gradient in virtual-dihedral angles.
8283         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8284      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
8285         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8286         vv(1)=pizda(1,1)+pizda(2,2)
8287         vv(2)=pizda(2,1)-pizda(1,2)
8288         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8289      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
8290      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
8291 C Cartesian gradient
8292         do iii=1,2
8293           do kkk=1,5
8294             do lll=1,3
8295               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8296      &          pizda(1,1))
8297               vv(1)=pizda(1,1)+pizda(2,2)
8298               vv(2)=pizda(2,1)-pizda(1,2)
8299               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8300      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
8301      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
8302             enddo
8303           enddo
8304         enddo
8305       endif
8306 1112  continue
8307       eel5=eello5_1+eello5_2+eello5_3+eello5_4
8308 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
8309 cd        write (2,*) 'ijkl',i,j,k,l
8310 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
8311 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
8312 cd      endif
8313 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
8314 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
8315 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
8316 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
8317       if (j.lt.nres-1) then
8318         j1=j+1
8319         j2=j-1
8320       else
8321         j1=j-1
8322         j2=j-2
8323       endif
8324       if (l.lt.nres-1) then
8325         l1=l+1
8326         l2=l-1
8327       else
8328         l1=l-1
8329         l2=l-2
8330       endif
8331 cd      eij=1.0d0
8332 cd      ekl=1.0d0
8333 cd      ekont=1.0d0
8334 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
8335 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
8336 C        summed up outside the subrouine as for the other subroutines
8337 C        handling long-range interactions. The old code is commented out
8338 C        with "cgrad" to keep track of changes.
8339       do ll=1,3
8340 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
8341 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
8342         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
8343         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
8344 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
8345 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
8346 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
8347 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
8348 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
8349 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
8350 c     &   gradcorr5ij,
8351 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
8352 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
8353 cgrad        ghalf=0.5d0*ggg1(ll)
8354 cd        ghalf=0.0d0
8355         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
8356         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
8357         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
8358         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
8359         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
8360         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
8361 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
8362 cgrad        ghalf=0.5d0*ggg2(ll)
8363 cd        ghalf=0.0d0
8364         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
8365         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
8366         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
8367         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
8368         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
8369         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
8370       enddo
8371 cd      goto 1112
8372 cgrad      do m=i+1,j-1
8373 cgrad        do ll=1,3
8374 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
8375 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
8376 cgrad        enddo
8377 cgrad      enddo
8378 cgrad      do m=k+1,l-1
8379 cgrad        do ll=1,3
8380 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
8381 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
8382 cgrad        enddo
8383 cgrad      enddo
8384 c1112  continue
8385 cgrad      do m=i+2,j2
8386 cgrad        do ll=1,3
8387 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
8388 cgrad        enddo
8389 cgrad      enddo
8390 cgrad      do m=k+2,l2
8391 cgrad        do ll=1,3
8392 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
8393 cgrad        enddo
8394 cgrad      enddo
8395 cd      do iii=1,nres-3
8396 cd        write (2,*) iii,g_corr5_loc(iii)
8397 cd      enddo
8398       eello5=ekont*eel5
8399 cd      write (2,*) 'ekont',ekont
8400 cd      write (iout,*) 'eello5',ekont*eel5
8401       return
8402       end
8403 c--------------------------------------------------------------------------
8404       double precision function eello6(i,j,k,l,jj,kk)
8405       implicit real*8 (a-h,o-z)
8406       include 'DIMENSIONS'
8407       include 'COMMON.IOUNITS'
8408       include 'COMMON.CHAIN'
8409       include 'COMMON.DERIV'
8410       include 'COMMON.INTERACT'
8411       include 'COMMON.CONTACTS'
8412       include 'COMMON.TORSION'
8413       include 'COMMON.VAR'
8414       include 'COMMON.GEO'
8415       include 'COMMON.FFIELD'
8416       double precision ggg1(3),ggg2(3)
8417 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8418 cd        eello6=0.0d0
8419 cd        return
8420 cd      endif
8421 cd      write (iout,*)
8422 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8423 cd     &   ' and',k,l
8424       eello6_1=0.0d0
8425       eello6_2=0.0d0
8426       eello6_3=0.0d0
8427       eello6_4=0.0d0
8428       eello6_5=0.0d0
8429       eello6_6=0.0d0
8430 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8431 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8432       do iii=1,2
8433         do kkk=1,5
8434           do lll=1,3
8435             derx(lll,kkk,iii)=0.0d0
8436           enddo
8437         enddo
8438       enddo
8439 cd      eij=facont_hb(jj,i)
8440 cd      ekl=facont_hb(kk,k)
8441 cd      ekont=eij*ekl
8442 cd      eij=1.0d0
8443 cd      ekl=1.0d0
8444 cd      ekont=1.0d0
8445       if (l.eq.j+1) then
8446         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8447         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8448         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8449         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8450         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8451         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8452       else
8453         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8454         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8455         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8456         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8457         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8458           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8459         else
8460           eello6_5=0.0d0
8461         endif
8462         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8463       endif
8464 C If turn contributions are considered, they will be handled separately.
8465       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8466 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8467 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8468 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8469 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8470 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8471 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8472 cd      goto 1112
8473       if (j.lt.nres-1) then
8474         j1=j+1
8475         j2=j-1
8476       else
8477         j1=j-1
8478         j2=j-2
8479       endif
8480       if (l.lt.nres-1) then
8481         l1=l+1
8482         l2=l-1
8483       else
8484         l1=l-1
8485         l2=l-2
8486       endif
8487       do ll=1,3
8488 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8489 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8490 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8491 cgrad        ghalf=0.5d0*ggg1(ll)
8492 cd        ghalf=0.0d0
8493         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8494         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8495         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8496         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8497         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8498         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8499         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8500         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8501 cgrad        ghalf=0.5d0*ggg2(ll)
8502 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8503 cd        ghalf=0.0d0
8504         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8505         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8506         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8507         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8508         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8509         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8510       enddo
8511 cd      goto 1112
8512 cgrad      do m=i+1,j-1
8513 cgrad        do ll=1,3
8514 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8515 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8516 cgrad        enddo
8517 cgrad      enddo
8518 cgrad      do m=k+1,l-1
8519 cgrad        do ll=1,3
8520 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8521 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8522 cgrad        enddo
8523 cgrad      enddo
8524 cgrad1112  continue
8525 cgrad      do m=i+2,j2
8526 cgrad        do ll=1,3
8527 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8528 cgrad        enddo
8529 cgrad      enddo
8530 cgrad      do m=k+2,l2
8531 cgrad        do ll=1,3
8532 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8533 cgrad        enddo
8534 cgrad      enddo
8535 cd      do iii=1,nres-3
8536 cd        write (2,*) iii,g_corr6_loc(iii)
8537 cd      enddo
8538       eello6=ekont*eel6
8539 cd      write (2,*) 'ekont',ekont
8540 cd      write (iout,*) 'eello6',ekont*eel6
8541       return
8542       end
8543 c--------------------------------------------------------------------------
8544       double precision function eello6_graph1(i,j,k,l,imat,swap)
8545       implicit real*8 (a-h,o-z)
8546       include 'DIMENSIONS'
8547       include 'COMMON.IOUNITS'
8548       include 'COMMON.CHAIN'
8549       include 'COMMON.DERIV'
8550       include 'COMMON.INTERACT'
8551       include 'COMMON.CONTACTS'
8552       include 'COMMON.TORSION'
8553       include 'COMMON.VAR'
8554       include 'COMMON.GEO'
8555       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8556       logical swap
8557       logical lprn
8558       common /kutas/ lprn
8559 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8560 C                                                                              C
8561 C      Parallel       Antiparallel                                             C
8562 C                                                                              C
8563 C          o             o                                                     C
8564 C         /l\           /j\                                                    C
8565 C        /   \         /   \                                                   C
8566 C       /| o |         | o |\                                                  C
8567 C     \ j|/k\|  /   \  |/k\|l /                                                C
8568 C      \ /   \ /     \ /   \ /                                                 C
8569 C       o     o       o     o                                                  C
8570 C       i             i                                                        C
8571 C                                                                              C
8572 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8573       itk=itortyp(itype(k))
8574       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8575       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8576       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8577       call transpose2(EUgC(1,1,k),auxmat(1,1))
8578       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8579       vv1(1)=pizda1(1,1)-pizda1(2,2)
8580       vv1(2)=pizda1(1,2)+pizda1(2,1)
8581       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8582       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8583       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8584       s5=scalar2(vv(1),Dtobr2(1,i))
8585 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8586       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8587       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8588      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8589      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8590      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8591      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8592      & +scalar2(vv(1),Dtobr2der(1,i)))
8593       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8594       vv1(1)=pizda1(1,1)-pizda1(2,2)
8595       vv1(2)=pizda1(1,2)+pizda1(2,1)
8596       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8597       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8598       if (l.eq.j+1) then
8599         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8600      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8601      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8602      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8603      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8604       else
8605         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8606      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8607      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8608      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8609      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8610       endif
8611       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8612       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8613       vv1(1)=pizda1(1,1)-pizda1(2,2)
8614       vv1(2)=pizda1(1,2)+pizda1(2,1)
8615       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8616      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8617      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8618      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8619       do iii=1,2
8620         if (swap) then
8621           ind=3-iii
8622         else
8623           ind=iii
8624         endif
8625         do kkk=1,5
8626           do lll=1,3
8627             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8628             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8629             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8630             call transpose2(EUgC(1,1,k),auxmat(1,1))
8631             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8632      &        pizda1(1,1))
8633             vv1(1)=pizda1(1,1)-pizda1(2,2)
8634             vv1(2)=pizda1(1,2)+pizda1(2,1)
8635             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8636             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8637      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8638             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8639      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8640             s5=scalar2(vv(1),Dtobr2(1,i))
8641             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8642           enddo
8643         enddo
8644       enddo
8645       return
8646       end
8647 c----------------------------------------------------------------------------
8648       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8649       implicit real*8 (a-h,o-z)
8650       include 'DIMENSIONS'
8651       include 'COMMON.IOUNITS'
8652       include 'COMMON.CHAIN'
8653       include 'COMMON.DERIV'
8654       include 'COMMON.INTERACT'
8655       include 'COMMON.CONTACTS'
8656       include 'COMMON.TORSION'
8657       include 'COMMON.VAR'
8658       include 'COMMON.GEO'
8659       logical swap
8660       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8661      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8662       logical lprn
8663       common /kutas/ lprn
8664 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8665 C                                                                              C
8666 C      Parallel       Antiparallel                                             C
8667 C                                                                              C
8668 C          o             o                                                     C
8669 C     \   /l\           /j\   /                                                C
8670 C      \ /   \         /   \ /                                                 C
8671 C       o| o |         | o |o                                                  C
8672 C     \ j|/k\|      \  |/k\|l                                                  C
8673 C      \ /   \       \ /   \                                                   C
8674 C       o             o                                                        C
8675 C       i             i                                                        C
8676 C                                                                              C
8677 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8678 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8679 C AL 7/4/01 s1 would occur in the sixth-order moment,
8680 C           but not in a cluster cumulant
8681 #ifdef MOMENT
8682       s1=dip(1,jj,i)*dip(1,kk,k)
8683 #endif
8684       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8685       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8686       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8687       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8688       call transpose2(EUg(1,1,k),auxmat(1,1))
8689       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8690       vv(1)=pizda(1,1)-pizda(2,2)
8691       vv(2)=pizda(1,2)+pizda(2,1)
8692       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8693 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8694 #ifdef MOMENT
8695       eello6_graph2=-(s1+s2+s3+s4)
8696 #else
8697       eello6_graph2=-(s2+s3+s4)
8698 #endif
8699 c      eello6_graph2=-s3
8700 C Derivatives in gamma(i-1)
8701       if (i.gt.1) then
8702 #ifdef MOMENT
8703         s1=dipderg(1,jj,i)*dip(1,kk,k)
8704 #endif
8705         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8706         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8707         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8708         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8709 #ifdef MOMENT
8710         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8711 #else
8712         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8713 #endif
8714 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8715       endif
8716 C Derivatives in gamma(k-1)
8717 #ifdef MOMENT
8718       s1=dip(1,jj,i)*dipderg(1,kk,k)
8719 #endif
8720       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8721       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8722       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8723       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8724       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8725       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8726       vv(1)=pizda(1,1)-pizda(2,2)
8727       vv(2)=pizda(1,2)+pizda(2,1)
8728       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8729 #ifdef MOMENT
8730       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8731 #else
8732       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8733 #endif
8734 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8735 C Derivatives in gamma(j-1) or gamma(l-1)
8736       if (j.gt.1) then
8737 #ifdef MOMENT
8738         s1=dipderg(3,jj,i)*dip(1,kk,k)
8739 #endif
8740         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8741         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8742         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8743         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8744         vv(1)=pizda(1,1)-pizda(2,2)
8745         vv(2)=pizda(1,2)+pizda(2,1)
8746         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8747 #ifdef MOMENT
8748         if (swap) then
8749           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8750         else
8751           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8752         endif
8753 #endif
8754         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8755 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8756       endif
8757 C Derivatives in gamma(l-1) or gamma(j-1)
8758       if (l.gt.1) then
8759 #ifdef MOMENT
8760         s1=dip(1,jj,i)*dipderg(3,kk,k)
8761 #endif
8762         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8763         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8764         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8765         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8766         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8767         vv(1)=pizda(1,1)-pizda(2,2)
8768         vv(2)=pizda(1,2)+pizda(2,1)
8769         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8770 #ifdef MOMENT
8771         if (swap) then
8772           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8773         else
8774           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8775         endif
8776 #endif
8777         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8778 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8779       endif
8780 C Cartesian derivatives.
8781       if (lprn) then
8782         write (2,*) 'In eello6_graph2'
8783         do iii=1,2
8784           write (2,*) 'iii=',iii
8785           do kkk=1,5
8786             write (2,*) 'kkk=',kkk
8787             do jjj=1,2
8788               write (2,'(3(2f10.5),5x)')
8789      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8790             enddo
8791           enddo
8792         enddo
8793       endif
8794       do iii=1,2
8795         do kkk=1,5
8796           do lll=1,3
8797 #ifdef MOMENT
8798             if (iii.eq.1) then
8799               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8800             else
8801               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8802             endif
8803 #endif
8804             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8805      &        auxvec(1))
8806             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8807             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8808      &        auxvec(1))
8809             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8810             call transpose2(EUg(1,1,k),auxmat(1,1))
8811             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8812      &        pizda(1,1))
8813             vv(1)=pizda(1,1)-pizda(2,2)
8814             vv(2)=pizda(1,2)+pizda(2,1)
8815             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8816 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8817 #ifdef MOMENT
8818             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8819 #else
8820             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8821 #endif
8822             if (swap) then
8823               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8824             else
8825               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8826             endif
8827           enddo
8828         enddo
8829       enddo
8830       return
8831       end
8832 c----------------------------------------------------------------------------
8833       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8834       implicit real*8 (a-h,o-z)
8835       include 'DIMENSIONS'
8836       include 'COMMON.IOUNITS'
8837       include 'COMMON.CHAIN'
8838       include 'COMMON.DERIV'
8839       include 'COMMON.INTERACT'
8840       include 'COMMON.CONTACTS'
8841       include 'COMMON.TORSION'
8842       include 'COMMON.VAR'
8843       include 'COMMON.GEO'
8844       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8845       logical swap
8846 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8847 C                                                                              C
8848 C      Parallel       Antiparallel                                             C
8849 C                                                                              C
8850 C          o             o                                                     C
8851 C         /l\   /   \   /j\                                                    C
8852 C        /   \ /     \ /   \                                                   C
8853 C       /| o |o       o| o |\                                                  C
8854 C       j|/k\|  /      |/k\|l /                                                C
8855 C        /   \ /       /   \ /                                                 C
8856 C       /     o       /     o                                                  C
8857 C       i             i                                                        C
8858 C                                                                              C
8859 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8860 C
8861 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8862 C           energy moment and not to the cluster cumulant.
8863       iti=itortyp(itype(i))
8864       if (j.lt.nres-1) then
8865         itj1=itortyp(itype(j+1))
8866       else
8867         itj1=ntortyp
8868       endif
8869       itk=itortyp(itype(k))
8870       itk1=itortyp(itype(k+1))
8871       if (l.lt.nres-1) then
8872         itl1=itortyp(itype(l+1))
8873       else
8874         itl1=ntortyp
8875       endif
8876 #ifdef MOMENT
8877       s1=dip(4,jj,i)*dip(4,kk,k)
8878 #endif
8879       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8880       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8881       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8882       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8883       call transpose2(EE(1,1,itk),auxmat(1,1))
8884       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8885       vv(1)=pizda(1,1)+pizda(2,2)
8886       vv(2)=pizda(2,1)-pizda(1,2)
8887       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8888 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8889 cd     & "sum",-(s2+s3+s4)
8890 #ifdef MOMENT
8891       eello6_graph3=-(s1+s2+s3+s4)
8892 #else
8893       eello6_graph3=-(s2+s3+s4)
8894 #endif
8895 c      eello6_graph3=-s4
8896 C Derivatives in gamma(k-1)
8897       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8898       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8899       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8900       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8901 C Derivatives in gamma(l-1)
8902       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8903       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8904       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8905       vv(1)=pizda(1,1)+pizda(2,2)
8906       vv(2)=pizda(2,1)-pizda(1,2)
8907       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8908       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8909 C Cartesian derivatives.
8910       do iii=1,2
8911         do kkk=1,5
8912           do lll=1,3
8913 #ifdef MOMENT
8914             if (iii.eq.1) then
8915               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8916             else
8917               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8918             endif
8919 #endif
8920             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8921      &        auxvec(1))
8922             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8923             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8924      &        auxvec(1))
8925             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8926             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8927      &        pizda(1,1))
8928             vv(1)=pizda(1,1)+pizda(2,2)
8929             vv(2)=pizda(2,1)-pizda(1,2)
8930             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8931 #ifdef MOMENT
8932             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8933 #else
8934             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8935 #endif
8936             if (swap) then
8937               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8938             else
8939               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8940             endif
8941 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8942           enddo
8943         enddo
8944       enddo
8945       return
8946       end
8947 c----------------------------------------------------------------------------
8948       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8949       implicit real*8 (a-h,o-z)
8950       include 'DIMENSIONS'
8951       include 'COMMON.IOUNITS'
8952       include 'COMMON.CHAIN'
8953       include 'COMMON.DERIV'
8954       include 'COMMON.INTERACT'
8955       include 'COMMON.CONTACTS'
8956       include 'COMMON.TORSION'
8957       include 'COMMON.VAR'
8958       include 'COMMON.GEO'
8959       include 'COMMON.FFIELD'
8960       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8961      & auxvec1(2),auxmat1(2,2)
8962       logical swap
8963 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8964 C                                                                              C
8965 C      Parallel       Antiparallel                                             C
8966 C                                                                              C
8967 C          o             o                                                     C
8968 C         /l\   /   \   /j\                                                    C
8969 C        /   \ /     \ /   \                                                   C
8970 C       /| o |o       o| o |\                                                  C
8971 C     \ j|/k\|      \  |/k\|l                                                  C
8972 C      \ /   \       \ /   \                                                   C
8973 C       o     \       o     \                                                  C
8974 C       i             i                                                        C
8975 C                                                                              C
8976 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8977 C
8978 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8979 C           energy moment and not to the cluster cumulant.
8980 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8981       iti=itortyp(itype(i))
8982       itj=itortyp(itype(j))
8983       if (j.lt.nres-1) then
8984         itj1=itortyp(itype(j+1))
8985       else
8986         itj1=ntortyp
8987       endif
8988       itk=itortyp(itype(k))
8989       if (k.lt.nres-1) then
8990         itk1=itortyp(itype(k+1))
8991       else
8992         itk1=ntortyp
8993       endif
8994       itl=itortyp(itype(l))
8995       if (l.lt.nres-1) then
8996         itl1=itortyp(itype(l+1))
8997       else
8998         itl1=ntortyp
8999       endif
9000 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9001 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9002 cd     & ' itl',itl,' itl1',itl1
9003 #ifdef MOMENT
9004       if (imat.eq.1) then
9005         s1=dip(3,jj,i)*dip(3,kk,k)
9006       else
9007         s1=dip(2,jj,j)*dip(2,kk,l)
9008       endif
9009 #endif
9010       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9011       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9012       if (j.eq.l+1) then
9013         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
9014         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9015       else
9016         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
9017         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9018       endif
9019       call transpose2(EUg(1,1,k),auxmat(1,1))
9020       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9021       vv(1)=pizda(1,1)-pizda(2,2)
9022       vv(2)=pizda(2,1)+pizda(1,2)
9023       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9024 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9025 #ifdef MOMENT
9026       eello6_graph4=-(s1+s2+s3+s4)
9027 #else
9028       eello6_graph4=-(s2+s3+s4)
9029 #endif
9030 C Derivatives in gamma(i-1)
9031       if (i.gt.1) then
9032 #ifdef MOMENT
9033         if (imat.eq.1) then
9034           s1=dipderg(2,jj,i)*dip(3,kk,k)
9035         else
9036           s1=dipderg(4,jj,j)*dip(2,kk,l)
9037         endif
9038 #endif
9039         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9040         if (j.eq.l+1) then
9041           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
9042           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9043         else
9044           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
9045           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9046         endif
9047         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9048         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9049 cd          write (2,*) 'turn6 derivatives'
9050 #ifdef MOMENT
9051           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9052 #else
9053           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9054 #endif
9055         else
9056 #ifdef MOMENT
9057           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9058 #else
9059           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9060 #endif
9061         endif
9062       endif
9063 C Derivatives in gamma(k-1)
9064 #ifdef MOMENT
9065       if (imat.eq.1) then
9066         s1=dip(3,jj,i)*dipderg(2,kk,k)
9067       else
9068         s1=dip(2,jj,j)*dipderg(4,kk,l)
9069       endif
9070 #endif
9071       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9072       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9073       if (j.eq.l+1) then
9074         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
9075         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9076       else
9077         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
9078         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9079       endif
9080       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9081       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9082       vv(1)=pizda(1,1)-pizda(2,2)
9083       vv(2)=pizda(2,1)+pizda(1,2)
9084       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9085       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9086 #ifdef MOMENT
9087         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9088 #else
9089         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9090 #endif
9091       else
9092 #ifdef MOMENT
9093         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9094 #else
9095         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9096 #endif
9097       endif
9098 C Derivatives in gamma(j-1) or gamma(l-1)
9099       if (l.eq.j+1 .and. l.gt.1) then
9100         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9101         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9102         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9103         vv(1)=pizda(1,1)-pizda(2,2)
9104         vv(2)=pizda(2,1)+pizda(1,2)
9105         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9106         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9107       else if (j.gt.1) then
9108         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9109         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9110         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9111         vv(1)=pizda(1,1)-pizda(2,2)
9112         vv(2)=pizda(2,1)+pizda(1,2)
9113         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9114         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9115           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9116         else
9117           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9118         endif
9119       endif
9120 C Cartesian derivatives.
9121       do iii=1,2
9122         do kkk=1,5
9123           do lll=1,3
9124 #ifdef MOMENT
9125             if (iii.eq.1) then
9126               if (imat.eq.1) then
9127                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9128               else
9129                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9130               endif
9131             else
9132               if (imat.eq.1) then
9133                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9134               else
9135                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9136               endif
9137             endif
9138 #endif
9139             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
9140      &        auxvec(1))
9141             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9142             if (j.eq.l+1) then
9143               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9144      &          b1(1,itj1),auxvec(1))
9145               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
9146             else
9147               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9148      &          b1(1,itl1),auxvec(1))
9149               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
9150             endif
9151             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9152      &        pizda(1,1))
9153             vv(1)=pizda(1,1)-pizda(2,2)
9154             vv(2)=pizda(2,1)+pizda(1,2)
9155             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9156             if (swap) then
9157               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9158 #ifdef MOMENT
9159                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9160      &             -(s1+s2+s4)
9161 #else
9162                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9163      &             -(s2+s4)
9164 #endif
9165                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9166               else
9167 #ifdef MOMENT
9168                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9169 #else
9170                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9171 #endif
9172                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9173               endif
9174             else
9175 #ifdef MOMENT
9176               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9177 #else
9178               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9179 #endif
9180               if (l.eq.j+1) then
9181                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9182               else
9183                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9184               endif
9185             endif
9186           enddo
9187         enddo
9188       enddo
9189       return
9190       end
9191 c----------------------------------------------------------------------------
9192       double precision function eello_turn6(i,jj,kk)
9193       implicit real*8 (a-h,o-z)
9194       include 'DIMENSIONS'
9195       include 'COMMON.IOUNITS'
9196       include 'COMMON.CHAIN'
9197       include 'COMMON.DERIV'
9198       include 'COMMON.INTERACT'
9199       include 'COMMON.CONTACTS'
9200       include 'COMMON.TORSION'
9201       include 'COMMON.VAR'
9202       include 'COMMON.GEO'
9203       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
9204      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
9205      &  ggg1(3),ggg2(3)
9206       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
9207      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
9208 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9209 C           the respective energy moment and not to the cluster cumulant.
9210       s1=0.0d0
9211       s8=0.0d0
9212       s13=0.0d0
9213 c
9214       eello_turn6=0.0d0
9215       j=i+4
9216       k=i+1
9217       l=i+3
9218       iti=itortyp(itype(i))
9219       itk=itortyp(itype(k))
9220       itk1=itortyp(itype(k+1))
9221       itl=itortyp(itype(l))
9222       itj=itortyp(itype(j))
9223 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9224 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
9225 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9226 cd        eello6=0.0d0
9227 cd        return
9228 cd      endif
9229 cd      write (iout,*)
9230 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9231 cd     &   ' and',k,l
9232 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
9233       do iii=1,2
9234         do kkk=1,5
9235           do lll=1,3
9236             derx_turn(lll,kkk,iii)=0.0d0
9237           enddo
9238         enddo
9239       enddo
9240 cd      eij=1.0d0
9241 cd      ekl=1.0d0
9242 cd      ekont=1.0d0
9243       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9244 cd      eello6_5=0.0d0
9245 cd      write (2,*) 'eello6_5',eello6_5
9246 #ifdef MOMENT
9247       call transpose2(AEA(1,1,1),auxmat(1,1))
9248       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
9249       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
9250       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
9251 #endif
9252       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9253       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
9254       s2 = scalar2(b1(1,itk),vtemp1(1))
9255 #ifdef MOMENT
9256       call transpose2(AEA(1,1,2),atemp(1,1))
9257       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
9258       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
9259       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9260 #endif
9261       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
9262       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
9263       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
9264 #ifdef MOMENT
9265       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
9266       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
9267       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
9268       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
9269       ss13 = scalar2(b1(1,itk),vtemp4(1))
9270       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
9271 #endif
9272 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
9273 c      s1=0.0d0
9274 c      s2=0.0d0
9275 c      s8=0.0d0
9276 c      s12=0.0d0
9277 c      s13=0.0d0
9278       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
9279 C Derivatives in gamma(i+2)
9280       s1d =0.0d0
9281       s8d =0.0d0
9282 #ifdef MOMENT
9283       call transpose2(AEA(1,1,1),auxmatd(1,1))
9284       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9285       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9286       call transpose2(AEAderg(1,1,2),atempd(1,1))
9287       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9288       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9289 #endif
9290       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
9291       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9292       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9293 c      s1d=0.0d0
9294 c      s2d=0.0d0
9295 c      s8d=0.0d0
9296 c      s12d=0.0d0
9297 c      s13d=0.0d0
9298       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
9299 C Derivatives in gamma(i+3)
9300 #ifdef MOMENT
9301       call transpose2(AEA(1,1,1),auxmatd(1,1))
9302       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9303       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
9304       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
9305 #endif
9306       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
9307       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
9308       s2d = scalar2(b1(1,itk),vtemp1d(1))
9309 #ifdef MOMENT
9310       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
9311       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
9312 #endif
9313       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
9314 #ifdef MOMENT
9315       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
9316       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9317       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9318 #endif
9319 c      s1d=0.0d0
9320 c      s2d=0.0d0
9321 c      s8d=0.0d0
9322 c      s12d=0.0d0
9323 c      s13d=0.0d0
9324 #ifdef MOMENT
9325       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9326      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9327 #else
9328       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9329      &               -0.5d0*ekont*(s2d+s12d)
9330 #endif
9331 C Derivatives in gamma(i+4)
9332       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
9333       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9334       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9335 #ifdef MOMENT
9336       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
9337       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
9338       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9339 #endif
9340 c      s1d=0.0d0
9341 c      s2d=0.0d0
9342 c      s8d=0.0d0
9343 C      s12d=0.0d0
9344 c      s13d=0.0d0
9345 #ifdef MOMENT
9346       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
9347 #else
9348       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
9349 #endif
9350 C Derivatives in gamma(i+5)
9351 #ifdef MOMENT
9352       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
9353       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9354       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9355 #endif
9356       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
9357       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
9358       s2d = scalar2(b1(1,itk),vtemp1d(1))
9359 #ifdef MOMENT
9360       call transpose2(AEA(1,1,2),atempd(1,1))
9361       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
9362       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9363 #endif
9364       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
9365       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9366 #ifdef MOMENT
9367       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
9368       ss13d = scalar2(b1(1,itk),vtemp4d(1))
9369       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9370 #endif
9371 c      s1d=0.0d0
9372 c      s2d=0.0d0
9373 c      s8d=0.0d0
9374 c      s12d=0.0d0
9375 c      s13d=0.0d0
9376 #ifdef MOMENT
9377       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9378      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9379 #else
9380       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9381      &               -0.5d0*ekont*(s2d+s12d)
9382 #endif
9383 C Cartesian derivatives
9384       do iii=1,2
9385         do kkk=1,5
9386           do lll=1,3
9387 #ifdef MOMENT
9388             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
9389             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9390             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9391 #endif
9392             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9393             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
9394      &          vtemp1d(1))
9395             s2d = scalar2(b1(1,itk),vtemp1d(1))
9396 #ifdef MOMENT
9397             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
9398             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9399             s8d = -(atempd(1,1)+atempd(2,2))*
9400      &           scalar2(cc(1,1,itl),vtemp2(1))
9401 #endif
9402             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
9403      &           auxmatd(1,1))
9404             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9405             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9406 c      s1d=0.0d0
9407 c      s2d=0.0d0
9408 c      s8d=0.0d0
9409 c      s12d=0.0d0
9410 c      s13d=0.0d0
9411 #ifdef MOMENT
9412             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9413      &        - 0.5d0*(s1d+s2d)
9414 #else
9415             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9416      &        - 0.5d0*s2d
9417 #endif
9418 #ifdef MOMENT
9419             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9420      &        - 0.5d0*(s8d+s12d)
9421 #else
9422             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9423      &        - 0.5d0*s12d
9424 #endif
9425           enddo
9426         enddo
9427       enddo
9428 #ifdef MOMENT
9429       do kkk=1,5
9430         do lll=1,3
9431           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9432      &      achuj_tempd(1,1))
9433           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9434           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9435           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9436           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9437           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9438      &      vtemp4d(1))
9439           ss13d = scalar2(b1(1,itk),vtemp4d(1))
9440           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9441           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9442         enddo
9443       enddo
9444 #endif
9445 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9446 cd     &  16*eel_turn6_num
9447 cd      goto 1112
9448       if (j.lt.nres-1) then
9449         j1=j+1
9450         j2=j-1
9451       else
9452         j1=j-1
9453         j2=j-2
9454       endif
9455       if (l.lt.nres-1) then
9456         l1=l+1
9457         l2=l-1
9458       else
9459         l1=l-1
9460         l2=l-2
9461       endif
9462       do ll=1,3
9463 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9464 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9465 cgrad        ghalf=0.5d0*ggg1(ll)
9466 cd        ghalf=0.0d0
9467         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9468         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9469         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9470      &    +ekont*derx_turn(ll,2,1)
9471         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9472         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9473      &    +ekont*derx_turn(ll,4,1)
9474         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9475         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9476         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9477 cgrad        ghalf=0.5d0*ggg2(ll)
9478 cd        ghalf=0.0d0
9479         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9480      &    +ekont*derx_turn(ll,2,2)
9481         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9482         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9483      &    +ekont*derx_turn(ll,4,2)
9484         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9485         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9486         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9487       enddo
9488 cd      goto 1112
9489 cgrad      do m=i+1,j-1
9490 cgrad        do ll=1,3
9491 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9492 cgrad        enddo
9493 cgrad      enddo
9494 cgrad      do m=k+1,l-1
9495 cgrad        do ll=1,3
9496 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9497 cgrad        enddo
9498 cgrad      enddo
9499 cgrad1112  continue
9500 cgrad      do m=i+2,j2
9501 cgrad        do ll=1,3
9502 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9503 cgrad        enddo
9504 cgrad      enddo
9505 cgrad      do m=k+2,l2
9506 cgrad        do ll=1,3
9507 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9508 cgrad        enddo
9509 cgrad      enddo
9510 cd      do iii=1,nres-3
9511 cd        write (2,*) iii,g_corr6_loc(iii)
9512 cd      enddo
9513       eello_turn6=ekont*eel_turn6
9514 cd      write (2,*) 'ekont',ekont
9515 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9516       return
9517       end
9518
9519 C-----------------------------------------------------------------------------
9520       double precision function scalar(u,v)
9521 !DIR$ INLINEALWAYS scalar
9522 #ifndef OSF
9523 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9524 #endif
9525       implicit none
9526       double precision u(3),v(3)
9527 cd      double precision sc
9528 cd      integer i
9529 cd      sc=0.0d0
9530 cd      do i=1,3
9531 cd        sc=sc+u(i)*v(i)
9532 cd      enddo
9533 cd      scalar=sc
9534
9535       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9536       return
9537       end
9538 crc-------------------------------------------------
9539       SUBROUTINE MATVEC2(A1,V1,V2)
9540 !DIR$ INLINEALWAYS MATVEC2
9541 #ifndef OSF
9542 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9543 #endif
9544       implicit real*8 (a-h,o-z)
9545       include 'DIMENSIONS'
9546       DIMENSION A1(2,2),V1(2),V2(2)
9547 c      DO 1 I=1,2
9548 c        VI=0.0
9549 c        DO 3 K=1,2
9550 c    3     VI=VI+A1(I,K)*V1(K)
9551 c        Vaux(I)=VI
9552 c    1 CONTINUE
9553
9554       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9555       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9556
9557       v2(1)=vaux1
9558       v2(2)=vaux2
9559       END
9560 C---------------------------------------
9561       SUBROUTINE MATMAT2(A1,A2,A3)
9562 #ifndef OSF
9563 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9564 #endif
9565       implicit real*8 (a-h,o-z)
9566       include 'DIMENSIONS'
9567       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9568 c      DIMENSION AI3(2,2)
9569 c        DO  J=1,2
9570 c          A3IJ=0.0
9571 c          DO K=1,2
9572 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9573 c          enddo
9574 c          A3(I,J)=A3IJ
9575 c       enddo
9576 c      enddo
9577
9578       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9579       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9580       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9581       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9582
9583       A3(1,1)=AI3_11
9584       A3(2,1)=AI3_21
9585       A3(1,2)=AI3_12
9586       A3(2,2)=AI3_22
9587       END
9588
9589 c-------------------------------------------------------------------------
9590       double precision function scalar2(u,v)
9591 !DIR$ INLINEALWAYS scalar2
9592       implicit none
9593       double precision u(2),v(2)
9594       double precision sc
9595       integer i
9596       scalar2=u(1)*v(1)+u(2)*v(2)
9597       return
9598       end
9599
9600 C-----------------------------------------------------------------------------
9601
9602       subroutine transpose2(a,at)
9603 !DIR$ INLINEALWAYS transpose2
9604 #ifndef OSF
9605 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9606 #endif
9607       implicit none
9608       double precision a(2,2),at(2,2)
9609       at(1,1)=a(1,1)
9610       at(1,2)=a(2,1)
9611       at(2,1)=a(1,2)
9612       at(2,2)=a(2,2)
9613       return
9614       end
9615 c--------------------------------------------------------------------------
9616       subroutine transpose(n,a,at)
9617       implicit none
9618       integer n,i,j
9619       double precision a(n,n),at(n,n)
9620       do i=1,n
9621         do j=1,n
9622           at(j,i)=a(i,j)
9623         enddo
9624       enddo
9625       return
9626       end
9627 C---------------------------------------------------------------------------
9628       subroutine prodmat3(a1,a2,kk,transp,prod)
9629 !DIR$ INLINEALWAYS prodmat3
9630 #ifndef OSF
9631 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9632 #endif
9633       implicit none
9634       integer i,j
9635       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9636       logical transp
9637 crc      double precision auxmat(2,2),prod_(2,2)
9638
9639       if (transp) then
9640 crc        call transpose2(kk(1,1),auxmat(1,1))
9641 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9642 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9643
9644            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9645      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9646            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9647      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9648            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9649      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9650            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9651      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9652
9653       else
9654 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9655 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9656
9657            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9658      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9659            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9660      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9661            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9662      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9663            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9664      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9665
9666       endif
9667 c      call transpose2(a2(1,1),a2t(1,1))
9668
9669 crc      print *,transp
9670 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9671 crc      print *,((prod(i,j),i=1,2),j=1,2)
9672
9673       return
9674       end
9675 CCC----------------------------------------------
9676       subroutine Eliptransfer(eliptran)
9677       include 'DIMENSIONS'
9678       include 'COMMON.GEO'
9679       include 'COMMON.VAR'
9680       include 'COMMON.LOCAL'
9681       include 'COMMON.CHAIN'
9682       include 'COMMON.DERIV'
9683       include 'COMMON.NAMES'
9684       include 'COMMON.INTERACT'
9685       include 'COMMON.IOUNITS'
9686       include 'COMMON.CALC'
9687       include 'COMMON.CONTROL'
9688       include 'COMMON.SPLITELE'
9689       include 'COMMON.SBRIDGE'
9690 C structure of box:
9691 C      water
9692 C--bordliptop-- buffore starts
9693 C--bufliptop--- here true lipid starts
9694 C      lipid
9695 C--buflipbot--- lipid ends buffore starts
9696 C--bordlipbot--buffore ends
9697       eliptran=0.0
9698       do i=1,nres
9699 C first for peptide groups
9700 c for each residue check if it is in lipid or lipid water border area
9701        if ((mod(c(3,i),boxzsize).gt.bordlipbot)
9702      &.and.(mod(c(3,i),boxzsize).lt.bordliptop)) then
9703 C the energy transfer exist
9704         if (mod(c(3,i),boxzsize).lt.buflipbot) then
9705 C what fraction I am in
9706          fracinbuf=1.0d0-
9707      &        ((mod(c(3,i),boxzsize)-bordlipbot)/lipbufthick)
9708 C lipbufthick is thickenes of lipid buffore
9709          ssslip=sscale(fracinbuf)
9710          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
9711          eliptran=eliptran+sslip
9712          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran
9713 C         print *,"doing sccale for lower part"
9714         elseif (mod(c(3,i),boxzsize).gt.bufliptop) then
9715          fracinbuf=1.0d0-((bordliptop-mod(c(3,i),boxzsize))/lipbufthick)
9716          ssslip=sscale(fracinbuf)
9717          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
9718          eliptran=eliptran+sslip
9719          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran
9720           print *, "doing sscalefor top part"
9721         else
9722          eliptran=eliptran+1.0d0
9723          print *,"I am in true lipid"
9724         endif
9725 C       else
9726 C       eliptran=elpitran+0.0 ! I am in water
9727        endif
9728        enddo
9729 C now multiply all by the peptide group transfer factor
9730        eliptran=eliptran*pepliptran
9731 C now the same for side chains
9732        do i=1,nres
9733 c for each residue check if it is in lipid or lipid water border area
9734        if ((mod(c(3,i+nres),boxzsize).gt.bordlipbot)
9735      & .and.(mod(c(3,i+nres),boxzsize).lt.bordliptop)) then
9736 C the energy transfer exist
9737         if (mod(c(3,i+nres),boxzsize).lt.buflipbot) then
9738          fracinbuf=1.0d0-
9739      &     ((mod(c(3,i+nres),boxzsize)-bordlipbot)/lipbufthick)
9740 C lipbufthick is thickenes of lipid buffore
9741          ssslip=sscale(fracinbuf)
9742          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
9743          eliptran=eliptran+sslip*liptranene(itype(i))
9744          gliptranx(3,i)=gliptranx(3,i)+ssgradlip*liptranene(itype(i))
9745          print *,"doing sccale for lower part"
9746         elseif (mod(c(3,i+nres),boxzsize).gt.bufliptop) then
9747          fracinbuf=1.0d0-
9748      &((bordliptop-mod(c(3,i+nres),boxzsize))/lipbufthick)
9749          ssslip=sscale(fracinbuf)
9750          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
9751          eliptran=eliptran+sslip*liptranene(itype(i))
9752          gliptranx(3,i)=gliptranx(3,i)+ssgradlip*liptranene(itype(i))
9753           print *, "doing sscalefor top part"
9754         else
9755          eliptran=eliptran+liptranene(itype(i))
9756          print *,"I am in true lipid"
9757         endif
9758 C       else
9759 C       eliptran=elpitran+0.0 ! I am in water
9760        enddo
9761