source/unres/src_MD/energy_p_new_barrier.F

   1       subroutine etotal(energia)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4 #ifndef ISNAN
   5       external proc_proc
   6 #ifdef WINPGI
   7 cMS$ATTRIBUTES C ::  proc_proc
   8 #endif
   9 #endif
  10 #ifdef MPI
  11       include "mpif.h"
  12       double precision weights_(n_ene)
  13 #endif
  14       include 'COMMON.SETUP'
  15       include 'COMMON.IOUNITS'
  16       double precision energia(0:n_ene)
  17       include 'COMMON.LOCAL'
  18       include 'COMMON.FFIELD'
  19       include 'COMMON.DERIV'
  20       include 'COMMON.INTERACT'
  21       include 'COMMON.SBRIDGE'
  22       include 'COMMON.CHAIN'
  23       include 'COMMON.VAR'
  24       include 'COMMON.MD'
  25       include 'COMMON.CONTROL'
  26       include 'COMMON.TIME1'
  27 #ifdef MPI
  28 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  29 c     & " nfgtasks",nfgtasks
  30       call flush(iout)
  31       if (nfgtasks.gt.1) then
  32 #ifdef MPI
  33         time00=MPI_Wtime()
  34 #else
  35         time00=tcpu()
  36 #endif
  37 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  38         if (fg_rank.eq.0) then
  39           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  40 c          print *,"Processor",myrank," BROADCAST iorder"
  41 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  42 C FG slaves as WEIGHTS array.
  43           weights_(1)=wsc
  44           weights_(2)=wscp
  45           weights_(3)=welec
  46           weights_(4)=wcorr
  47           weights_(5)=wcorr5
  48           weights_(6)=wcorr6
  49           weights_(7)=wel_loc
  50           weights_(8)=wturn3
  51           weights_(9)=wturn4
  52           weights_(10)=wturn6
  53           weights_(11)=wang
  54           weights_(12)=wscloc
  55           weights_(13)=wtor
  56           weights_(14)=wtor_d
  57           weights_(15)=wstrain
  58           weights_(16)=wvdwpp
  59           weights_(17)=wbond
  60           weights_(18)=scal14
  61           weights_(21)=wsccor
  62           weights_(22)=wsct
  63 C FG Master broadcasts the WEIGHTS_ array
  64           call MPI_Bcast(weights_(1),n_ene,
  65      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  66         else
  67 C FG slaves receive the WEIGHTS array
  68           call MPI_Bcast(weights(1),n_ene,
  69      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  70           wsc=weights(1)
  71           wscp=weights(2)
  72           welec=weights(3)
  73           wcorr=weights(4)
  74           wcorr5=weights(5)
  75           wcorr6=weights(6)
  76           wel_loc=weights(7)
  77           wturn3=weights(8)
  78           wturn4=weights(9)
  79           wturn6=weights(10)
  80           wang=weights(11)
  81           wscloc=weights(12)
  82           wtor=weights(13)
  83           wtor_d=weights(14)
  84           wstrain=weights(15)
  85           wvdwpp=weights(16)
  86           wbond=weights(17)
  87           scal14=weights(18)
  88           wsccor=weights(21)
  89           wsct=weights(22)
  90         endif
  91         time_Bcast=time_Bcast+MPI_Wtime()-time00
  92         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  93 c        call chainbuild_cart
  94       endif
  95 c      write(iout,*) 'Processor',myrank,' calling etotal ipot=',ipot
  96 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  97 #else
  98 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  99 c        call int_from_cart1(.false.)
 100 c      endif
 101 #endif
 102 #ifndef DFA
 103       edfadis=0.0d0
 104       edfator=0.0d0
 105       edfanei=0.0d0
 106       edfabet=0.0d0
 107 #endif
 108 #ifdef TIMING
 109 #ifdef MPI
 110       time00=MPI_Wtime()
 111 #else
 112       time00=tcpu()
 113 #endif
 114 #endif
 115 C
 116 C Compute the side-chain and electrostatic interaction energy
 117 C
 118       goto (101,102,103,104,105,106) ipot
 119 C Lennard-Jones potential.
 120   101 call elj(evdw,evdw_p,evdw_m)
 121 cd    print '(a)','Exit ELJ'
 122       goto 107
 123 C Lennard-Jones-Kihara potential (shifted).
 124   102 call eljk(evdw,evdw_p,evdw_m)
 125       goto 107
 126 C Berne-Pechukas potential (dilated LJ, angular dependence).
 127   103 call ebp(evdw,evdw_p,evdw_m)
 128       goto 107
 129 C Gay-Berne potential (shifted LJ, angular dependence).
 130   104 call egb(evdw,evdw_p,evdw_m)
 131       goto 107
 132 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 133   105 call egbv(evdw,evdw_p,evdw_m)
 134       goto 107
 135 C Soft-sphere potential
 136   106 call e_softsphere(evdw)
 137 C
 138 C Calculate electrostatic (H-bonding) energy of the main chain.
 139 C
 140   107 continue
 141 #ifdef DFA
 142 C     BARTEK for dfa test!
 143       if (wdfa_dist.gt.0) then
 144         call edfad(edfadis)
 145       else
 146         edfadis=0
 147       endif
 148 c      print*, 'edfad is finished!', edfadis
 149       if (wdfa_tor.gt.0) then
 150         call edfat(edfator)
 151       else
 152         edfator=0
 153       endif
 154 c      print*, 'edfat is finished!', edfator
 155       if (wdfa_nei.gt.0) then
 156         call edfan(edfanei)
 157       else
 158         edfanei=0
 159       endif
 160 c      print*, 'edfan is finished!', edfanei
 161       if (wdfa_beta.gt.0) then
 162         call edfab(edfabet)
 163       else
 164         edfabet=0
 165       endif
 166 #endif
 167 c      print*, 'edfab is finished!', edfabet
 168 cmc
 169 cmc Sep-06: egb takes care of dynamic ss bonds too
 170 cmc
 171 c      if (dyn_ss) call dyn_set_nss
 172
 173 c      print *,"Processor",myrank," computed USCSC"
 174 #ifdef TIMING
 175 #ifdef MPI
 176       time01=MPI_Wtime()
 177 #else
 178       time00=tcpu()
 179 #endif
 180 #endif
 181       call vec_and_deriv
 182 #ifdef TIMING
 183 #ifdef MPI
 184       time_vec=time_vec+MPI_Wtime()-time01
 185 #else
 186       time_vec=time_vec+tcpu()-time01
 187 #endif
 188 #endif
 189 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 190       if (ipot.lt.6) then
 191 #ifdef SPLITELE
 192          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 193      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 194      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 195      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 196 #else
 197          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 198      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 199      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 200      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 201 #endif
 202             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 203          else
 204             ees=0.0d0
 205             evdw1=0.0d0
 206             eel_loc=0.0d0
 207             eello_turn3=0.0d0
 208             eello_turn4=0.0d0
 209          endif
 210       else
 211 c        write (iout,*) "Soft-spheer ELEC potential"
 212         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 213      &   eello_turn4)
 214       endif
 215 c      print *,"Processor",myrank," computed UELEC"
 216 C
 217 C Calculate excluded-volume interaction energy between peptide groups
 218 C and side chains.
 219 C
 220       if (ipot.lt.6) then
 221        if(wscp.gt.0d0) then
 222         call escp(evdw2,evdw2_14)
 223        else
 224         evdw2=0
 225         evdw2_14=0
 226        endif
 227       else
 228 c        write (iout,*) "Soft-sphere SCP potential"
 229         call escp_soft_sphere(evdw2,evdw2_14)
 230       endif
 231 c
 232 c Calculate the bond-stretching energy
 233 c
 234       call ebond(estr)
 235 C
 236 C Calculate the disulfide-bridge and other energy and the contributions
 237 C from other distance constraints.
 238 cd    print *,'Calling EHPB'
 239       call edis(ehpb)
 240 cd    print *,'EHPB exitted succesfully.'
 241 C
 242 C Calculate the virtual-bond-angle energy.
 243 C
 244       if (wang.gt.0d0) then
 245         call ebend(ebe)
 246       else
 247         ebe=0
 248       endif
 249 c      print *,"Processor",myrank," computed UB"
 250 C
 251 C Calculate the SC local energy.
 252 C
 253       call esc(escloc)
 254 c      print *,"Processor",myrank," computed USC"
 255 C
 256 C Calculate the virtual-bond torsional energy.
 257 C
 258 cd    print *,'nterm=',nterm
 259       if (wtor.gt.0) then
 260        call etor(etors,edihcnstr)
 261       else
 262        etors=0
 263        edihcnstr=0
 264       endif
 265
 266       if (constr_homology.ge.1.and.waga_homology(iset).ne.0d0) then
 267         call e_modeller(ehomology_constr)
 268 c        print *,'iset=',iset,'me=',me,ehomology_constr,
 269 c     &  'Processor',fg_rank,' CG group',kolor,
 270 c     &  ' absolute rank',MyRank
 271       else
 272         ehomology_constr=0.0d0
 273       endif
 274
 275
 276 c      write(iout,*) ehomology_constr
 277 c      print *,"Processor",myrank," computed Utor"
 278 C
 279 C 6/23/01 Calculate double-torsional energy
 280 C
 281       if (wtor_d.gt.0) then
 282        call etor_d(etors_d)
 283       else
 284        etors_d=0
 285       endif
 286 c      print *,"Processor",myrank," computed Utord"
 287 C
 288 C 21/5/07 Calculate local sicdechain correlation energy
 289 C
 290       if (wsccor.gt.0.0d0) then
 291         call eback_sc_corr(esccor)
 292       else
 293         esccor=0.0d0
 294       endif
 295 c      print *,"Processor",myrank," computed Usccorr"
 296 C
 297 C 12/1/95 Multi-body terms
 298 C
 299       n_corr=0
 300       n_corr1=0
 301       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 302      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 303          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 304 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 305 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 306       else
 307          ecorr=0.0d0
 308          ecorr5=0.0d0
 309          ecorr6=0.0d0
 310          eturn6=0.0d0
 311       endif
 312       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 313          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 314 cd         write (iout,*) "multibody_hb ecorr",ecorr
 315       endif
 316 c      print *,"Processor",myrank," computed Ucorr"
 317 C
 318 C If performing constraint dynamics, call the constraint energy
 319 C  after the equilibration time
 320       if(usampl.and.totT.gt.eq_time) then
 321 c         write (iout,*) "CALL TO ECONSTR_BACK"
 322          call EconstrQ
 323          call Econstr_back
 324       else
 325          Uconst=0.0d0
 326          Uconst_back=0.0d0
 327       endif
 328 #ifdef TIMING
 329 #ifdef MPI
 330       time_enecalc=time_enecalc+MPI_Wtime()-time00
 331 #else
 332       time_enecalc=time_enecalc+tcpu()-time00
 333 #endif
 334 #endif
 335 c      print *,"Processor",myrank," computed Uconstr"
 336 #ifdef TIMING
 337 #ifdef MPI
 338       time00=MPI_Wtime()
 339 #else
 340       time00=tcpu()
 341 #endif
 342 #endif
 343 c
 344 C Sum the energies
 345 C
 346       energia(1)=evdw
 347 #ifdef SCP14
 348       energia(2)=evdw2-evdw2_14
 349       energia(18)=evdw2_14
 350 #else
 351       energia(2)=evdw2
 352       energia(18)=0.0d0
 353 #endif
 354 #ifdef SPLITELE
 355       energia(3)=ees
 356       energia(16)=evdw1
 357 #else
 358       energia(3)=ees+evdw1
 359       energia(16)=0.0d0
 360 #endif
 361       energia(4)=ecorr
 362       energia(5)=ecorr5
 363       energia(6)=ecorr6
 364       energia(7)=eel_loc
 365       energia(8)=eello_turn3
 366       energia(9)=eello_turn4
 367       energia(10)=eturn6
 368       energia(11)=ebe
 369       energia(12)=escloc
 370       energia(13)=etors
 371       energia(14)=etors_d
 372       energia(15)=ehpb
 373       energia(19)=edihcnstr
 374       energia(17)=estr
 375       energia(20)=Uconst+Uconst_back
 376       energia(21)=esccor
 377       energia(22)=evdw_p
 378       energia(23)=evdw_m
 379       energia(24)=ehomology_constr
 380       energia(25)=edfadis
 381       energia(26)=edfator
 382       energia(27)=edfanei
 383       energia(28)=edfabet
 384 c      print *," Processor",myrank," calls SUM_ENERGY"
 385       call sum_energy(energia,.true.)
 386       if (dyn_ss) call dyn_set_nss
 387 c      print *," Processor",myrank," left SUM_ENERGY"
 388 #ifdef TIMING
 389 #ifdef MPI
 390       time_sumene=time_sumene+MPI_Wtime()-time00
 391 #else
 392       time_sumene=time_sumene+tcpu()-time00
 393 #endif
 394 #endif
 395       return
 396       end
 397 c-------------------------------------------------------------------------------
 398       subroutine sum_energy(energia,reduce)
 399       implicit real*8 (a-h,o-z)
 400       include 'DIMENSIONS'
 401 #ifndef ISNAN
 402       external proc_proc
 403 #ifdef WINPGI
 404 cMS$ATTRIBUTES C ::  proc_proc
 405 #endif
 406 #endif
 407 #ifdef MPI
 408       include "mpif.h"
 409 #endif
 410       include 'COMMON.SETUP'
 411       include 'COMMON.IOUNITS'
 412       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 413       include 'COMMON.FFIELD'
 414       include 'COMMON.DERIV'
 415       include 'COMMON.INTERACT'
 416       include 'COMMON.SBRIDGE'
 417       include 'COMMON.CHAIN'
 418       include 'COMMON.VAR'
 419       include 'COMMON.CONTROL'
 420       include 'COMMON.TIME1'
 421       logical reduce
 422 #ifdef MPI
 423       if (nfgtasks.gt.1 .and. reduce) then
 424 #ifdef DEBUG
 425         write (iout,*) "energies before REDUCE"
 426         call enerprint(energia)
 427         call flush(iout)
 428 #endif
 429         do i=0,n_ene
 430           enebuff(i)=energia(i)
 431         enddo
 432         time00=MPI_Wtime()
 433         call MPI_Barrier(FG_COMM,IERR)
 434         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 435         time00=MPI_Wtime()
 436         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 437      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 438 #ifdef DEBUG
 439         write (iout,*) "energies after REDUCE"
 440         call enerprint(energia)
 441         call flush(iout)
 442 #endif
 443         time_Reduce=time_Reduce+MPI_Wtime()-time00
 444       endif
 445       if (fg_rank.eq.0) then
 446 #endif
 447 #ifdef TSCSC
 448       evdw=energia(22)+wsct*energia(23)
 449 #else
 450       evdw=energia(1)
 451 #endif
 452 #ifdef SCP14
 453       evdw2=energia(2)+energia(18)
 454       evdw2_14=energia(18)
 455 #else
 456       evdw2=energia(2)
 457 #endif
 458 #ifdef SPLITELE
 459       ees=energia(3)
 460       evdw1=energia(16)
 461 #else
 462       ees=energia(3)
 463       evdw1=0.0d0
 464 #endif
 465       ecorr=energia(4)
 466       ecorr5=energia(5)
 467       ecorr6=energia(6)
 468       eel_loc=energia(7)
 469       eello_turn3=energia(8)
 470       eello_turn4=energia(9)
 471       eturn6=energia(10)
 472       ebe=energia(11)
 473       escloc=energia(12)
 474       etors=energia(13)
 475       etors_d=energia(14)
 476       ehpb=energia(15)
 477       edihcnstr=energia(19)
 478       estr=energia(17)
 479       Uconst=energia(20)
 480       esccor=energia(21)
 481       ehomology_constr=energia(24)
 482       edfadis=energia(25)
 483       edfator=energia(26)
 484       edfanei=energia(27)
 485       edfabet=energia(28)
 486 #ifdef SPLITELE
 487       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 488      & +wang*ebe+wtor*etors+wscloc*escloc
 489      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 490      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 491      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 492      & +wbond*estr+Uconst+wsccor*esccor+ehomology_constr
 493      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 494      & +wdfa_beta*edfabet
 495 #else
 496       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 497      & +wang*ebe+wtor*etors+wscloc*escloc
 498      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 499      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 500      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 501      & +wbond*estr+Uconst+wsccor*esccor+ehomology_constr
 502      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 503      & +wdfa_beta*edfabet
 504 #endif
 505       energia(0)=etot
 506 c detecting NaNQ
 507 #ifdef ISNAN
 508 #ifdef AIX
 509       if (isnan(etot).ne.0) energia(0)=1.0d+99
 510 #else
 511       if (isnan(etot)) energia(0)=1.0d+99
 512 #endif
 513 #else
 514       i=0
 515 #ifdef WINPGI
 516       idumm=proc_proc(etot,i)
 517 #else
 518       call proc_proc(etot,i)
 519 #endif
 520       if(i.eq.1)energia(0)=1.0d+99
 521 #endif
 522 #ifdef MPI
 523       endif
 524 #endif
 525       return
 526       end
 527 c-------------------------------------------------------------------------------
 528       subroutine sum_gradient
 529       implicit real*8 (a-h,o-z)
 530       include 'DIMENSIONS'
 531 #ifndef ISNAN
 532       external proc_proc
 533 #ifdef WINPGI
 534 cMS$ATTRIBUTES C ::  proc_proc
 535 #endif
 536 #endif
 537 #ifdef MPI
 538       include 'mpif.h'
 539 #endif
 540       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 541      &  glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres)
 542       include 'COMMON.SETUP'
 543       include 'COMMON.IOUNITS'
 544       include 'COMMON.FFIELD'
 545       include 'COMMON.DERIV'
 546       include 'COMMON.INTERACT'
 547       include 'COMMON.SBRIDGE'
 548       include 'COMMON.CHAIN'
 549       include 'COMMON.VAR'
 550       include 'COMMON.CONTROL'
 551       include 'COMMON.TIME1'
 552       include 'COMMON.MAXGRAD'
 553       include 'COMMON.SCCOR'
 554       include 'COMMON.MD'
 555 #ifdef TIMING
 556 #ifdef MPI
 557       time01=MPI_Wtime()
 558 #else
 559       time01=tcpu()
 560 #endif
 561 #endif
 562 #ifdef DEBUG
 563       write (iout,*) "sum_gradient gvdwc, gvdwx"
 564       do i=1,nres
 565         write (iout,'(i3,3f10.5,5x,3f10.5,5x,3f10.5,5x,3f10.5)')
 566      &   i,(gvdwx(j,i),j=1,3),(gvdwcT(j,i),j=1,3),(gvdwc(j,i),j=1,3),
 567      &   (gvdwcT(j,i),j=1,3)
 568       enddo
 569       call flush(iout)
 570 #endif
 571 #ifdef MPI
 572 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 573         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 574      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 575 #endif
 576 C
 577 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 578 C            in virtual-bond-vector coordinates
 579 C
 580 #ifdef DEBUG
 581 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 582 c      do i=1,nres-1
 583 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 584 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 585 c      enddo
 586 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 587 c      do i=1,nres-1
 588 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 589 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 590 c      enddo
 591       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 592       do i=1,nres
 593         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 594      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 595      &   g_corr5_loc(i)
 596       enddo
 597       call flush(iout)
 598 #endif
 599 #ifdef SPLITELE
 600 #ifdef TSCSC
 601       do i=1,nct
 602         do j=1,3
 603           gradbufc(j,i)=wsc*gvdwc(j,i)+wsc*wscT*gvdwcT(j,i)+
 604      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 605      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 606      &                wel_loc*gel_loc_long(j,i)+
 607      &                wcorr*gradcorr_long(j,i)+
 608      &                wcorr5*gradcorr5_long(j,i)+
 609      &                wcorr6*gradcorr6_long(j,i)+
 610      &                wturn6*gcorr6_turn_long(j,i)+
 611      &                wstrain*ghpbc(j,i)+
 612      &                wdfa_dist*gdfad(j,i)+
 613      &                wdfa_tor*gdfat(j,i)+
 614      &                wdfa_nei*gdfan(j,i)+
 615      &                wdfa_beta*gdfab(j,i)
 616         enddo
 617       enddo
 618 #else
 619       do i=1,nct
 620         do j=1,3
 621           gradbufc(j,i)=wsc*gvdwc(j,i)+
 622      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 623      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 624      &                wel_loc*gel_loc_long(j,i)+
 625      &                wcorr*gradcorr_long(j,i)+
 626      &                wcorr5*gradcorr5_long(j,i)+
 627      &                wcorr6*gradcorr6_long(j,i)+
 628      &                wturn6*gcorr6_turn_long(j,i)+
 629      &                wstrain*ghpbc(j,i)+
 630      &                wdfa_dist*gdfad(j,i)+
 631      &                wdfa_tor*gdfat(j,i)+
 632      &                wdfa_nei*gdfan(j,i)+
 633      &                wdfa_beta*gdfab(j,i)
 634         enddo
 635       enddo
 636 #endif
 637 #else
 638       do i=1,nct
 639         do j=1,3
 640           gradbufc(j,i)=wsc*gvdwc(j,i)+
 641      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 642      &                welec*gelc_long(j,i)+
 643      &                wbond*gradb(j,i)+
 644      &                wel_loc*gel_loc_long(j,i)+
 645      &                wcorr*gradcorr_long(j,i)+
 646      &                wcorr5*gradcorr5_long(j,i)+
 647      &                wcorr6*gradcorr6_long(j,i)+
 648      &                wturn6*gcorr6_turn_long(j,i)+
 649      &                wstrain*ghpbc(j,i)+
 650      &                wdfa_dist*gdfad(j,i)+
 651      &                wdfa_tor*gdfat(j,i)+
 652      &                wdfa_nei*gdfan(j,i)+
 653      &                wdfa_beta*gdfab(j,i)
 654         enddo
 655       enddo
 656 #endif
 657 #ifdef MPI
 658       if (nfgtasks.gt.1) then
 659       time00=MPI_Wtime()
 660 #ifdef DEBUG
 661       write (iout,*) "gradbufc before allreduce"
 662       do i=1,nres
 663         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 664       enddo
 665       call flush(iout)
 666 #endif
 667       do i=1,nres
 668         do j=1,3
 669           gradbufc_sum(j,i)=gradbufc(j,i)
 670         enddo
 671       enddo
 672 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 673 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 674 c      time_reduce=time_reduce+MPI_Wtime()-time00
 675 #ifdef DEBUG
 676 c      write (iout,*) "gradbufc_sum after allreduce"
 677 c      do i=1,nres
 678 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 679 c      enddo
 680 c      call flush(iout)
 681 #endif
 682 #ifdef TIMING
 683 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 684 #endif
 685       do i=nnt,nres
 686         do k=1,3
 687           gradbufc(k,i)=0.0d0
 688         enddo
 689       enddo
 690 #ifdef DEBUG
 691       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 692       write (iout,*) (i," jgrad_start",jgrad_start(i),
 693      &                  " jgrad_end  ",jgrad_end(i),
 694      &                  i=igrad_start,igrad_end)
 695 #endif
 696 c
 697 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 698 c do not parallelize this part.
 699 c
 700 c      do i=igrad_start,igrad_end
 701 c        do j=jgrad_start(i),jgrad_end(i)
 702 c          do k=1,3
 703 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 704 c          enddo
 705 c        enddo
 706 c      enddo
 707       do j=1,3
 708         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 709       enddo
 710       do i=nres-2,nnt,-1
 711         do j=1,3
 712           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 713         enddo
 714       enddo
 715 #ifdef DEBUG
 716       write (iout,*) "gradbufc after summing"
 717       do i=1,nres
 718         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 719       enddo
 720       call flush(iout)
 721 #endif
 722       else
 723 #endif
 724 #ifdef DEBUG
 725       write (iout,*) "gradbufc"
 726       do i=1,nres
 727         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 728       enddo
 729       call flush(iout)
 730 #endif
 731       do i=1,nres
 732         do j=1,3
 733           gradbufc_sum(j,i)=gradbufc(j,i)
 734           gradbufc(j,i)=0.0d0
 735         enddo
 736       enddo
 737       do j=1,3
 738         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 739       enddo
 740       do i=nres-2,nnt,-1
 741         do j=1,3
 742           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 743         enddo
 744       enddo
 745 c      do i=nnt,nres-1
 746 c        do k=1,3
 747 c          gradbufc(k,i)=0.0d0
 748 c        enddo
 749 c        do j=i+1,nres
 750 c          do k=1,3
 751 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 752 c          enddo
 753 c        enddo
 754 c      enddo
 755 #ifdef DEBUG
 756       write (iout,*) "gradbufc after summing"
 757       do i=1,nres
 758         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 759       enddo
 760       call flush(iout)
 761 #endif
 762 #ifdef MPI
 763       endif
 764 #endif
 765       do k=1,3
 766         gradbufc(k,nres)=0.0d0
 767       enddo
 768       do i=1,nct
 769         do j=1,3
 770 #ifdef SPLITELE
 771           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 772      &                wel_loc*gel_loc(j,i)+
 773      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 774      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 775      &                wel_loc*gel_loc_long(j,i)+
 776      &                wcorr*gradcorr_long(j,i)+
 777      &                wcorr5*gradcorr5_long(j,i)+
 778      &                wcorr6*gradcorr6_long(j,i)+
 779      &                wturn6*gcorr6_turn_long(j,i))+
 780      &                wbond*gradb(j,i)+
 781      &                wcorr*gradcorr(j,i)+
 782      &                wturn3*gcorr3_turn(j,i)+
 783      &                wturn4*gcorr4_turn(j,i)+
 784      &                wcorr5*gradcorr5(j,i)+
 785      &                wcorr6*gradcorr6(j,i)+
 786      &                wturn6*gcorr6_turn(j,i)+
 787      &                wsccor*gsccorc(j,i)
 788      &               +wscloc*gscloc(j,i)
 789 #else
 790           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 791      &                wel_loc*gel_loc(j,i)+
 792      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 793      &                welec*gelc_long(j,i)+
 794      &                wel_loc*gel_loc_long(j,i)+
 795      &                wcorr*gcorr_long(j,i)+
 796      &                wcorr5*gradcorr5_long(j,i)+
 797      &                wcorr6*gradcorr6_long(j,i)+
 798      &                wturn6*gcorr6_turn_long(j,i))+
 799      &                wbond*gradb(j,i)+
 800      &                wcorr*gradcorr(j,i)+
 801      &                wturn3*gcorr3_turn(j,i)+
 802      &                wturn4*gcorr4_turn(j,i)+
 803      &                wcorr5*gradcorr5(j,i)+
 804      &                wcorr6*gradcorr6(j,i)+
 805      &                wturn6*gcorr6_turn(j,i)+
 806      &                wsccor*gsccorc(j,i)
 807      &               +wscloc*gscloc(j,i)
 808 #endif
 809 #ifdef TSCSC
 810           gradx(j,i,icg)=wsc*gvdwx(j,i)+wsc*wscT*gvdwxT(j,i)+
 811      &                  wscp*gradx_scp(j,i)+
 812      &                  wbond*gradbx(j,i)+
 813      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 814      &                  wsccor*gsccorx(j,i)
 815      &                 +wscloc*gsclocx(j,i)
 816 #else
 817           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 818      &                  wbond*gradbx(j,i)+
 819      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 820      &                  wsccor*gsccorx(j,i)
 821      &                 +wscloc*gsclocx(j,i)
 822 #endif
 823         enddo
 824       enddo
 825       if (constr_homology.gt.0.and.waga_homology(iset).ne.0d0) then
 826         do i=1,nct
 827           do j=1,3
 828             gradc(j,i,icg)=gradc(j,i,icg)+duscdiff(j,i)
 829             gradx(j,i,icg)=gradx(j,i,icg)+duscdiffx(j,i)
 830           enddo
 831         enddo
 832       endif
 833 #ifdef DEBUG
 834       write (iout,*) "gloc before adding corr"
 835       do i=1,4*nres
 836         write (iout,*) i,gloc(i,icg)
 837       enddo
 838 #endif
 839       do i=1,nres-3
 840         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 841      &   +wcorr5*g_corr5_loc(i)
 842      &   +wcorr6*g_corr6_loc(i)
 843      &   +wturn4*gel_loc_turn4(i)
 844      &   +wturn3*gel_loc_turn3(i)
 845      &   +wturn6*gel_loc_turn6(i)
 846      &   +wel_loc*gel_loc_loc(i)
 847       enddo
 848 #ifdef DEBUG
 849       write (iout,*) "gloc after adding corr"
 850       do i=1,4*nres
 851         write (iout,*) i,gloc(i,icg)
 852       enddo
 853 #endif
 854 #ifdef MPI
 855       if (nfgtasks.gt.1) then
 856         do j=1,3
 857           do i=1,nres
 858             gradbufc(j,i)=gradc(j,i,icg)
 859             gradbufx(j,i)=gradx(j,i,icg)
 860           enddo
 861         enddo
 862         do i=1,4*nres
 863           glocbuf(i)=gloc(i,icg)
 864         enddo
 865 #ifdef DEBUG
 866       write (iout,*) "gloc_sc before reduce"
 867       do i=1,nres
 868        do j=1,3
 869         write (iout,*) i,j,gloc_sc(j,i,icg)
 870        enddo
 871       enddo
 872 #endif
 873         do i=1,nres
 874          do j=1,3
 875           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 876          enddo
 877         enddo
 878         time00=MPI_Wtime()
 879         call MPI_Barrier(FG_COMM,IERR)
 880         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 881         time00=MPI_Wtime()
 882         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 883      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 884         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 885      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 886         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 887      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 888         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 889      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 890         time_reduce=time_reduce+MPI_Wtime()-time00
 891 #ifdef DEBUG
 892       write (iout,*) "gloc_sc after reduce"
 893       do i=1,nres
 894        do j=1,3
 895         write (iout,*) i,j,gloc_sc(j,i,icg)
 896        enddo
 897       enddo
 898 #endif
 899 #ifdef DEBUG
 900       write (iout,*) "gloc after reduce"
 901       do i=1,4*nres
 902         write (iout,*) i,gloc(i,icg)
 903       enddo
 904 #endif
 905       endif
 906 #endif
 907       if (gnorm_check) then
 908 c
 909 c Compute the maximum elements of the gradient
 910 c
 911       gvdwc_max=0.0d0
 912       gvdwc_scp_max=0.0d0
 913       gelc_max=0.0d0
 914       gvdwpp_max=0.0d0
 915       gradb_max=0.0d0
 916       ghpbc_max=0.0d0
 917       gradcorr_max=0.0d0
 918       gel_loc_max=0.0d0
 919       gcorr3_turn_max=0.0d0
 920       gcorr4_turn_max=0.0d0
 921       gradcorr5_max=0.0d0
 922       gradcorr6_max=0.0d0
 923       gcorr6_turn_max=0.0d0
 924       gsccorc_max=0.0d0
 925       gscloc_max=0.0d0
 926       gvdwx_max=0.0d0
 927       gradx_scp_max=0.0d0
 928       ghpbx_max=0.0d0
 929       gradxorr_max=0.0d0
 930       gsccorx_max=0.0d0
 931       gsclocx_max=0.0d0
 932       do i=1,nct
 933         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 934         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 935 #ifdef TSCSC
 936         gvdwc_norm=dsqrt(scalar(gvdwcT(1,i),gvdwcT(1,i)))
 937         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 938 #endif
 939         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 940         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 941      &   gvdwc_scp_max=gvdwc_scp_norm
 942         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 943         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 944         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 945         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 946         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 947         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 948         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 949         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 950         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 951         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 952         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 953         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 954         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 955      &    gcorr3_turn(1,i)))
 956         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 957      &    gcorr3_turn_max=gcorr3_turn_norm
 958         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 959      &    gcorr4_turn(1,i)))
 960         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 961      &    gcorr4_turn_max=gcorr4_turn_norm
 962         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 963         if (gradcorr5_norm.gt.gradcorr5_max)
 964      &    gradcorr5_max=gradcorr5_norm
 965         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 966         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 967         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 968      &    gcorr6_turn(1,i)))
 969         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 970      &    gcorr6_turn_max=gcorr6_turn_norm
 971         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 972         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 973         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 974         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 975         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 976         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 977 #ifdef TSCSC
 978         gvdwx_norm=dsqrt(scalar(gvdwxT(1,i),gvdwxT(1,i)))
 979         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 980 #endif
 981         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 982         if (gradx_scp_norm.gt.gradx_scp_max)
 983      &    gradx_scp_max=gradx_scp_norm
 984         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 985         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 986         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 987         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 988         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 989         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 990         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 991         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 992       enddo
 993       if (gradout) then
 994 #ifdef AIX
 995         open(istat,file=statname,position="append")
 996 #else
 997         open(istat,file=statname,access="append")
 998 #endif
 999         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
1000      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
1001      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
1002      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
1003      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
1004      &     gsccorx_max,gsclocx_max
1005         close(istat)
1006         if (gvdwc_max.gt.1.0d4) then
1007           write (iout,*) "gvdwc gvdwx gradb gradbx"
1008           do i=nnt,nct
1009             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
1010      &        gradb(j,i),gradbx(j,i),j=1,3)
1011           enddo
1012           call pdbout(0.0d0,'cipiszcze',iout)
1013           call flush(iout)
1014         endif
1015       endif
1016       endif
1017 #ifdef DEBUG
1018       write (iout,*) "gradc gradx gloc"
1019       do i=1,nres
1020         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
1021      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
1022       enddo
1023 #endif
1024 #ifdef TIMING
1025 #ifdef MPI
1026       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
1027 #else
1028       time_sumgradient=time_sumgradient+tcpu()-time01
1029 #endif
1030 #endif
1031       return
1032       end
1033 c-------------------------------------------------------------------------------
1034       subroutine rescale_weights(t_bath)
1035       implicit real*8 (a-h,o-z)
1036       include 'DIMENSIONS'
1037       include 'COMMON.IOUNITS'
1038       include 'COMMON.FFIELD'
1039       include 'COMMON.SBRIDGE'
1040       double precision kfac /2.4d0/
1041       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
1042 c      facT=temp0/t_bath
1043 c      facT=2*temp0/(t_bath+temp0)
1044       if (rescale_mode.eq.0) then
1045         facT=1.0d0
1046         facT2=1.0d0
1047         facT3=1.0d0
1048         facT4=1.0d0
1049         facT5=1.0d0
1050       else if (rescale_mode.eq.1) then
1051         facT=kfac/(kfac-1.0d0+t_bath/temp0)
1052         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1053         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1054         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1055         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1056       else if (rescale_mode.eq.2) then
1057         x=t_bath/temp0
1058         x2=x*x
1059         x3=x2*x
1060         x4=x3*x
1061         x5=x4*x
1062         facT=licznik/dlog(dexp(x)+dexp(-x))
1063         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
1064         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
1065         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
1066         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
1067       else
1068         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1069         write (*,*) "Wrong RESCALE_MODE",rescale_mode
1070 #ifdef MPI
1071        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1072 #endif
1073        stop 555
1074       endif
1075       welec=weights(3)*fact
1076       wcorr=weights(4)*fact3
1077       wcorr5=weights(5)*fact4
1078       wcorr6=weights(6)*fact5
1079       wel_loc=weights(7)*fact2
1080       wturn3=weights(8)*fact2
1081       wturn4=weights(9)*fact3
1082       wturn6=weights(10)*fact5
1083       wtor=weights(13)*fact
1084       wtor_d=weights(14)*fact2
1085       wsccor=weights(21)*fact
1086 #ifdef TSCSC
1087 c      wsct=t_bath/temp0
1088       wsct=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
1089 #endif
1090       return
1091       end
1092 C------------------------------------------------------------------------
1093       subroutine enerprint(energia)
1094       implicit real*8 (a-h,o-z)
1095       include 'DIMENSIONS'
1096       include 'COMMON.IOUNITS'
1097       include 'COMMON.FFIELD'
1098       include 'COMMON.SBRIDGE'
1099       include 'COMMON.MD'
1100       double precision energia(0:n_ene)
1101       etot=energia(0)
1102 #ifdef TSCSC
1103       evdw=energia(22)+wsct*energia(23)
1104 #else
1105       evdw=energia(1)
1106 #endif
1107       evdw2=energia(2)
1108 #ifdef SCP14
1109       evdw2=energia(2)+energia(18)
1110 #else
1111       evdw2=energia(2)
1112 #endif
1113       ees=energia(3)
1114 #ifdef SPLITELE
1115       evdw1=energia(16)
1116 #endif
1117       ecorr=energia(4)
1118       ecorr5=energia(5)
1119       ecorr6=energia(6)
1120       eel_loc=energia(7)
1121       eello_turn3=energia(8)
1122       eello_turn4=energia(9)
1123       eello_turn6=energia(10)
1124       ebe=energia(11)
1125       escloc=energia(12)
1126       etors=energia(13)
1127       etors_d=energia(14)
1128       ehpb=energia(15)
1129       edihcnstr=energia(19)
1130       estr=energia(17)
1131       Uconst=energia(20)
1132       esccor=energia(21)
1133       ehomology_constr=energia(24)
1134 C     Bartek
1135       edfadis = energia(25)
1136       edfator = energia(26)
1137       edfanei = energia(27)
1138       edfabet = energia(28)
1139
1140 #ifdef SPLITELE
1141       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1142      &  estr,wbond,ebe,wang,
1143      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1144      &  ecorr,wcorr,
1145      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1146      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
1147      &  edihcnstr,ehomology_constr, ebr*nss,
1148      &  Uconst,edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
1149      &  edfabet,wdfa_beta,etot
1150    10 format (/'Virtual-chain energies:'//
1151      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
1152      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
1153      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
1154      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pE16.6,' (p-p VDW)'/
1155      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
1156      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
1157      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
1158      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
1159      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
1160      & 'EHPB=  ',1pE16.6,' WEIGHT=',1pE16.6,
1161      & ' (SS bridges & dist. cnstr.)'/
1162      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1163      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1164      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1165      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
1166      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
1167      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
1168      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
1169      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
1170      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1171      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1172      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1173      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1174      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
1175      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
1176      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
1177      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
1178      & 'ETOT=  ',1pE16.6,' (total)')
1179 #else
1180       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1181      &  estr,wbond,ebe,wang,
1182      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1183      &  ecorr,wcorr,
1184      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1185      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1186      &  ehomology_constr,ebr*nss,Uconst,edfadis,wdfa_dist,edfator,
1187      &  wdfa_tor,edfanei,wdfa_nei,edfabet,wdfa_beta,
1188      &  etot
1189    10 format (/'Virtual-chain energies:'//
1190      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1191      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1192      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1193      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1194      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1195      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1196      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1197      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1198      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1199      & ' (SS bridges & dist. cnstr.)'/
1200      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1201      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1202      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1203      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1204      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1205      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1206      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1207      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1208      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1209      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1210      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1211      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1212      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA distance energy)'/
1213      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA torsion energy)'/
1214      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA NCa energy)'/
1215      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA Beta energy)'/
1216      & 'ETOT=  ',1pE16.6,' (total)')
1217 #endif
1218       return
1219       end
1220 C-----------------------------------------------------------------------
1221       subroutine elj(evdw,evdw_p,evdw_m)
1222 C
1223 C This subroutine calculates the interaction energy of nonbonded side chains
1224 C assuming the LJ potential of interaction.
1225 C
1226       implicit real*8 (a-h,o-z)
1227       include 'DIMENSIONS'
1228       parameter (accur=1.0d-10)
1229       include 'COMMON.GEO'
1230       include 'COMMON.VAR'
1231       include 'COMMON.LOCAL'
1232       include 'COMMON.CHAIN'
1233       include 'COMMON.DERIV'
1234       include 'COMMON.INTERACT'
1235       include 'COMMON.TORSION'
1236       include 'COMMON.SBRIDGE'
1237       include 'COMMON.NAMES'
1238       include 'COMMON.IOUNITS'
1239       include 'COMMON.CONTACTS'
1240       dimension gg(3)
1241 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1242       evdw=0.0D0
1243       do i=iatsc_s,iatsc_e
1244         itypi=itype(i)
1245         itypi1=itype(i+1)
1246         xi=c(1,nres+i)
1247         yi=c(2,nres+i)
1248         zi=c(3,nres+i)
1249 C Change 12/1/95
1250         num_conti=0
1251 C
1252 C Calculate SC interaction energy.
1253 C
1254         do iint=1,nint_gr(i)
1255 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1256 cd   &                  'iend=',iend(i,iint)
1257           do j=istart(i,iint),iend(i,iint)
1258             itypj=itype(j)
1259             xj=c(1,nres+j)-xi
1260             yj=c(2,nres+j)-yi
1261             zj=c(3,nres+j)-zi
1262 C Change 12/1/95 to calculate four-body interactions
1263             rij=xj*xj+yj*yj+zj*zj
1264             rrij=1.0D0/rij
1265 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1266             eps0ij=eps(itypi,itypj)
1267             fac=rrij**expon2
1268             e1=fac*fac*aa(itypi,itypj)
1269             e2=fac*bb(itypi,itypj)
1270             evdwij=e1+e2
1271 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1272 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1273 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1274 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1275 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1276 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1277 #ifdef TSCSC
1278             if (bb(itypi,itypj).gt.0) then
1279                evdw_p=evdw_p+evdwij
1280             else
1281                evdw_m=evdw_m+evdwij
1282             endif
1283 #else
1284             evdw=evdw+evdwij
1285 #endif
1286 C
1287 C Calculate the components of the gradient in DC and X
1288 C
1289             fac=-rrij*(e1+evdwij)
1290             gg(1)=xj*fac
1291             gg(2)=yj*fac
1292             gg(3)=zj*fac
1293 #ifdef TSCSC
1294             if (bb(itypi,itypj).gt.0.0d0) then
1295               do k=1,3
1296                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1297                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1298                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1299                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1300               enddo
1301             else
1302               do k=1,3
1303                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1304                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1305                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1306                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1307               enddo
1308             endif
1309 #else
1310             do k=1,3
1311               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1312               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1313               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1314               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1315             enddo
1316 #endif
1317 cgrad            do k=i,j-1
1318 cgrad              do l=1,3
1319 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1320 cgrad              enddo
1321 cgrad            enddo
1322 C
1323 C 12/1/95, revised on 5/20/97
1324 C
1325 C Calculate the contact function. The ith column of the array JCONT will
1326 C contain the numbers of atoms that make contacts with the atom I (of numbers
1327 C greater than I). The arrays FACONT and GACONT will contain the values of
1328 C the contact function and its derivative.
1329 C
1330 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1331 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1332 C Uncomment next line, if the correlation interactions are contact function only
1333             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1334               rij=dsqrt(rij)
1335               sigij=sigma(itypi,itypj)
1336               r0ij=rs0(itypi,itypj)
1337 C
1338 C Check whether the SC's are not too far to make a contact.
1339 C
1340               rcut=1.5d0*r0ij
1341               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1342 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1343 C
1344               if (fcont.gt.0.0D0) then
1345 C If the SC-SC distance if close to sigma, apply spline.
1346 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1347 cAdam &             fcont1,fprimcont1)
1348 cAdam           fcont1=1.0d0-fcont1
1349 cAdam           if (fcont1.gt.0.0d0) then
1350 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1351 cAdam             fcont=fcont*fcont1
1352 cAdam           endif
1353 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1354 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1355 cga             do k=1,3
1356 cga               gg(k)=gg(k)*eps0ij
1357 cga             enddo
1358 cga             eps0ij=-evdwij*eps0ij
1359 C Uncomment for AL's type of SC correlation interactions.
1360 cadam           eps0ij=-evdwij
1361                 num_conti=num_conti+1
1362                 jcont(num_conti,i)=j
1363                 facont(num_conti,i)=fcont*eps0ij
1364                 fprimcont=eps0ij*fprimcont/rij
1365                 fcont=expon*fcont
1366 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1367 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1368 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1369 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1370                 gacont(1,num_conti,i)=-fprimcont*xj
1371                 gacont(2,num_conti,i)=-fprimcont*yj
1372                 gacont(3,num_conti,i)=-fprimcont*zj
1373 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1374 cd              write (iout,'(2i3,3f10.5)')
1375 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1376               endif
1377             endif
1378           enddo      ! j
1379         enddo        ! iint
1380 C Change 12/1/95
1381         num_cont(i)=num_conti
1382       enddo          ! i
1383       do i=1,nct
1384         do j=1,3
1385           gvdwc(j,i)=expon*gvdwc(j,i)
1386           gvdwx(j,i)=expon*gvdwx(j,i)
1387         enddo
1388       enddo
1389 C******************************************************************************
1390 C
1391 C                              N O T E !!!
1392 C
1393 C To save time, the factor of EXPON has been extracted from ALL components
1394 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1395 C use!
1396 C
1397 C******************************************************************************
1398       return
1399       end
1400 C-----------------------------------------------------------------------------
1401       subroutine eljk(evdw,evdw_p,evdw_m)
1402 C
1403 C This subroutine calculates the interaction energy of nonbonded side chains
1404 C assuming the LJK potential of interaction.
1405 C
1406       implicit real*8 (a-h,o-z)
1407       include 'DIMENSIONS'
1408       include 'COMMON.GEO'
1409       include 'COMMON.VAR'
1410       include 'COMMON.LOCAL'
1411       include 'COMMON.CHAIN'
1412       include 'COMMON.DERIV'
1413       include 'COMMON.INTERACT'
1414       include 'COMMON.IOUNITS'
1415       include 'COMMON.NAMES'
1416       dimension gg(3)
1417       logical scheck
1418 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1419       evdw=0.0D0
1420       do i=iatsc_s,iatsc_e
1421         itypi=itype(i)
1422         itypi1=itype(i+1)
1423         xi=c(1,nres+i)
1424         yi=c(2,nres+i)
1425         zi=c(3,nres+i)
1426 C
1427 C Calculate SC interaction energy.
1428 C
1429         do iint=1,nint_gr(i)
1430           do j=istart(i,iint),iend(i,iint)
1431             itypj=itype(j)
1432             xj=c(1,nres+j)-xi
1433             yj=c(2,nres+j)-yi
1434             zj=c(3,nres+j)-zi
1435             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1436             fac_augm=rrij**expon
1437             e_augm=augm(itypi,itypj)*fac_augm
1438             r_inv_ij=dsqrt(rrij)
1439             rij=1.0D0/r_inv_ij
1440             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1441             fac=r_shift_inv**expon
1442             e1=fac*fac*aa(itypi,itypj)
1443             e2=fac*bb(itypi,itypj)
1444             evdwij=e_augm+e1+e2
1445 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1446 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1447 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1448 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1449 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1450 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1451 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1452 #ifdef TSCSC
1453             if (bb(itypi,itypj).gt.0) then
1454                evdw_p=evdw_p+evdwij
1455             else
1456                evdw_m=evdw_m+evdwij
1457             endif
1458 #else
1459             evdw=evdw+evdwij
1460 #endif
1461 C
1462 C Calculate the components of the gradient in DC and X
1463 C
1464             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1465             gg(1)=xj*fac
1466             gg(2)=yj*fac
1467             gg(3)=zj*fac
1468 #ifdef TSCSC
1469             if (bb(itypi,itypj).gt.0.0d0) then
1470               do k=1,3
1471                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1472                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1473                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1474                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1475               enddo
1476             else
1477               do k=1,3
1478                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1479                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1480                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1481                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1482               enddo
1483             endif
1484 #else
1485             do k=1,3
1486               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1487               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1488               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1489               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1490             enddo
1491 #endif
1492 cgrad            do k=i,j-1
1493 cgrad              do l=1,3
1494 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1495 cgrad              enddo
1496 cgrad            enddo
1497           enddo      ! j
1498         enddo        ! iint
1499       enddo          ! i
1500       do i=1,nct
1501         do j=1,3
1502           gvdwc(j,i)=expon*gvdwc(j,i)
1503           gvdwx(j,i)=expon*gvdwx(j,i)
1504         enddo
1505       enddo
1506       return
1507       end
1508 C-----------------------------------------------------------------------------
1509       subroutine ebp(evdw,evdw_p,evdw_m)
1510 C
1511 C This subroutine calculates the interaction energy of nonbonded side chains
1512 C assuming the Berne-Pechukas potential of interaction.
1513 C
1514       implicit real*8 (a-h,o-z)
1515       include 'DIMENSIONS'
1516       include 'COMMON.GEO'
1517       include 'COMMON.VAR'
1518       include 'COMMON.LOCAL'
1519       include 'COMMON.CHAIN'
1520       include 'COMMON.DERIV'
1521       include 'COMMON.NAMES'
1522       include 'COMMON.INTERACT'
1523       include 'COMMON.IOUNITS'
1524       include 'COMMON.CALC'
1525       common /srutu/ icall
1526 c     double precision rrsave(maxdim)
1527       logical lprn
1528       evdw=0.0D0
1529 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1530       evdw=0.0D0
1531 c     if (icall.eq.0) then
1532 c       lprn=.true.
1533 c     else
1534         lprn=.false.
1535 c     endif
1536       ind=0
1537       do i=iatsc_s,iatsc_e
1538         itypi=itype(i)
1539         itypi1=itype(i+1)
1540         xi=c(1,nres+i)
1541         yi=c(2,nres+i)
1542         zi=c(3,nres+i)
1543         dxi=dc_norm(1,nres+i)
1544         dyi=dc_norm(2,nres+i)
1545         dzi=dc_norm(3,nres+i)
1546 c        dsci_inv=dsc_inv(itypi)
1547         dsci_inv=vbld_inv(i+nres)
1548 C
1549 C Calculate SC interaction energy.
1550 C
1551         do iint=1,nint_gr(i)
1552           do j=istart(i,iint),iend(i,iint)
1553             ind=ind+1
1554             itypj=itype(j)
1555 c            dscj_inv=dsc_inv(itypj)
1556             dscj_inv=vbld_inv(j+nres)
1557             chi1=chi(itypi,itypj)
1558             chi2=chi(itypj,itypi)
1559             chi12=chi1*chi2
1560             chip1=chip(itypi)
1561             chip2=chip(itypj)
1562             chip12=chip1*chip2
1563             alf1=alp(itypi)
1564             alf2=alp(itypj)
1565             alf12=0.5D0*(alf1+alf2)
1566 C For diagnostics only!!!
1567 c           chi1=0.0D0
1568 c           chi2=0.0D0
1569 c           chi12=0.0D0
1570 c           chip1=0.0D0
1571 c           chip2=0.0D0
1572 c           chip12=0.0D0
1573 c           alf1=0.0D0
1574 c           alf2=0.0D0
1575 c           alf12=0.0D0
1576             xj=c(1,nres+j)-xi
1577             yj=c(2,nres+j)-yi
1578             zj=c(3,nres+j)-zi
1579             dxj=dc_norm(1,nres+j)
1580             dyj=dc_norm(2,nres+j)
1581             dzj=dc_norm(3,nres+j)
1582             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1583 cd          if (icall.eq.0) then
1584 cd            rrsave(ind)=rrij
1585 cd          else
1586 cd            rrij=rrsave(ind)
1587 cd          endif
1588             rij=dsqrt(rrij)
1589 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1590             call sc_angular
1591 C Calculate whole angle-dependent part of epsilon and contributions
1592 C to its derivatives
1593             fac=(rrij*sigsq)**expon2
1594             e1=fac*fac*aa(itypi,itypj)
1595             e2=fac*bb(itypi,itypj)
1596             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1597             eps2der=evdwij*eps3rt
1598             eps3der=evdwij*eps2rt
1599             evdwij=evdwij*eps2rt*eps3rt
1600 #ifdef TSCSC
1601             if (bb(itypi,itypj).gt.0) then
1602                evdw_p=evdw_p+evdwij
1603             else
1604                evdw_m=evdw_m+evdwij
1605             endif
1606 #else
1607             evdw=evdw+evdwij
1608 #endif
1609             if (lprn) then
1610             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1611             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1612 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1613 cd     &        restyp(itypi),i,restyp(itypj),j,
1614 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1615 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1616 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1617 cd     &        evdwij
1618             endif
1619 C Calculate gradient components.
1620             e1=e1*eps1*eps2rt**2*eps3rt**2
1621             fac=-expon*(e1+evdwij)
1622             sigder=fac/sigsq
1623             fac=rrij*fac
1624 C Calculate radial part of the gradient
1625             gg(1)=xj*fac
1626             gg(2)=yj*fac
1627             gg(3)=zj*fac
1628 C Calculate the angular part of the gradient and sum add the contributions
1629 C to the appropriate components of the Cartesian gradient.
1630 #ifdef TSCSC
1631             if (bb(itypi,itypj).gt.0) then
1632                call sc_grad
1633             else
1634                call sc_grad_T
1635             endif
1636 #else
1637             call sc_grad
1638 #endif
1639           enddo      ! j
1640         enddo        ! iint
1641       enddo          ! i
1642 c     stop
1643       return
1644       end
1645 C-----------------------------------------------------------------------------
1646       subroutine egb(evdw,evdw_p,evdw_m)
1647 C
1648 C This subroutine calculates the interaction energy of nonbonded side chains
1649 C assuming the Gay-Berne potential of interaction.
1650 C
1651       implicit real*8 (a-h,o-z)
1652       include 'DIMENSIONS'
1653       include 'COMMON.GEO'
1654       include 'COMMON.VAR'
1655       include 'COMMON.LOCAL'
1656       include 'COMMON.CHAIN'
1657       include 'COMMON.DERIV'
1658       include 'COMMON.NAMES'
1659       include 'COMMON.INTERACT'
1660       include 'COMMON.IOUNITS'
1661       include 'COMMON.CALC'
1662       include 'COMMON.CONTROL'
1663       include 'COMMON.SBRIDGE'
1664       logical lprn
1665       evdw=0.0D0
1666 ccccc      energy_dec=.false.
1667 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1668       evdw=0.0D0
1669       evdw_p=0.0D0
1670       evdw_m=0.0D0
1671       lprn=.false.
1672 c     if (icall.eq.0) lprn=.false.
1673       ind=0
1674       do i=iatsc_s,iatsc_e
1675         itypi=itype(i)
1676         itypi1=itype(i+1)
1677         xi=c(1,nres+i)
1678         yi=c(2,nres+i)
1679         zi=c(3,nres+i)
1680         dxi=dc_norm(1,nres+i)
1681         dyi=dc_norm(2,nres+i)
1682         dzi=dc_norm(3,nres+i)
1683 c        dsci_inv=dsc_inv(itypi)
1684         dsci_inv=vbld_inv(i+nres)
1685 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1686 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1687 C
1688 C Calculate SC interaction energy.
1689 C
1690         do iint=1,nint_gr(i)
1691           do j=istart(i,iint),iend(i,iint)
1692             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1693               call dyn_ssbond_ene(i,j,evdwij)
1694               evdw=evdw+evdwij
1695               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1696      &                        'evdw',i,j,evdwij,' ss'
1697             ELSE
1698             ind=ind+1
1699             itypj=itype(j)
1700 c            dscj_inv=dsc_inv(itypj)
1701             dscj_inv=vbld_inv(j+nres)
1702 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1703 c     &       1.0d0/vbld(j+nres)
1704 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1705             sig0ij=sigma(itypi,itypj)
1706             chi1=chi(itypi,itypj)
1707             chi2=chi(itypj,itypi)
1708             chi12=chi1*chi2
1709             chip1=chip(itypi)
1710             chip2=chip(itypj)
1711             chip12=chip1*chip2
1712             alf1=alp(itypi)
1713             alf2=alp(itypj)
1714             alf12=0.5D0*(alf1+alf2)
1715 C For diagnostics only!!!
1716 c           chi1=0.0D0
1717 c           chi2=0.0D0
1718 c           chi12=0.0D0
1719 c           chip1=0.0D0
1720 c           chip2=0.0D0
1721 c           chip12=0.0D0
1722 c           alf1=0.0D0
1723 c           alf2=0.0D0
1724 c           alf12=0.0D0
1725             xj=c(1,nres+j)-xi
1726             yj=c(2,nres+j)-yi
1727             zj=c(3,nres+j)-zi
1728             dxj=dc_norm(1,nres+j)
1729             dyj=dc_norm(2,nres+j)
1730             dzj=dc_norm(3,nres+j)
1731 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1732 c            write (iout,*) "j",j," dc_norm",
1733 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1734             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1735             rij=dsqrt(rrij)
1736 C Calculate angle-dependent terms of energy and contributions to their
1737 C derivatives.
1738             call sc_angular
1739             sigsq=1.0D0/sigsq
1740             sig=sig0ij*dsqrt(sigsq)
1741             rij_shift=1.0D0/rij-sig+sig0ij
1742 c for diagnostics; uncomment
1743 c            rij_shift=1.2*sig0ij
1744 C I hate to put IF's in the loops, but here don't have another choice!!!!
1745             if (rij_shift.le.0.0D0) then
1746               evdw=1.0D20
1747 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1748 cd     &        restyp(itypi),i,restyp(itypj),j,
1749 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1750               return
1751             endif
1752             sigder=-sig*sigsq
1753 c---------------------------------------------------------------
1754             rij_shift=1.0D0/rij_shift
1755             fac=rij_shift**expon
1756             e1=fac*fac*aa(itypi,itypj)
1757             e2=fac*bb(itypi,itypj)
1758             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1759             eps2der=evdwij*eps3rt
1760             eps3der=evdwij*eps2rt
1761 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1762 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1763             evdwij=evdwij*eps2rt*eps3rt
1764 #ifdef TSCSC
1765             if (bb(itypi,itypj).gt.0) then
1766                evdw_p=evdw_p+evdwij
1767             else
1768                evdw_m=evdw_m+evdwij
1769             endif
1770 #else
1771             evdw=evdw+evdwij
1772 #endif
1773             if (lprn) then
1774             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1775             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1776             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1777      &        restyp(itypi),i,restyp(itypj),j,
1778      &        epsi,sigm,chi1,chi2,chip1,chip2,
1779      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1780      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1781      &        evdwij
1782             endif
1783
1784             if (energy_dec) then
1785               write (iout,'(a6,2i5,0pf7.3)') 'evdw',i,j,evdwij
1786               call flush(iout)
1787             endif
1788 C Calculate gradient components.
1789             e1=e1*eps1*eps2rt**2*eps3rt**2
1790             fac=-expon*(e1+evdwij)*rij_shift
1791             sigder=fac*sigder
1792             fac=rij*fac
1793 c            fac=0.0d0
1794 C Calculate the radial part of the gradient
1795             gg(1)=xj*fac
1796             gg(2)=yj*fac
1797             gg(3)=zj*fac
1798 C Calculate angular part of the gradient.
1799 #ifdef TSCSC
1800             if (bb(itypi,itypj).gt.0) then
1801                call sc_grad
1802             else
1803                call sc_grad_T
1804             endif
1805 #else
1806             call sc_grad
1807 #endif
1808             ENDIF    ! dyn_ss
1809           enddo      ! j
1810         enddo        ! iint
1811       enddo          ! i
1812 c      write (iout,*) "Number of loop steps in EGB:",ind
1813 cccc      energy_dec=.false.
1814       return
1815       end
1816 C-----------------------------------------------------------------------------
1817       subroutine egbv(evdw,evdw_p,evdw_m)
1818 C
1819 C This subroutine calculates the interaction energy of nonbonded side chains
1820 C assuming the Gay-Berne-Vorobjev potential of interaction.
1821 C
1822       implicit real*8 (a-h,o-z)
1823       include 'DIMENSIONS'
1824       include 'COMMON.GEO'
1825       include 'COMMON.VAR'
1826       include 'COMMON.LOCAL'
1827       include 'COMMON.CHAIN'
1828       include 'COMMON.DERIV'
1829       include 'COMMON.NAMES'
1830       include 'COMMON.INTERACT'
1831       include 'COMMON.IOUNITS'
1832       include 'COMMON.CALC'
1833       common /srutu/ icall
1834       logical lprn
1835       evdw=0.0D0
1836 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1837       evdw=0.0D0
1838       lprn=.false.
1839 c     if (icall.eq.0) lprn=.true.
1840       ind=0
1841       do i=iatsc_s,iatsc_e
1842         itypi=itype(i)
1843         itypi1=itype(i+1)
1844         xi=c(1,nres+i)
1845         yi=c(2,nres+i)
1846         zi=c(3,nres+i)
1847         dxi=dc_norm(1,nres+i)
1848         dyi=dc_norm(2,nres+i)
1849         dzi=dc_norm(3,nres+i)
1850 c        dsci_inv=dsc_inv(itypi)
1851         dsci_inv=vbld_inv(i+nres)
1852 C
1853 C Calculate SC interaction energy.
1854 C
1855         do iint=1,nint_gr(i)
1856           do j=istart(i,iint),iend(i,iint)
1857             ind=ind+1
1858             itypj=itype(j)
1859 c            dscj_inv=dsc_inv(itypj)
1860             dscj_inv=vbld_inv(j+nres)
1861             sig0ij=sigma(itypi,itypj)
1862             r0ij=r0(itypi,itypj)
1863             chi1=chi(itypi,itypj)
1864             chi2=chi(itypj,itypi)
1865             chi12=chi1*chi2
1866             chip1=chip(itypi)
1867             chip2=chip(itypj)
1868             chip12=chip1*chip2
1869             alf1=alp(itypi)
1870             alf2=alp(itypj)
1871             alf12=0.5D0*(alf1+alf2)
1872 C For diagnostics only!!!
1873 c           chi1=0.0D0
1874 c           chi2=0.0D0
1875 c           chi12=0.0D0
1876 c           chip1=0.0D0
1877 c           chip2=0.0D0
1878 c           chip12=0.0D0
1879 c           alf1=0.0D0
1880 c           alf2=0.0D0
1881 c           alf12=0.0D0
1882             xj=c(1,nres+j)-xi
1883             yj=c(2,nres+j)-yi
1884             zj=c(3,nres+j)-zi
1885             dxj=dc_norm(1,nres+j)
1886             dyj=dc_norm(2,nres+j)
1887             dzj=dc_norm(3,nres+j)
1888             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1889             rij=dsqrt(rrij)
1890 C Calculate angle-dependent terms of energy and contributions to their
1891 C derivatives.
1892             call sc_angular
1893             sigsq=1.0D0/sigsq
1894             sig=sig0ij*dsqrt(sigsq)
1895             rij_shift=1.0D0/rij-sig+r0ij
1896 C I hate to put IF's in the loops, but here don't have another choice!!!!
1897             if (rij_shift.le.0.0D0) then
1898               evdw=1.0D20
1899               return
1900             endif
1901             sigder=-sig*sigsq
1902 c---------------------------------------------------------------
1903             rij_shift=1.0D0/rij_shift
1904             fac=rij_shift**expon
1905             e1=fac*fac*aa(itypi,itypj)
1906             e2=fac*bb(itypi,itypj)
1907             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1908             eps2der=evdwij*eps3rt
1909             eps3der=evdwij*eps2rt
1910             fac_augm=rrij**expon
1911             e_augm=augm(itypi,itypj)*fac_augm
1912             evdwij=evdwij*eps2rt*eps3rt
1913 #ifdef TSCSC
1914             if (bb(itypi,itypj).gt.0) then
1915                evdw_p=evdw_p+evdwij+e_augm
1916             else
1917                evdw_m=evdw_m+evdwij+e_augm
1918             endif
1919 #else
1920             evdw=evdw+evdwij+e_augm
1921 #endif
1922             if (lprn) then
1923             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1924             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1925             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1926      &        restyp(itypi),i,restyp(itypj),j,
1927      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1928      &        chi1,chi2,chip1,chip2,
1929      &        eps1,eps2rt**2,eps3rt**2,
1930      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1931      &        evdwij+e_augm
1932             endif
1933 C Calculate gradient components.
1934             e1=e1*eps1*eps2rt**2*eps3rt**2
1935             fac=-expon*(e1+evdwij)*rij_shift
1936             sigder=fac*sigder
1937             fac=rij*fac-2*expon*rrij*e_augm
1938 C Calculate the radial part of the gradient
1939             gg(1)=xj*fac
1940             gg(2)=yj*fac
1941             gg(3)=zj*fac
1942 C Calculate angular part of the gradient.
1943 #ifdef TSCSC
1944             if (bb(itypi,itypj).gt.0) then
1945                call sc_grad
1946             else
1947                call sc_grad_T
1948             endif
1949 #else
1950             call sc_grad
1951 #endif
1952           enddo      ! j
1953         enddo        ! iint
1954       enddo          ! i
1955       end
1956 C-----------------------------------------------------------------------------
1957       subroutine sc_angular
1958 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1959 C om12. Called by ebp, egb, and egbv.
1960       implicit none
1961       include 'COMMON.CALC'
1962       include 'COMMON.IOUNITS'
1963       erij(1)=xj*rij
1964       erij(2)=yj*rij
1965       erij(3)=zj*rij
1966       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1967       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1968       om12=dxi*dxj+dyi*dyj+dzi*dzj
1969       chiom12=chi12*om12
1970 C Calculate eps1(om12) and its derivative in om12
1971       faceps1=1.0D0-om12*chiom12
1972       faceps1_inv=1.0D0/faceps1
1973       eps1=dsqrt(faceps1_inv)
1974 C Following variable is eps1*deps1/dom12
1975       eps1_om12=faceps1_inv*chiom12
1976 c diagnostics only
1977 c      faceps1_inv=om12
1978 c      eps1=om12
1979 c      eps1_om12=1.0d0
1980 c      write (iout,*) "om12",om12," eps1",eps1
1981 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1982 C and om12.
1983       om1om2=om1*om2
1984       chiom1=chi1*om1
1985       chiom2=chi2*om2
1986       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1987       sigsq=1.0D0-facsig*faceps1_inv
1988       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1989       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1990       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1991 c diagnostics only
1992 c      sigsq=1.0d0
1993 c      sigsq_om1=0.0d0
1994 c      sigsq_om2=0.0d0
1995 c      sigsq_om12=0.0d0
1996 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1997 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1998 c     &    " eps1",eps1
1999 C Calculate eps2 and its derivatives in om1, om2, and om12.
2000       chipom1=chip1*om1
2001       chipom2=chip2*om2
2002       chipom12=chip12*om12
2003       facp=1.0D0-om12*chipom12
2004       facp_inv=1.0D0/facp
2005       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2006 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2007 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2008 C Following variable is the square root of eps2
2009       eps2rt=1.0D0-facp1*facp_inv
2010 C Following three variables are the derivatives of the square root of eps
2011 C in om1, om2, and om12.
2012       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2013       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2014       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2015 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2016       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2017 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2018 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2019 c     &  " eps2rt_om12",eps2rt_om12
2020 C Calculate whole angle-dependent part of epsilon and contributions
2021 C to its derivatives
2022       return
2023       end
2024
2025 C----------------------------------------------------------------------------
2026       subroutine sc_grad_T
2027       implicit real*8 (a-h,o-z)
2028       include 'DIMENSIONS'
2029       include 'COMMON.CHAIN'
2030       include 'COMMON.DERIV'
2031       include 'COMMON.CALC'
2032       include 'COMMON.IOUNITS'
2033       double precision dcosom1(3),dcosom2(3)
2034       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2035       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2036       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2037      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2038 c diagnostics only
2039 c      eom1=0.0d0
2040 c      eom2=0.0d0
2041 c      eom12=evdwij*eps1_om12
2042 c end diagnostics
2043 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2044 c     &  " sigder",sigder
2045 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2046 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2047       do k=1,3
2048         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2049         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2050       enddo
2051       do k=1,3
2052         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
2053       enddo
2054 c      write (iout,*) "gg",(gg(k),k=1,3)
2055       do k=1,3
2056         gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
2057      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2058      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2059         gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
2060      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2061      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2062 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2063 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2064 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2065 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2066       enddo
2067 C
2068 C Calculate the components of the gradient in DC and X
2069 C
2070 cgrad      do k=i,j-1
2071 cgrad        do l=1,3
2072 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2073 cgrad        enddo
2074 cgrad      enddo
2075       do l=1,3
2076         gvdwcT(l,i)=gvdwcT(l,i)-gg(l)
2077         gvdwcT(l,j)=gvdwcT(l,j)+gg(l)
2078       enddo
2079       return
2080       end
2081
2082 C----------------------------------------------------------------------------
2083       subroutine sc_grad
2084       implicit real*8 (a-h,o-z)
2085       include 'DIMENSIONS'
2086       include 'COMMON.CHAIN'
2087       include 'COMMON.DERIV'
2088       include 'COMMON.CALC'
2089       include 'COMMON.IOUNITS'
2090       double precision dcosom1(3),dcosom2(3)
2091       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2092       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2093       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2094      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2095 c diagnostics only
2096 c      eom1=0.0d0
2097 c      eom2=0.0d0
2098 c      eom12=evdwij*eps1_om12
2099 c end diagnostics
2100 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2101 c     &  " sigder",sigder
2102 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2103 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2104       do k=1,3
2105         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2106         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2107       enddo
2108       do k=1,3
2109         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
2110       enddo
2111 c      write (iout,*) "gg",(gg(k),k=1,3)
2112       do k=1,3
2113         gvdwx(k,i)=gvdwx(k,i)-gg(k)
2114      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2115      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2116         gvdwx(k,j)=gvdwx(k,j)+gg(k)
2117      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2118      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2119 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2120 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2121 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2122 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2123       enddo
2124 C
2125 C Calculate the components of the gradient in DC and X
2126 C
2127 cgrad      do k=i,j-1
2128 cgrad        do l=1,3
2129 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2130 cgrad        enddo
2131 cgrad      enddo
2132       do l=1,3
2133         gvdwc(l,i)=gvdwc(l,i)-gg(l)
2134         gvdwc(l,j)=gvdwc(l,j)+gg(l)
2135       enddo
2136       return
2137       end
2138 C-----------------------------------------------------------------------
2139       subroutine e_softsphere(evdw)
2140 C
2141 C This subroutine calculates the interaction energy of nonbonded side chains
2142 C assuming the LJ potential of interaction.
2143 C
2144       implicit real*8 (a-h,o-z)
2145       include 'DIMENSIONS'
2146       parameter (accur=1.0d-10)
2147       include 'COMMON.GEO'
2148       include 'COMMON.VAR'
2149       include 'COMMON.LOCAL'
2150       include 'COMMON.CHAIN'
2151       include 'COMMON.DERIV'
2152       include 'COMMON.INTERACT'
2153       include 'COMMON.TORSION'
2154       include 'COMMON.SBRIDGE'
2155       include 'COMMON.NAMES'
2156       include 'COMMON.IOUNITS'
2157       include 'COMMON.CONTACTS'
2158       dimension gg(3)
2159 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2160       evdw=0.0D0
2161       do i=iatsc_s,iatsc_e
2162         itypi=itype(i)
2163         itypi1=itype(i+1)
2164         xi=c(1,nres+i)
2165         yi=c(2,nres+i)
2166         zi=c(3,nres+i)
2167 C
2168 C Calculate SC interaction energy.
2169 C
2170         do iint=1,nint_gr(i)
2171 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2172 cd   &                  'iend=',iend(i,iint)
2173           do j=istart(i,iint),iend(i,iint)
2174             itypj=itype(j)
2175             xj=c(1,nres+j)-xi
2176             yj=c(2,nres+j)-yi
2177             zj=c(3,nres+j)-zi
2178             rij=xj*xj+yj*yj+zj*zj
2179 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2180             r0ij=r0(itypi,itypj)
2181             r0ijsq=r0ij*r0ij
2182 c            print *,i,j,r0ij,dsqrt(rij)
2183             if (rij.lt.r0ijsq) then
2184               evdwij=0.25d0*(rij-r0ijsq)**2
2185               fac=rij-r0ijsq
2186             else
2187               evdwij=0.0d0
2188               fac=0.0d0
2189             endif
2190             evdw=evdw+evdwij
2191 C
2192 C Calculate the components of the gradient in DC and X
2193 C
2194             gg(1)=xj*fac
2195             gg(2)=yj*fac
2196             gg(3)=zj*fac
2197             do k=1,3
2198               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2199               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2200               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2201               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2202             enddo
2203 cgrad            do k=i,j-1
2204 cgrad              do l=1,3
2205 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2206 cgrad              enddo
2207 cgrad            enddo
2208           enddo ! j
2209         enddo ! iint
2210       enddo ! i
2211       return
2212       end
2213 C--------------------------------------------------------------------------
2214       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2215      &              eello_turn4)
2216 C
2217 C Soft-sphere potential of p-p interaction
2218 C
2219       implicit real*8 (a-h,o-z)
2220       include 'DIMENSIONS'
2221       include 'COMMON.CONTROL'
2222       include 'COMMON.IOUNITS'
2223       include 'COMMON.GEO'
2224       include 'COMMON.VAR'
2225       include 'COMMON.LOCAL'
2226       include 'COMMON.CHAIN'
2227       include 'COMMON.DERIV'
2228       include 'COMMON.INTERACT'
2229       include 'COMMON.CONTACTS'
2230       include 'COMMON.TORSION'
2231       include 'COMMON.VECTORS'
2232       include 'COMMON.FFIELD'
2233       dimension ggg(3)
2234 cd      write(iout,*) 'In EELEC_soft_sphere'
2235       ees=0.0D0
2236       evdw1=0.0D0
2237       eel_loc=0.0d0
2238       eello_turn3=0.0d0
2239       eello_turn4=0.0d0
2240       ind=0
2241       do i=iatel_s,iatel_e
2242         dxi=dc(1,i)
2243         dyi=dc(2,i)
2244         dzi=dc(3,i)
2245         xmedi=c(1,i)+0.5d0*dxi
2246         ymedi=c(2,i)+0.5d0*dyi
2247         zmedi=c(3,i)+0.5d0*dzi
2248         num_conti=0
2249 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2250         do j=ielstart(i),ielend(i)
2251           ind=ind+1
2252           iteli=itel(i)
2253           itelj=itel(j)
2254           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2255           r0ij=rpp(iteli,itelj)
2256           r0ijsq=r0ij*r0ij
2257           dxj=dc(1,j)
2258           dyj=dc(2,j)
2259           dzj=dc(3,j)
2260           xj=c(1,j)+0.5D0*dxj-xmedi
2261           yj=c(2,j)+0.5D0*dyj-ymedi
2262           zj=c(3,j)+0.5D0*dzj-zmedi
2263           rij=xj*xj+yj*yj+zj*zj
2264           if (rij.lt.r0ijsq) then
2265             evdw1ij=0.25d0*(rij-r0ijsq)**2
2266             fac=rij-r0ijsq
2267           else
2268             evdw1ij=0.0d0
2269             fac=0.0d0
2270           endif
2271           evdw1=evdw1+evdw1ij
2272 C
2273 C Calculate contributions to the Cartesian gradient.
2274 C
2275           ggg(1)=fac*xj
2276           ggg(2)=fac*yj
2277           ggg(3)=fac*zj
2278           do k=1,3
2279             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2280             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2281           enddo
2282 *
2283 * Loop over residues i+1 thru j-1.
2284 *
2285 cgrad          do k=i+1,j-1
2286 cgrad            do l=1,3
2287 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2288 cgrad            enddo
2289 cgrad          enddo
2290         enddo ! j
2291       enddo   ! i
2292 cgrad      do i=nnt,nct-1
2293 cgrad        do k=1,3
2294 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2295 cgrad        enddo
2296 cgrad        do j=i+1,nct-1
2297 cgrad          do k=1,3
2298 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2299 cgrad          enddo
2300 cgrad        enddo
2301 cgrad      enddo
2302       return
2303       end
2304 c------------------------------------------------------------------------------
2305       subroutine vec_and_deriv
2306       implicit real*8 (a-h,o-z)
2307       include 'DIMENSIONS'
2308 #ifdef MPI
2309       include 'mpif.h'
2310 #endif
2311       include 'COMMON.IOUNITS'
2312       include 'COMMON.GEO'
2313       include 'COMMON.VAR'
2314       include 'COMMON.LOCAL'
2315       include 'COMMON.CHAIN'
2316       include 'COMMON.VECTORS'
2317       include 'COMMON.SETUP'
2318       include 'COMMON.TIME1'
2319       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2320 C Compute the local reference systems. For reference system (i), the
2321 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2322 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2323 #ifdef PARVEC
2324       do i=ivec_start,ivec_end
2325 #else
2326       do i=1,nres-1
2327 #endif
2328           if (i.eq.nres-1) then
2329 C Case of the last full residue
2330 C Compute the Z-axis
2331             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2332             costh=dcos(pi-theta(nres))
2333             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2334             do k=1,3
2335               uz(k,i)=fac*uz(k,i)
2336             enddo
2337 C Compute the derivatives of uz
2338             uzder(1,1,1)= 0.0d0
2339             uzder(2,1,1)=-dc_norm(3,i-1)
2340             uzder(3,1,1)= dc_norm(2,i-1)
2341             uzder(1,2,1)= dc_norm(3,i-1)
2342             uzder(2,2,1)= 0.0d0
2343             uzder(3,2,1)=-dc_norm(1,i-1)
2344             uzder(1,3,1)=-dc_norm(2,i-1)
2345             uzder(2,3,1)= dc_norm(1,i-1)
2346             uzder(3,3,1)= 0.0d0
2347             uzder(1,1,2)= 0.0d0
2348             uzder(2,1,2)= dc_norm(3,i)
2349             uzder(3,1,2)=-dc_norm(2,i)
2350             uzder(1,2,2)=-dc_norm(3,i)
2351             uzder(2,2,2)= 0.0d0
2352             uzder(3,2,2)= dc_norm(1,i)
2353             uzder(1,3,2)= dc_norm(2,i)
2354             uzder(2,3,2)=-dc_norm(1,i)
2355             uzder(3,3,2)= 0.0d0
2356 C Compute the Y-axis
2357             facy=fac
2358             do k=1,3
2359               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2360             enddo
2361 C Compute the derivatives of uy
2362             do j=1,3
2363               do k=1,3
2364                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2365      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2366                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2367               enddo
2368               uyder(j,j,1)=uyder(j,j,1)-costh
2369               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2370             enddo
2371             do j=1,2
2372               do k=1,3
2373                 do l=1,3
2374                   uygrad(l,k,j,i)=uyder(l,k,j)
2375                   uzgrad(l,k,j,i)=uzder(l,k,j)
2376                 enddo
2377               enddo
2378             enddo
2379             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2380             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2381             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2382             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2383           else
2384 C Other residues
2385 C Compute the Z-axis
2386             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2387             costh=dcos(pi-theta(i+2))
2388             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2389             do k=1,3
2390               uz(k,i)=fac*uz(k,i)
2391             enddo
2392 C Compute the derivatives of uz
2393             uzder(1,1,1)= 0.0d0
2394             uzder(2,1,1)=-dc_norm(3,i+1)
2395             uzder(3,1,1)= dc_norm(2,i+1)
2396             uzder(1,2,1)= dc_norm(3,i+1)
2397             uzder(2,2,1)= 0.0d0
2398             uzder(3,2,1)=-dc_norm(1,i+1)
2399             uzder(1,3,1)=-dc_norm(2,i+1)
2400             uzder(2,3,1)= dc_norm(1,i+1)
2401             uzder(3,3,1)= 0.0d0
2402             uzder(1,1,2)= 0.0d0
2403             uzder(2,1,2)= dc_norm(3,i)
2404             uzder(3,1,2)=-dc_norm(2,i)
2405             uzder(1,2,2)=-dc_norm(3,i)
2406             uzder(2,2,2)= 0.0d0
2407             uzder(3,2,2)= dc_norm(1,i)
2408             uzder(1,3,2)= dc_norm(2,i)
2409             uzder(2,3,2)=-dc_norm(1,i)
2410             uzder(3,3,2)= 0.0d0
2411 C Compute the Y-axis
2412             facy=fac
2413             do k=1,3
2414               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2415             enddo
2416 C Compute the derivatives of uy
2417             do j=1,3
2418               do k=1,3
2419                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2420      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2421                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2422               enddo
2423               uyder(j,j,1)=uyder(j,j,1)-costh
2424               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2425             enddo
2426             do j=1,2
2427               do k=1,3
2428                 do l=1,3
2429                   uygrad(l,k,j,i)=uyder(l,k,j)
2430                   uzgrad(l,k,j,i)=uzder(l,k,j)
2431                 enddo
2432               enddo
2433             enddo
2434             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2435             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2436             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2437             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2438           endif
2439       enddo
2440       do i=1,nres-1
2441         vbld_inv_temp(1)=vbld_inv(i+1)
2442         if (i.lt.nres-1) then
2443           vbld_inv_temp(2)=vbld_inv(i+2)
2444           else
2445           vbld_inv_temp(2)=vbld_inv(i)
2446           endif
2447         do j=1,2
2448           do k=1,3
2449             do l=1,3
2450               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2451               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2452             enddo
2453           enddo
2454         enddo
2455       enddo
2456 #if defined(PARVEC) && defined(MPI)
2457       if (nfgtasks1.gt.1) then
2458         time00=MPI_Wtime()
2459 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2460 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2461 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2462         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2463      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2464      &   FG_COMM1,IERR)
2465         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2466      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2467      &   FG_COMM1,IERR)
2468         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2469      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2470      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2471         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2472      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2473      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2474         time_gather=time_gather+MPI_Wtime()-time00
2475       endif
2476 c      if (fg_rank.eq.0) then
2477 c        write (iout,*) "Arrays UY and UZ"
2478 c        do i=1,nres-1
2479 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2480 c     &     (uz(k,i),k=1,3)
2481 c        enddo
2482 c      endif
2483 #endif
2484       return
2485       end
2486 C-----------------------------------------------------------------------------
2487       subroutine check_vecgrad
2488       implicit real*8 (a-h,o-z)
2489       include 'DIMENSIONS'
2490       include 'COMMON.IOUNITS'
2491       include 'COMMON.GEO'
2492       include 'COMMON.VAR'
2493       include 'COMMON.LOCAL'
2494       include 'COMMON.CHAIN'
2495       include 'COMMON.VECTORS'
2496       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2497       dimension uyt(3,maxres),uzt(3,maxres)
2498       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2499       double precision delta /1.0d-7/
2500       call vec_and_deriv
2501 cd      do i=1,nres
2502 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2503 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2504 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2505 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2506 cd     &     (dc_norm(if90,i),if90=1,3)
2507 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2508 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2509 cd          write(iout,'(a)')
2510 cd      enddo
2511       do i=1,nres
2512         do j=1,2
2513           do k=1,3
2514             do l=1,3
2515               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2516               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2517             enddo
2518           enddo
2519         enddo
2520       enddo
2521       call vec_and_deriv
2522       do i=1,nres
2523         do j=1,3
2524           uyt(j,i)=uy(j,i)
2525           uzt(j,i)=uz(j,i)
2526         enddo
2527       enddo
2528       do i=1,nres
2529 cd        write (iout,*) 'i=',i
2530         do k=1,3
2531           erij(k)=dc_norm(k,i)
2532         enddo
2533         do j=1,3
2534           do k=1,3
2535             dc_norm(k,i)=erij(k)
2536           enddo
2537           dc_norm(j,i)=dc_norm(j,i)+delta
2538 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2539 c          do k=1,3
2540 c            dc_norm(k,i)=dc_norm(k,i)/fac
2541 c          enddo
2542 c          write (iout,*) (dc_norm(k,i),k=1,3)
2543 c          write (iout,*) (erij(k),k=1,3)
2544           call vec_and_deriv
2545           do k=1,3
2546             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2547             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2548             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2549             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2550           enddo
2551 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2552 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2553 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2554         enddo
2555         do k=1,3
2556           dc_norm(k,i)=erij(k)
2557         enddo
2558 cd        do k=1,3
2559 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2560 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2561 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2562 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2563 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2564 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2565 cd          write (iout,'(a)')
2566 cd        enddo
2567       enddo
2568       return
2569       end
2570 C--------------------------------------------------------------------------
2571       subroutine set_matrices
2572       implicit real*8 (a-h,o-z)
2573       include 'DIMENSIONS'
2574 #ifdef MPI
2575       include "mpif.h"
2576       include "COMMON.SETUP"
2577       integer IERR
2578       integer status(MPI_STATUS_SIZE)
2579 #endif
2580       include 'COMMON.IOUNITS'
2581       include 'COMMON.GEO'
2582       include 'COMMON.VAR'
2583       include 'COMMON.LOCAL'
2584       include 'COMMON.CHAIN'
2585       include 'COMMON.DERIV'
2586       include 'COMMON.INTERACT'
2587       include 'COMMON.CONTACTS'
2588       include 'COMMON.TORSION'
2589       include 'COMMON.VECTORS'
2590       include 'COMMON.FFIELD'
2591       double precision auxvec(2),auxmat(2,2)
2592 C
2593 C Compute the virtual-bond-torsional-angle dependent quantities needed
2594 C to calculate the el-loc multibody terms of various order.
2595 C
2596 #ifdef PARMAT
2597       do i=ivec_start+2,ivec_end+2
2598 #else
2599       do i=3,nres+1
2600 #endif
2601         if (i .lt. nres+1) then
2602           sin1=dsin(phi(i))
2603           cos1=dcos(phi(i))
2604           sintab(i-2)=sin1
2605           costab(i-2)=cos1
2606           obrot(1,i-2)=cos1
2607           obrot(2,i-2)=sin1
2608           sin2=dsin(2*phi(i))
2609           cos2=dcos(2*phi(i))
2610           sintab2(i-2)=sin2
2611           costab2(i-2)=cos2
2612           obrot2(1,i-2)=cos2
2613           obrot2(2,i-2)=sin2
2614           Ug(1,1,i-2)=-cos1
2615           Ug(1,2,i-2)=-sin1
2616           Ug(2,1,i-2)=-sin1
2617           Ug(2,2,i-2)= cos1
2618           Ug2(1,1,i-2)=-cos2
2619           Ug2(1,2,i-2)=-sin2
2620           Ug2(2,1,i-2)=-sin2
2621           Ug2(2,2,i-2)= cos2
2622         else
2623           costab(i-2)=1.0d0
2624           sintab(i-2)=0.0d0
2625           obrot(1,i-2)=1.0d0
2626           obrot(2,i-2)=0.0d0
2627           obrot2(1,i-2)=0.0d0
2628           obrot2(2,i-2)=0.0d0
2629           Ug(1,1,i-2)=1.0d0
2630           Ug(1,2,i-2)=0.0d0
2631           Ug(2,1,i-2)=0.0d0
2632           Ug(2,2,i-2)=1.0d0
2633           Ug2(1,1,i-2)=0.0d0
2634           Ug2(1,2,i-2)=0.0d0
2635           Ug2(2,1,i-2)=0.0d0
2636           Ug2(2,2,i-2)=0.0d0
2637         endif
2638         if (i .gt. 3 .and. i .lt. nres+1) then
2639           obrot_der(1,i-2)=-sin1
2640           obrot_der(2,i-2)= cos1
2641           Ugder(1,1,i-2)= sin1
2642           Ugder(1,2,i-2)=-cos1
2643           Ugder(2,1,i-2)=-cos1
2644           Ugder(2,2,i-2)=-sin1
2645           dwacos2=cos2+cos2
2646           dwasin2=sin2+sin2
2647           obrot2_der(1,i-2)=-dwasin2
2648           obrot2_der(2,i-2)= dwacos2
2649           Ug2der(1,1,i-2)= dwasin2
2650           Ug2der(1,2,i-2)=-dwacos2
2651           Ug2der(2,1,i-2)=-dwacos2
2652           Ug2der(2,2,i-2)=-dwasin2
2653         else
2654           obrot_der(1,i-2)=0.0d0
2655           obrot_der(2,i-2)=0.0d0
2656           Ugder(1,1,i-2)=0.0d0
2657           Ugder(1,2,i-2)=0.0d0
2658           Ugder(2,1,i-2)=0.0d0
2659           Ugder(2,2,i-2)=0.0d0
2660           obrot2_der(1,i-2)=0.0d0
2661           obrot2_der(2,i-2)=0.0d0
2662           Ug2der(1,1,i-2)=0.0d0
2663           Ug2der(1,2,i-2)=0.0d0
2664           Ug2der(2,1,i-2)=0.0d0
2665           Ug2der(2,2,i-2)=0.0d0
2666         endif
2667 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2668         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2669           iti = itortyp(itype(i-2))
2670         else
2671           iti=ntortyp+1
2672         endif
2673 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2674         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2675           iti1 = itortyp(itype(i-1))
2676         else
2677           iti1=ntortyp+1
2678         endif
2679 cd        write (iout,*) '*******i',i,' iti1',iti
2680 cd        write (iout,*) 'b1',b1(:,iti)
2681 cd        write (iout,*) 'b2',b2(:,iti)
2682 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2683 c        if (i .gt. iatel_s+2) then
2684         if (i .gt. nnt+2) then
2685           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2686           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2687           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2688      &    then
2689           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2690           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2691           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2692           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2693           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2694           endif
2695         else
2696           do k=1,2
2697             Ub2(k,i-2)=0.0d0
2698             Ctobr(k,i-2)=0.0d0
2699             Dtobr2(k,i-2)=0.0d0
2700             do l=1,2
2701               EUg(l,k,i-2)=0.0d0
2702               CUg(l,k,i-2)=0.0d0
2703               DUg(l,k,i-2)=0.0d0
2704               DtUg2(l,k,i-2)=0.0d0
2705             enddo
2706           enddo
2707         endif
2708         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2709         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2710         do k=1,2
2711           muder(k,i-2)=Ub2der(k,i-2)
2712         enddo
2713 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2714         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2715           iti1 = itortyp(itype(i-1))
2716         else
2717           iti1=ntortyp+1
2718         endif
2719         do k=1,2
2720           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2721         enddo
2722 cd        write (iout,*) 'mu ',mu(:,i-2)
2723 cd        write (iout,*) 'mu1',mu1(:,i-2)
2724 cd        write (iout,*) 'mu2',mu2(:,i-2)
2725         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2726      &  then
2727         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2728         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2729         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2730         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2731         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2732 C Vectors and matrices dependent on a single virtual-bond dihedral.
2733         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2734         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2735         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2736         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2737         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2738         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2739         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2740         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2741         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2742         endif
2743       enddo
2744 C Matrices dependent on two consecutive virtual-bond dihedrals.
2745 C The order of matrices is from left to right.
2746       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2747      &then
2748 c      do i=max0(ivec_start,2),ivec_end
2749       do i=2,nres-1
2750         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2751         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2752         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2753         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2754         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2755         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2756         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2757         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2758       enddo
2759       endif
2760 #if defined(MPI) && defined(PARMAT)
2761 #ifdef DEBUG
2762 c      if (fg_rank.eq.0) then
2763         write (iout,*) "Arrays UG and UGDER before GATHER"
2764         do i=1,nres-1
2765           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2766      &     ((ug(l,k,i),l=1,2),k=1,2),
2767      &     ((ugder(l,k,i),l=1,2),k=1,2)
2768         enddo
2769         write (iout,*) "Arrays UG2 and UG2DER"
2770         do i=1,nres-1
2771           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2772      &     ((ug2(l,k,i),l=1,2),k=1,2),
2773      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2774         enddo
2775         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2776         do i=1,nres-1
2777           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2778      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2779      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2780         enddo
2781         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2782         do i=1,nres-1
2783           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2784      &     costab(i),sintab(i),costab2(i),sintab2(i)
2785         enddo
2786         write (iout,*) "Array MUDER"
2787         do i=1,nres-1
2788           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2789         enddo
2790 c      endif
2791 #endif
2792       if (nfgtasks.gt.1) then
2793         time00=MPI_Wtime()
2794 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2795 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2796 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2797 #ifdef MATGATHER
2798         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2799      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2800      &   FG_COMM1,IERR)
2801         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2802      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2803      &   FG_COMM1,IERR)
2804         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2805      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2806      &   FG_COMM1,IERR)
2807         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2808      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2809      &   FG_COMM1,IERR)
2810         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2811      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2812      &   FG_COMM1,IERR)
2813         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2814      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2815      &   FG_COMM1,IERR)
2816         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2817      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2818      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2819         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2820      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2821      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2822         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2823      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2824      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2825         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2826      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2827      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2828         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2829      &  then
2830         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2831      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2832      &   FG_COMM1,IERR)
2833         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2834      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2835      &   FG_COMM1,IERR)
2836         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2837      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2838      &   FG_COMM1,IERR)
2839        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2840      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2841      &   FG_COMM1,IERR)
2842         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2843      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2844      &   FG_COMM1,IERR)
2845         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2846      &   ivec_count(fg_rank1),
2847      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2848      &   FG_COMM1,IERR)
2849         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2850      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2851      &   FG_COMM1,IERR)
2852         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2853      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2854      &   FG_COMM1,IERR)
2855         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2856      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2857      &   FG_COMM1,IERR)
2858         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2859      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2860      &   FG_COMM1,IERR)
2861         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2862      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2863      &   FG_COMM1,IERR)
2864         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2865      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2866      &   FG_COMM1,IERR)
2867         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2868      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2869      &   FG_COMM1,IERR)
2870         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2871      &   ivec_count(fg_rank1),
2872      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2873      &   FG_COMM1,IERR)
2874         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2875      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2876      &   FG_COMM1,IERR)
2877        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2878      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2879      &   FG_COMM1,IERR)
2880         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2881      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2882      &   FG_COMM1,IERR)
2883        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2884      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2885      &   FG_COMM1,IERR)
2886         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2887      &   ivec_count(fg_rank1),
2888      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2889      &   FG_COMM1,IERR)
2890         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2891      &   ivec_count(fg_rank1),
2892      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2893      &   FG_COMM1,IERR)
2894         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2895      &   ivec_count(fg_rank1),
2896      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2897      &   MPI_MAT2,FG_COMM1,IERR)
2898         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2899      &   ivec_count(fg_rank1),
2900      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2901      &   MPI_MAT2,FG_COMM1,IERR)
2902         endif
2903 #else
2904 c Passes matrix info through the ring
2905       isend=fg_rank1
2906       irecv=fg_rank1-1
2907       if (irecv.lt.0) irecv=nfgtasks1-1
2908       iprev=irecv
2909       inext=fg_rank1+1
2910       if (inext.ge.nfgtasks1) inext=0
2911       do i=1,nfgtasks1-1
2912 c        write (iout,*) "isend",isend," irecv",irecv
2913 c        call flush(iout)
2914         lensend=lentyp(isend)
2915         lenrecv=lentyp(irecv)
2916 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2917 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2918 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2919 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2920 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2921 c        write (iout,*) "Gather ROTAT1"
2922 c        call flush(iout)
2923 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2924 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2925 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2926 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2927 c        write (iout,*) "Gather ROTAT2"
2928 c        call flush(iout)
2929         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2930      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2931      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2932      &   iprev,4400+irecv,FG_COMM,status,IERR)
2933 c        write (iout,*) "Gather ROTAT_OLD"
2934 c        call flush(iout)
2935         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2936      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2937      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2938      &   iprev,5500+irecv,FG_COMM,status,IERR)
2939 c        write (iout,*) "Gather PRECOMP11"
2940 c        call flush(iout)
2941         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2942      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2943      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2944      &   iprev,6600+irecv,FG_COMM,status,IERR)
2945 c        write (iout,*) "Gather PRECOMP12"
2946 c        call flush(iout)
2947         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2948      &  then
2949         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2950      &   MPI_ROTAT2(lensend),inext,7700+isend,
2951      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2952      &   iprev,7700+irecv,FG_COMM,status,IERR)
2953 c        write (iout,*) "Gather PRECOMP21"
2954 c        call flush(iout)
2955         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2956      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2957      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2958      &   iprev,8800+irecv,FG_COMM,status,IERR)
2959 c        write (iout,*) "Gather PRECOMP22"
2960 c        call flush(iout)
2961         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2962      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2963      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2964      &   MPI_PRECOMP23(lenrecv),
2965      &   iprev,9900+irecv,FG_COMM,status,IERR)
2966 c        write (iout,*) "Gather PRECOMP23"
2967 c        call flush(iout)
2968         endif
2969         isend=irecv
2970         irecv=irecv-1
2971         if (irecv.lt.0) irecv=nfgtasks1-1
2972       enddo
2973 #endif
2974         time_gather=time_gather+MPI_Wtime()-time00
2975       endif
2976 #ifdef DEBUG
2977 c      if (fg_rank.eq.0) then
2978         write (iout,*) "Arrays UG and UGDER"
2979         do i=1,nres-1
2980           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2981      &     ((ug(l,k,i),l=1,2),k=1,2),
2982      &     ((ugder(l,k,i),l=1,2),k=1,2)
2983         enddo
2984         write (iout,*) "Arrays UG2 and UG2DER"
2985         do i=1,nres-1
2986           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2987      &     ((ug2(l,k,i),l=1,2),k=1,2),
2988      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2989         enddo
2990         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2991         do i=1,nres-1
2992           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2993      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2994      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2995         enddo
2996         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2997         do i=1,nres-1
2998           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2999      &     costab(i),sintab(i),costab2(i),sintab2(i)
3000         enddo
3001         write (iout,*) "Array MUDER"
3002         do i=1,nres-1
3003           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3004         enddo
3005 c      endif
3006 #endif
3007 #endif
3008 cd      do i=1,nres
3009 cd        iti = itortyp(itype(i))
3010 cd        write (iout,*) i
3011 cd        do j=1,2
3012 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3013 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3014 cd        enddo
3015 cd      enddo
3016       return
3017       end
3018 C--------------------------------------------------------------------------
3019       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3020 C
3021 C This subroutine calculates the average interaction energy and its gradient
3022 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3023 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3024 C The potential depends both on the distance of peptide-group centers and on
3025 C the orientation of the CA-CA virtual bonds.
3026 C
3027       implicit real*8 (a-h,o-z)
3028 #ifdef MPI
3029       include 'mpif.h'
3030 #endif
3031       include 'DIMENSIONS'
3032       include 'COMMON.CONTROL'
3033       include 'COMMON.SETUP'
3034       include 'COMMON.IOUNITS'
3035       include 'COMMON.GEO'
3036       include 'COMMON.VAR'
3037       include 'COMMON.LOCAL'
3038       include 'COMMON.CHAIN'
3039       include 'COMMON.DERIV'
3040       include 'COMMON.INTERACT'
3041       include 'COMMON.CONTACTS'
3042       include 'COMMON.TORSION'
3043       include 'COMMON.VECTORS'
3044       include 'COMMON.FFIELD'
3045       include 'COMMON.TIME1'
3046       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3047      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3048       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3049      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3050       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3051      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3052      &    num_conti,j1,j2
3053 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3054 #ifdef MOMENT
3055       double precision scal_el /1.0d0/
3056 #else
3057       double precision scal_el /0.5d0/
3058 #endif
3059 C 12/13/98
3060 C 13-go grudnia roku pamietnego...
3061       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3062      &                   0.0d0,1.0d0,0.0d0,
3063      &                   0.0d0,0.0d0,1.0d0/
3064 cd      write(iout,*) 'In EELEC'
3065 cd      do i=1,nloctyp
3066 cd        write(iout,*) 'Type',i
3067 cd        write(iout,*) 'B1',B1(:,i)
3068 cd        write(iout,*) 'B2',B2(:,i)
3069 cd        write(iout,*) 'CC',CC(:,:,i)
3070 cd        write(iout,*) 'DD',DD(:,:,i)
3071 cd        write(iout,*) 'EE',EE(:,:,i)
3072 cd      enddo
3073 cd      call check_vecgrad
3074 cd      stop
3075       if (icheckgrad.eq.1) then
3076         do i=1,nres-1
3077           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3078           do k=1,3
3079             dc_norm(k,i)=dc(k,i)*fac
3080           enddo
3081 c          write (iout,*) 'i',i,' fac',fac
3082         enddo
3083       endif
3084       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3085      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3086      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3087 c        call vec_and_deriv
3088 #ifdef TIMING
3089         time01=MPI_Wtime()
3090 #endif
3091         call set_matrices
3092 #ifdef TIMING
3093         time_mat=time_mat+MPI_Wtime()-time01
3094 #endif
3095       endif
3096 cd      do i=1,nres-1
3097 cd        write (iout,*) 'i=',i
3098 cd        do k=1,3
3099 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3100 cd        enddo
3101 cd        do k=1,3
3102 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3103 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3104 cd        enddo
3105 cd      enddo
3106       t_eelecij=0.0d0
3107       ees=0.0D0
3108       evdw1=0.0D0
3109       eel_loc=0.0d0
3110       eello_turn3=0.0d0
3111       eello_turn4=0.0d0
3112       ind=0
3113       do i=1,nres
3114         num_cont_hb(i)=0
3115       enddo
3116 cd      print '(a)','Enter EELEC'
3117 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3118       do i=1,nres
3119         gel_loc_loc(i)=0.0d0
3120         gcorr_loc(i)=0.0d0
3121       enddo
3122 c
3123 c
3124 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3125 C
3126 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3127 C
3128       do i=iturn3_start,iturn3_end
3129         dxi=dc(1,i)
3130         dyi=dc(2,i)
3131         dzi=dc(3,i)
3132         dx_normi=dc_norm(1,i)
3133         dy_normi=dc_norm(2,i)
3134         dz_normi=dc_norm(3,i)
3135         xmedi=c(1,i)+0.5d0*dxi
3136         ymedi=c(2,i)+0.5d0*dyi
3137         zmedi=c(3,i)+0.5d0*dzi
3138         num_conti=0
3139         call eelecij(i,i+2,ees,evdw1,eel_loc)
3140         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3141         num_cont_hb(i)=num_conti
3142       enddo
3143       do i=iturn4_start,iturn4_end
3144         dxi=dc(1,i)
3145         dyi=dc(2,i)
3146         dzi=dc(3,i)
3147         dx_normi=dc_norm(1,i)
3148         dy_normi=dc_norm(2,i)
3149         dz_normi=dc_norm(3,i)
3150         xmedi=c(1,i)+0.5d0*dxi
3151         ymedi=c(2,i)+0.5d0*dyi
3152         zmedi=c(3,i)+0.5d0*dzi
3153         num_conti=num_cont_hb(i)
3154         call eelecij(i,i+3,ees,evdw1,eel_loc)
3155         if (wturn4.gt.0.0d0) call eturn4(i,eello_turn4)
3156         num_cont_hb(i)=num_conti
3157       enddo   ! i
3158 c
3159 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3160 c
3161       do i=iatel_s,iatel_e
3162         dxi=dc(1,i)
3163         dyi=dc(2,i)
3164         dzi=dc(3,i)
3165         dx_normi=dc_norm(1,i)
3166         dy_normi=dc_norm(2,i)
3167         dz_normi=dc_norm(3,i)
3168         xmedi=c(1,i)+0.5d0*dxi
3169         ymedi=c(2,i)+0.5d0*dyi
3170         zmedi=c(3,i)+0.5d0*dzi
3171 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3172         num_conti=num_cont_hb(i)
3173         do j=ielstart(i),ielend(i)
3174           call eelecij(i,j,ees,evdw1,eel_loc)
3175         enddo ! j
3176         num_cont_hb(i)=num_conti
3177       enddo   ! i
3178 c      write (iout,*) "Number of loop steps in EELEC:",ind
3179 cd      do i=1,nres
3180 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3181 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3182 cd      enddo
3183 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3184 ccc      eel_loc=eel_loc+eello_turn3
3185 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3186       return
3187       end
3188 C-------------------------------------------------------------------------------
3189       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3190       implicit real*8 (a-h,o-z)
3191       include 'DIMENSIONS'
3192 #ifdef MPI
3193       include "mpif.h"
3194 #endif
3195       include 'COMMON.CONTROL'
3196       include 'COMMON.IOUNITS'
3197       include 'COMMON.GEO'
3198       include 'COMMON.VAR'
3199       include 'COMMON.LOCAL'
3200       include 'COMMON.CHAIN'
3201       include 'COMMON.DERIV'
3202       include 'COMMON.INTERACT'
3203       include 'COMMON.CONTACTS'
3204       include 'COMMON.TORSION'
3205       include 'COMMON.VECTORS'
3206       include 'COMMON.FFIELD'
3207       include 'COMMON.TIME1'
3208       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3209      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3210       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3211      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3212       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3213      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3214      &    num_conti,j1,j2
3215 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3216 #ifdef MOMENT
3217       double precision scal_el /1.0d0/
3218 #else
3219       double precision scal_el /0.5d0/
3220 #endif
3221 C 12/13/98
3222 C 13-go grudnia roku pamietnego...
3223       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3224      &                   0.0d0,1.0d0,0.0d0,
3225      &                   0.0d0,0.0d0,1.0d0/
3226 c          time00=MPI_Wtime()
3227 cd      write (iout,*) "eelecij",i,j
3228 c          ind=ind+1
3229           iteli=itel(i)
3230           itelj=itel(j)
3231           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3232           aaa=app(iteli,itelj)
3233           bbb=bpp(iteli,itelj)
3234           ael6i=ael6(iteli,itelj)
3235           ael3i=ael3(iteli,itelj)
3236           dxj=dc(1,j)
3237           dyj=dc(2,j)
3238           dzj=dc(3,j)
3239           dx_normj=dc_norm(1,j)
3240           dy_normj=dc_norm(2,j)
3241           dz_normj=dc_norm(3,j)
3242           xj=c(1,j)+0.5D0*dxj-xmedi
3243           yj=c(2,j)+0.5D0*dyj-ymedi
3244           zj=c(3,j)+0.5D0*dzj-zmedi
3245           rij=xj*xj+yj*yj+zj*zj
3246           rrmij=1.0D0/rij
3247           rij=dsqrt(rij)
3248           rmij=1.0D0/rij
3249           r3ij=rrmij*rmij
3250           r6ij=r3ij*r3ij
3251           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3252           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3253           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3254           fac=cosa-3.0D0*cosb*cosg
3255           ev1=aaa*r6ij*r6ij
3256 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3257           if (j.eq.i+2) ev1=scal_el*ev1
3258           ev2=bbb*r6ij
3259           fac3=ael6i*r6ij
3260           fac4=ael3i*r3ij
3261           evdwij=ev1+ev2
3262           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3263           el2=fac4*fac
3264           eesij=el1+el2
3265 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3266           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3267           ees=ees+eesij
3268           evdw1=evdw1+evdwij
3269 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3270 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3271 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3272 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3273
3274           if (energy_dec) then
3275               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3276               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3277           endif
3278
3279 C
3280 C Calculate contributions to the Cartesian gradient.
3281 C
3282 #ifdef SPLITELE
3283           facvdw=-6*rrmij*(ev1+evdwij)
3284           facel=-3*rrmij*(el1+eesij)
3285           fac1=fac
3286           erij(1)=xj*rmij
3287           erij(2)=yj*rmij
3288           erij(3)=zj*rmij
3289 *
3290 * Radial derivatives. First process both termini of the fragment (i,j)
3291 *
3292           ggg(1)=facel*xj
3293           ggg(2)=facel*yj
3294           ggg(3)=facel*zj
3295 c          do k=1,3
3296 c            ghalf=0.5D0*ggg(k)
3297 c            gelc(k,i)=gelc(k,i)+ghalf
3298 c            gelc(k,j)=gelc(k,j)+ghalf
3299 c          enddo
3300 c 9/28/08 AL Gradient compotents will be summed only at the end
3301           do k=1,3
3302             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3303             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3304           enddo
3305 *
3306 * Loop over residues i+1 thru j-1.
3307 *
3308 cgrad          do k=i+1,j-1
3309 cgrad            do l=1,3
3310 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3311 cgrad            enddo
3312 cgrad          enddo
3313           ggg(1)=facvdw*xj
3314           ggg(2)=facvdw*yj
3315           ggg(3)=facvdw*zj
3316 c          do k=1,3
3317 c            ghalf=0.5D0*ggg(k)
3318 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3319 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3320 c          enddo
3321 c 9/28/08 AL Gradient compotents will be summed only at the end
3322           do k=1,3
3323             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3324             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3325           enddo
3326 *
3327 * Loop over residues i+1 thru j-1.
3328 *
3329 cgrad          do k=i+1,j-1
3330 cgrad            do l=1,3
3331 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3332 cgrad            enddo
3333 cgrad          enddo
3334 #else
3335           facvdw=ev1+evdwij
3336           facel=el1+eesij
3337           fac1=fac
3338           fac=-3*rrmij*(facvdw+facvdw+facel)
3339           erij(1)=xj*rmij
3340           erij(2)=yj*rmij
3341           erij(3)=zj*rmij
3342 *
3343 * Radial derivatives. First process both termini of the fragment (i,j)
3344 *
3345           ggg(1)=fac*xj
3346           ggg(2)=fac*yj
3347           ggg(3)=fac*zj
3348 c          do k=1,3
3349 c            ghalf=0.5D0*ggg(k)
3350 c            gelc(k,i)=gelc(k,i)+ghalf
3351 c            gelc(k,j)=gelc(k,j)+ghalf
3352 c          enddo
3353 c 9/28/08 AL Gradient compotents will be summed only at the end
3354           do k=1,3
3355             gelc_long(k,j)=gelc(k,j)+ggg(k)
3356             gelc_long(k,i)=gelc(k,i)-ggg(k)
3357           enddo
3358 *
3359 * Loop over residues i+1 thru j-1.
3360 *
3361 cgrad          do k=i+1,j-1
3362 cgrad            do l=1,3
3363 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3364 cgrad            enddo
3365 cgrad          enddo
3366 c 9/28/08 AL Gradient compotents will be summed only at the end
3367           ggg(1)=facvdw*xj
3368           ggg(2)=facvdw*yj
3369           ggg(3)=facvdw*zj
3370           do k=1,3
3371             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3372             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3373           enddo
3374 #endif
3375 *
3376 * Angular part
3377 *
3378           ecosa=2.0D0*fac3*fac1+fac4
3379           fac4=-3.0D0*fac4
3380           fac3=-6.0D0*fac3
3381           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3382           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3383           do k=1,3
3384             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3385             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3386           enddo
3387 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3388 cd   &          (dcosg(k),k=1,3)
3389           do k=1,3
3390             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3391           enddo
3392 c          do k=1,3
3393 c            ghalf=0.5D0*ggg(k)
3394 c            gelc(k,i)=gelc(k,i)+ghalf
3395 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3396 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3397 c            gelc(k,j)=gelc(k,j)+ghalf
3398 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3399 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3400 c          enddo
3401 cgrad          do k=i+1,j-1
3402 cgrad            do l=1,3
3403 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3404 cgrad            enddo
3405 cgrad          enddo
3406           do k=1,3
3407             gelc(k,i)=gelc(k,i)
3408      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3409      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3410             gelc(k,j)=gelc(k,j)
3411      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3412      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3413             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3414             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3415           enddo
3416           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3417      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3418      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3419 C
3420 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3421 C   energy of a peptide unit is assumed in the form of a second-order
3422 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3423 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3424 C   are computed for EVERY pair of non-contiguous peptide groups.
3425 C
3426           if (j.lt.nres-1) then
3427             j1=j+1
3428             j2=j-1
3429           else
3430             j1=j-1
3431             j2=j-2
3432           endif
3433           kkk=0
3434           do k=1,2
3435             do l=1,2
3436               kkk=kkk+1
3437               muij(kkk)=mu(k,i)*mu(l,j)
3438             enddo
3439           enddo
3440 cd         write (iout,*) 'EELEC: i',i,' j',j
3441 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3442 cd          write(iout,*) 'muij',muij
3443           ury=scalar(uy(1,i),erij)
3444           urz=scalar(uz(1,i),erij)
3445           vry=scalar(uy(1,j),erij)
3446           vrz=scalar(uz(1,j),erij)
3447           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3448           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3449           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3450           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3451           fac=dsqrt(-ael6i)*r3ij
3452           a22=a22*fac
3453           a23=a23*fac
3454           a32=a32*fac
3455           a33=a33*fac
3456 cd          write (iout,'(4i5,4f10.5)')
3457 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3458 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3459 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3460 cd     &      uy(:,j),uz(:,j)
3461 cd          write (iout,'(4f10.5)')
3462 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3463 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3464 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3465 cd           write (iout,'(9f10.5/)')
3466 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3467 C Derivatives of the elements of A in virtual-bond vectors
3468           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3469           do k=1,3
3470             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3471             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3472             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3473             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3474             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3475             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3476             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3477             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3478             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3479             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3480             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3481             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3482           enddo
3483 C Compute radial contributions to the gradient
3484           facr=-3.0d0*rrmij
3485           a22der=a22*facr
3486           a23der=a23*facr
3487           a32der=a32*facr
3488           a33der=a33*facr
3489           agg(1,1)=a22der*xj
3490           agg(2,1)=a22der*yj
3491           agg(3,1)=a22der*zj
3492           agg(1,2)=a23der*xj
3493           agg(2,2)=a23der*yj
3494           agg(3,2)=a23der*zj
3495           agg(1,3)=a32der*xj
3496           agg(2,3)=a32der*yj
3497           agg(3,3)=a32der*zj
3498           agg(1,4)=a33der*xj
3499           agg(2,4)=a33der*yj
3500           agg(3,4)=a33der*zj
3501 C Add the contributions coming from er
3502           fac3=-3.0d0*fac
3503           do k=1,3
3504             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3505             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3506             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3507             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3508           enddo
3509           do k=1,3
3510 C Derivatives in DC(i)
3511 cgrad            ghalf1=0.5d0*agg(k,1)
3512 cgrad            ghalf2=0.5d0*agg(k,2)
3513 cgrad            ghalf3=0.5d0*agg(k,3)
3514 cgrad            ghalf4=0.5d0*agg(k,4)
3515             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3516      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3517             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3518      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3519             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3520      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3521             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3522      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3523 C Derivatives in DC(i+1)
3524             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3525      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3526             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3527      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3528             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3529      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3530             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3531      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3532 C Derivatives in DC(j)
3533             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3534      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3535             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3536      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3537             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3538      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3539             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3540      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3541 C Derivatives in DC(j+1) or DC(nres-1)
3542             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3543      &      -3.0d0*vryg(k,3)*ury)
3544             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3545      &      -3.0d0*vrzg(k,3)*ury)
3546             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3547      &      -3.0d0*vryg(k,3)*urz)
3548             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3549      &      -3.0d0*vrzg(k,3)*urz)
3550 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3551 cgrad              do l=1,4
3552 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3553 cgrad              enddo
3554 cgrad            endif
3555           enddo
3556           acipa(1,1)=a22
3557           acipa(1,2)=a23
3558           acipa(2,1)=a32
3559           acipa(2,2)=a33
3560           a22=-a22
3561           a23=-a23
3562           do l=1,2
3563             do k=1,3
3564               agg(k,l)=-agg(k,l)
3565               aggi(k,l)=-aggi(k,l)
3566               aggi1(k,l)=-aggi1(k,l)
3567               aggj(k,l)=-aggj(k,l)
3568               aggj1(k,l)=-aggj1(k,l)
3569             enddo
3570           enddo
3571           if (j.lt.nres-1) then
3572             a22=-a22
3573             a32=-a32
3574             do l=1,3,2
3575               do k=1,3
3576                 agg(k,l)=-agg(k,l)
3577                 aggi(k,l)=-aggi(k,l)
3578                 aggi1(k,l)=-aggi1(k,l)
3579                 aggj(k,l)=-aggj(k,l)
3580                 aggj1(k,l)=-aggj1(k,l)
3581               enddo
3582             enddo
3583           else
3584             a22=-a22
3585             a23=-a23
3586             a32=-a32
3587             a33=-a33
3588             do l=1,4
3589               do k=1,3
3590                 agg(k,l)=-agg(k,l)
3591                 aggi(k,l)=-aggi(k,l)
3592                 aggi1(k,l)=-aggi1(k,l)
3593                 aggj(k,l)=-aggj(k,l)
3594                 aggj1(k,l)=-aggj1(k,l)
3595               enddo
3596             enddo
3597           endif
3598           ENDIF ! WCORR
3599           IF (wel_loc.gt.0.0d0) THEN
3600 C Contribution to the local-electrostatic energy coming from the i-j pair
3601           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3602      &     +a33*muij(4)
3603 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3604
3605           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3606      &            'eelloc',i,j,eel_loc_ij
3607
3608           eel_loc=eel_loc+eel_loc_ij
3609 C Partial derivatives in virtual-bond dihedral angles gamma
3610           if (i.gt.1)
3611      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3612      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3613      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3614           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3615      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3616      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3617 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3618           do l=1,3
3619             ggg(l)=agg(l,1)*muij(1)+
3620      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3621             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3622             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3623 cgrad            ghalf=0.5d0*ggg(l)
3624 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3625 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3626           enddo
3627 cgrad          do k=i+1,j2
3628 cgrad            do l=1,3
3629 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3630 cgrad            enddo
3631 cgrad          enddo
3632 C Remaining derivatives of eello
3633           do l=1,3
3634             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3635      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3636             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3637      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3638             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3639      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3640             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3641      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3642           enddo
3643           ENDIF
3644 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3645 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3646           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3647      &       .and. num_conti.le.maxconts) then
3648 c            write (iout,*) i,j," entered corr"
3649 C
3650 C Calculate the contact function. The ith column of the array JCONT will
3651 C contain the numbers of atoms that make contacts with the atom I (of numbers
3652 C greater than I). The arrays FACONT and GACONT will contain the values of
3653 C the contact function and its derivative.
3654 c           r0ij=1.02D0*rpp(iteli,itelj)
3655 c           r0ij=1.11D0*rpp(iteli,itelj)
3656             r0ij=2.20D0*rpp(iteli,itelj)
3657 c           r0ij=1.55D0*rpp(iteli,itelj)
3658             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3659             if (fcont.gt.0.0D0) then
3660               num_conti=num_conti+1
3661               if (num_conti.gt.maxconts) then
3662                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3663      &                         ' will skip next contacts for this conf.'
3664               else
3665                 jcont_hb(num_conti,i)=j
3666 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3667 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3668                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3669      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3670 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3671 C  terms.
3672                 d_cont(num_conti,i)=rij
3673 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3674 C     --- Electrostatic-interaction matrix ---
3675                 a_chuj(1,1,num_conti,i)=a22
3676                 a_chuj(1,2,num_conti,i)=a23
3677                 a_chuj(2,1,num_conti,i)=a32
3678                 a_chuj(2,2,num_conti,i)=a33
3679 C     --- Gradient of rij
3680                 do kkk=1,3
3681                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3682                 enddo
3683                 kkll=0
3684                 do k=1,2
3685                   do l=1,2
3686                     kkll=kkll+1
3687                     do m=1,3
3688                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3689                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3690                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3691                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3692                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3693                     enddo
3694                   enddo
3695                 enddo
3696                 ENDIF
3697                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3698 C Calculate contact energies
3699                 cosa4=4.0D0*cosa
3700                 wij=cosa-3.0D0*cosb*cosg
3701                 cosbg1=cosb+cosg
3702                 cosbg2=cosb-cosg
3703 c               fac3=dsqrt(-ael6i)/r0ij**3
3704                 fac3=dsqrt(-ael6i)*r3ij
3705 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3706                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3707                 if (ees0tmp.gt.0) then
3708                   ees0pij=dsqrt(ees0tmp)
3709                 else
3710                   ees0pij=0
3711                 endif
3712 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3713                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3714                 if (ees0tmp.gt.0) then
3715                   ees0mij=dsqrt(ees0tmp)
3716                 else
3717                   ees0mij=0
3718                 endif
3719 c               ees0mij=0.0D0
3720                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3721                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3722 C Diagnostics. Comment out or remove after debugging!
3723 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3724 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3725 c               ees0m(num_conti,i)=0.0D0
3726 C End diagnostics.
3727 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3728 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3729 C Angular derivatives of the contact function
3730                 ees0pij1=fac3/ees0pij
3731                 ees0mij1=fac3/ees0mij
3732                 fac3p=-3.0D0*fac3*rrmij
3733                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3734                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3735 c               ees0mij1=0.0D0
3736                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3737                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3738                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3739                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3740                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3741                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3742                 ecosap=ecosa1+ecosa2
3743                 ecosbp=ecosb1+ecosb2
3744                 ecosgp=ecosg1+ecosg2
3745                 ecosam=ecosa1-ecosa2
3746                 ecosbm=ecosb1-ecosb2
3747                 ecosgm=ecosg1-ecosg2
3748 C Diagnostics
3749 c               ecosap=ecosa1
3750 c               ecosbp=ecosb1
3751 c               ecosgp=ecosg1
3752 c               ecosam=0.0D0
3753 c               ecosbm=0.0D0
3754 c               ecosgm=0.0D0
3755 C End diagnostics
3756                 facont_hb(num_conti,i)=fcont
3757                 fprimcont=fprimcont/rij
3758 cd              facont_hb(num_conti,i)=1.0D0
3759 C Following line is for diagnostics.
3760 cd              fprimcont=0.0D0
3761                 do k=1,3
3762                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3763                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3764                 enddo
3765                 do k=1,3
3766                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3767                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3768                 enddo
3769                 gggp(1)=gggp(1)+ees0pijp*xj
3770                 gggp(2)=gggp(2)+ees0pijp*yj
3771                 gggp(3)=gggp(3)+ees0pijp*zj
3772                 gggm(1)=gggm(1)+ees0mijp*xj
3773                 gggm(2)=gggm(2)+ees0mijp*yj
3774                 gggm(3)=gggm(3)+ees0mijp*zj
3775 C Derivatives due to the contact function
3776                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3777                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3778                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3779                 do k=1,3
3780 c
3781 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3782 c          following the change of gradient-summation algorithm.
3783 c
3784 cgrad                  ghalfp=0.5D0*gggp(k)
3785 cgrad                  ghalfm=0.5D0*gggm(k)
3786                   gacontp_hb1(k,num_conti,i)=!ghalfp
3787      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3788      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3789                   gacontp_hb2(k,num_conti,i)=!ghalfp
3790      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3791      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3792                   gacontp_hb3(k,num_conti,i)=gggp(k)
3793                   gacontm_hb1(k,num_conti,i)=!ghalfm
3794      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3795      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3796                   gacontm_hb2(k,num_conti,i)=!ghalfm
3797      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3798      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3799                   gacontm_hb3(k,num_conti,i)=gggm(k)
3800                 enddo
3801 C Diagnostics. Comment out or remove after debugging!
3802 cdiag           do k=1,3
3803 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3804 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3805 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3806 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3807 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3808 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3809 cdiag           enddo
3810               ENDIF ! wcorr
3811               endif  ! num_conti.le.maxconts
3812             endif  ! fcont.gt.0
3813           endif    ! j.gt.i+1
3814           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3815             do k=1,4
3816               do l=1,3
3817                 ghalf=0.5d0*agg(l,k)
3818                 aggi(l,k)=aggi(l,k)+ghalf
3819                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3820                 aggj(l,k)=aggj(l,k)+ghalf
3821               enddo
3822             enddo
3823             if (j.eq.nres-1 .and. i.lt.j-2) then
3824               do k=1,4
3825                 do l=1,3
3826                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3827                 enddo
3828               enddo
3829             endif
3830           endif
3831 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3832       return
3833       end
3834 C-----------------------------------------------------------------------------
3835       subroutine eturn3(i,eello_turn3)
3836 C Third- and fourth-order contributions from turns
3837       implicit real*8 (a-h,o-z)
3838       include 'DIMENSIONS'
3839       include 'COMMON.IOUNITS'
3840       include 'COMMON.GEO'
3841       include 'COMMON.VAR'
3842       include 'COMMON.LOCAL'
3843       include 'COMMON.CHAIN'
3844       include 'COMMON.DERIV'
3845       include 'COMMON.INTERACT'
3846       include 'COMMON.CONTACTS'
3847       include 'COMMON.TORSION'
3848       include 'COMMON.VECTORS'
3849       include 'COMMON.FFIELD'
3850       include 'COMMON.CONTROL'
3851       dimension ggg(3)
3852       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3853      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3854      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3855       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3856      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3857       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3858      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3859      &    num_conti,j1,j2
3860       j=i+2
3861 c      write (iout,*) "eturn3",i,j,j1,j2
3862       a_temp(1,1)=a22
3863       a_temp(1,2)=a23
3864       a_temp(2,1)=a32
3865       a_temp(2,2)=a33
3866 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3867 C
3868 C               Third-order contributions
3869 C
3870 C                 (i+2)o----(i+3)
3871 C                      | |
3872 C                      | |
3873 C                 (i+1)o----i
3874 C
3875 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3876 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3877         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3878         call transpose2(auxmat(1,1),auxmat1(1,1))
3879         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3880         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3881         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3882      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3883 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3884 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3885 cd     &    ' eello_turn3_num',4*eello_turn3_num
3886 C Derivatives in gamma(i)
3887         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3888         call transpose2(auxmat2(1,1),auxmat3(1,1))
3889         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3890         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3891 C Derivatives in gamma(i+1)
3892         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3893         call transpose2(auxmat2(1,1),auxmat3(1,1))
3894         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3895         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3896      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3897 C Cartesian derivatives
3898         do l=1,3
3899 c            ghalf1=0.5d0*agg(l,1)
3900 c            ghalf2=0.5d0*agg(l,2)
3901 c            ghalf3=0.5d0*agg(l,3)
3902 c            ghalf4=0.5d0*agg(l,4)
3903           a_temp(1,1)=aggi(l,1)!+ghalf1
3904           a_temp(1,2)=aggi(l,2)!+ghalf2
3905           a_temp(2,1)=aggi(l,3)!+ghalf3
3906           a_temp(2,2)=aggi(l,4)!+ghalf4
3907           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3908           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3909      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3910           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3911           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3912           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3913           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3914           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3915           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3916      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3917           a_temp(1,1)=aggj(l,1)!+ghalf1
3918           a_temp(1,2)=aggj(l,2)!+ghalf2
3919           a_temp(2,1)=aggj(l,3)!+ghalf3
3920           a_temp(2,2)=aggj(l,4)!+ghalf4
3921           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3922           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3923      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3924           a_temp(1,1)=aggj1(l,1)
3925           a_temp(1,2)=aggj1(l,2)
3926           a_temp(2,1)=aggj1(l,3)
3927           a_temp(2,2)=aggj1(l,4)
3928           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3929           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3930      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3931         enddo
3932       return
3933       end
3934 C-------------------------------------------------------------------------------
3935       subroutine eturn4(i,eello_turn4)
3936 C Third- and fourth-order contributions from turns
3937       implicit real*8 (a-h,o-z)
3938       include 'DIMENSIONS'
3939       include 'COMMON.IOUNITS'
3940       include 'COMMON.GEO'
3941       include 'COMMON.VAR'
3942       include 'COMMON.LOCAL'
3943       include 'COMMON.CHAIN'
3944       include 'COMMON.DERIV'
3945       include 'COMMON.INTERACT'
3946       include 'COMMON.CONTACTS'
3947       include 'COMMON.TORSION'
3948       include 'COMMON.VECTORS'
3949       include 'COMMON.FFIELD'
3950       include 'COMMON.CONTROL'
3951       dimension ggg(3)
3952       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3953      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3954      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3955       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3956      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3957       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3958      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3959      &    num_conti,j1,j2
3960       j=i+3
3961 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3962 C
3963 C               Fourth-order contributions
3964 C
3965 C                 (i+3)o----(i+4)
3966 C                     /  |
3967 C               (i+2)o   |
3968 C                     \  |
3969 C                 (i+1)o----i
3970 C
3971 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3972 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3973 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3974         a_temp(1,1)=a22
3975         a_temp(1,2)=a23
3976         a_temp(2,1)=a32
3977         a_temp(2,2)=a33
3978         iti1=itortyp(itype(i+1))
3979         iti2=itortyp(itype(i+2))
3980         iti3=itortyp(itype(i+3))
3981 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3982         call transpose2(EUg(1,1,i+1),e1t(1,1))
3983         call transpose2(Eug(1,1,i+2),e2t(1,1))
3984         call transpose2(Eug(1,1,i+3),e3t(1,1))
3985         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3986         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3987         s1=scalar2(b1(1,iti2),auxvec(1))
3988         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3989         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3990         s2=scalar2(b1(1,iti1),auxvec(1))
3991         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3992         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3993         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3994         eello_turn4=eello_turn4-(s1+s2+s3)
3995         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3996      &      'eturn4',i,j,-(s1+s2+s3)
3997 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3998 cd     &    ' eello_turn4_num',8*eello_turn4_num
3999 C Derivatives in gamma(i)
4000         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4001         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4002         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4003         s1=scalar2(b1(1,iti2),auxvec(1))
4004         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4005         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4006         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
4007 C Derivatives in gamma(i+1)
4008         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4009         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4010         s2=scalar2(b1(1,iti1),auxvec(1))
4011         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4012         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4013         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4014         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
4015 C Derivatives in gamma(i+2)
4016         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4017         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4018         s1=scalar2(b1(1,iti2),auxvec(1))
4019         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4020         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4021         s2=scalar2(b1(1,iti1),auxvec(1))
4022         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
4023         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
4024         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4025         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
4026 C Cartesian derivatives
4027 C Derivatives of this turn contributions in DC(i+2)
4028         if (j.lt.nres-1) then
4029           do l=1,3
4030             a_temp(1,1)=agg(l,1)
4031             a_temp(1,2)=agg(l,2)
4032             a_temp(2,1)=agg(l,3)
4033             a_temp(2,2)=agg(l,4)
4034             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4035             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4036             s1=scalar2(b1(1,iti2),auxvec(1))
4037             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4038             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4039             s2=scalar2(b1(1,iti1),auxvec(1))
4040             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4041             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4042             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4043             ggg(l)=-(s1+s2+s3)
4044             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
4045           enddo
4046         endif
4047 C Remaining derivatives of this turn contribution
4048         do l=1,3
4049           a_temp(1,1)=aggi(l,1)
4050           a_temp(1,2)=aggi(l,2)
4051           a_temp(2,1)=aggi(l,3)
4052           a_temp(2,2)=aggi(l,4)
4053           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4054           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4055           s1=scalar2(b1(1,iti2),auxvec(1))
4056           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4057           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4058           s2=scalar2(b1(1,iti1),auxvec(1))
4059           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4060           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4061           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4062           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
4063           a_temp(1,1)=aggi1(l,1)
4064           a_temp(1,2)=aggi1(l,2)
4065           a_temp(2,1)=aggi1(l,3)
4066           a_temp(2,2)=aggi1(l,4)
4067           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4068           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4069           s1=scalar2(b1(1,iti2),auxvec(1))
4070           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4071           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4072           s2=scalar2(b1(1,iti1),auxvec(1))
4073           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4074           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4075           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4076           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
4077           a_temp(1,1)=aggj(l,1)
4078           a_temp(1,2)=aggj(l,2)
4079           a_temp(2,1)=aggj(l,3)
4080           a_temp(2,2)=aggj(l,4)
4081           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4082           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4083           s1=scalar2(b1(1,iti2),auxvec(1))
4084           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4085           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4086           s2=scalar2(b1(1,iti1),auxvec(1))
4087           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4088           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4089           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4090           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
4091           a_temp(1,1)=aggj1(l,1)
4092           a_temp(1,2)=aggj1(l,2)
4093           a_temp(2,1)=aggj1(l,3)
4094           a_temp(2,2)=aggj1(l,4)
4095           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4096           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4097           s1=scalar2(b1(1,iti2),auxvec(1))
4098           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4099           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4100           s2=scalar2(b1(1,iti1),auxvec(1))
4101           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4102           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4103           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4104 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4105           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4106         enddo
4107       return
4108       end
4109 C-----------------------------------------------------------------------------
4110       subroutine vecpr(u,v,w)
4111       implicit real*8(a-h,o-z)
4112       dimension u(3),v(3),w(3)
4113       w(1)=u(2)*v(3)-u(3)*v(2)
4114       w(2)=-u(1)*v(3)+u(3)*v(1)
4115       w(3)=u(1)*v(2)-u(2)*v(1)
4116       return
4117       end
4118 C-----------------------------------------------------------------------------
4119       subroutine unormderiv(u,ugrad,unorm,ungrad)
4120 C This subroutine computes the derivatives of a normalized vector u, given
4121 C the derivatives computed without normalization conditions, ugrad. Returns
4122 C ungrad.
4123       implicit none
4124       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4125       double precision vec(3)
4126       double precision scalar
4127       integer i,j
4128 c      write (2,*) 'ugrad',ugrad
4129 c      write (2,*) 'u',u
4130       do i=1,3
4131         vec(i)=scalar(ugrad(1,i),u(1))
4132       enddo
4133 c      write (2,*) 'vec',vec
4134       do i=1,3
4135         do j=1,3
4136           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4137         enddo
4138       enddo
4139 c      write (2,*) 'ungrad',ungrad
4140       return
4141       end
4142 C-----------------------------------------------------------------------------
4143       subroutine escp_soft_sphere(evdw2,evdw2_14)
4144 C
4145 C This subroutine calculates the excluded-volume interaction energy between
4146 C peptide-group centers and side chains and its gradient in virtual-bond and
4147 C side-chain vectors.
4148 C
4149       implicit real*8 (a-h,o-z)
4150       include 'DIMENSIONS'
4151       include 'COMMON.GEO'
4152       include 'COMMON.VAR'
4153       include 'COMMON.LOCAL'
4154       include 'COMMON.CHAIN'
4155       include 'COMMON.DERIV'
4156       include 'COMMON.INTERACT'
4157       include 'COMMON.FFIELD'
4158       include 'COMMON.IOUNITS'
4159       include 'COMMON.CONTROL'
4160       dimension ggg(3)
4161       evdw2=0.0D0
4162       evdw2_14=0.0d0
4163       r0_scp=4.5d0
4164 cd    print '(a)','Enter ESCP'
4165 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4166       do i=iatscp_s,iatscp_e
4167         iteli=itel(i)
4168         xi=0.5D0*(c(1,i)+c(1,i+1))
4169         yi=0.5D0*(c(2,i)+c(2,i+1))
4170         zi=0.5D0*(c(3,i)+c(3,i+1))
4171
4172         do iint=1,nscp_gr(i)
4173
4174         do j=iscpstart(i,iint),iscpend(i,iint)
4175           itypj=itype(j)
4176 C Uncomment following three lines for SC-p interactions
4177 c         xj=c(1,nres+j)-xi
4178 c         yj=c(2,nres+j)-yi
4179 c         zj=c(3,nres+j)-zi
4180 C Uncomment following three lines for Ca-p interactions
4181           xj=c(1,j)-xi
4182           yj=c(2,j)-yi
4183           zj=c(3,j)-zi
4184           rij=xj*xj+yj*yj+zj*zj
4185           r0ij=r0_scp
4186           r0ijsq=r0ij*r0ij
4187           if (rij.lt.r0ijsq) then
4188             evdwij=0.25d0*(rij-r0ijsq)**2
4189             fac=rij-r0ijsq
4190           else
4191             evdwij=0.0d0
4192             fac=0.0d0
4193           endif
4194           evdw2=evdw2+evdwij
4195 C
4196 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4197 C
4198           ggg(1)=xj*fac
4199           ggg(2)=yj*fac
4200           ggg(3)=zj*fac
4201 cgrad          if (j.lt.i) then
4202 cd          write (iout,*) 'j<i'
4203 C Uncomment following three lines for SC-p interactions
4204 c           do k=1,3
4205 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4206 c           enddo
4207 cgrad          else
4208 cd          write (iout,*) 'j>i'
4209 cgrad            do k=1,3
4210 cgrad              ggg(k)=-ggg(k)
4211 C Uncomment following line for SC-p interactions
4212 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4213 cgrad            enddo
4214 cgrad          endif
4215 cgrad          do k=1,3
4216 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4217 cgrad          enddo
4218 cgrad          kstart=min0(i+1,j)
4219 cgrad          kend=max0(i-1,j-1)
4220 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4221 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4222 cgrad          do k=kstart,kend
4223 cgrad            do l=1,3
4224 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4225 cgrad            enddo
4226 cgrad          enddo
4227           do k=1,3
4228             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4229             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4230           enddo
4231         enddo
4232
4233         enddo ! iint
4234       enddo ! i
4235       return
4236       end
4237 C-----------------------------------------------------------------------------
4238       subroutine escp(evdw2,evdw2_14)
4239 C
4240 C This subroutine calculates the excluded-volume interaction energy between
4241 C peptide-group centers and side chains and its gradient in virtual-bond and
4242 C side-chain vectors.
4243 C
4244       implicit real*8 (a-h,o-z)
4245       include 'DIMENSIONS'
4246       include 'COMMON.GEO'
4247       include 'COMMON.VAR'
4248       include 'COMMON.LOCAL'
4249       include 'COMMON.CHAIN'
4250       include 'COMMON.DERIV'
4251       include 'COMMON.INTERACT'
4252       include 'COMMON.FFIELD'
4253       include 'COMMON.IOUNITS'
4254       include 'COMMON.CONTROL'
4255       dimension ggg(3)
4256       evdw2=0.0D0
4257       evdw2_14=0.0d0
4258 cd    print '(a)','Enter ESCP'
4259 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4260       do i=iatscp_s,iatscp_e
4261         iteli=itel(i)
4262         xi=0.5D0*(c(1,i)+c(1,i+1))
4263         yi=0.5D0*(c(2,i)+c(2,i+1))
4264         zi=0.5D0*(c(3,i)+c(3,i+1))
4265
4266         do iint=1,nscp_gr(i)
4267
4268         do j=iscpstart(i,iint),iscpend(i,iint)
4269           itypj=itype(j)
4270 C Uncomment following three lines for SC-p interactions
4271 c         xj=c(1,nres+j)-xi
4272 c         yj=c(2,nres+j)-yi
4273 c         zj=c(3,nres+j)-zi
4274 C Uncomment following three lines for Ca-p interactions
4275           xj=c(1,j)-xi
4276           yj=c(2,j)-yi
4277           zj=c(3,j)-zi
4278           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4279           fac=rrij**expon2
4280           e1=fac*fac*aad(itypj,iteli)
4281           e2=fac*bad(itypj,iteli)
4282           if (iabs(j-i) .le. 2) then
4283             e1=scal14*e1
4284             e2=scal14*e2
4285             evdw2_14=evdw2_14+e1+e2
4286           endif
4287           evdwij=e1+e2
4288           evdw2=evdw2+evdwij
4289           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4290      &        'evdw2',i,j,evdwij
4291 C
4292 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4293 C
4294           fac=-(evdwij+e1)*rrij
4295           ggg(1)=xj*fac
4296           ggg(2)=yj*fac
4297           ggg(3)=zj*fac
4298 cgrad          if (j.lt.i) then
4299 cd          write (iout,*) 'j<i'
4300 C Uncomment following three lines for SC-p interactions
4301 c           do k=1,3
4302 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4303 c           enddo
4304 cgrad          else
4305 cd          write (iout,*) 'j>i'
4306 cgrad            do k=1,3
4307 cgrad              ggg(k)=-ggg(k)
4308 C Uncomment following line for SC-p interactions
4309 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4310 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4311 cgrad            enddo
4312 cgrad          endif
4313 cgrad          do k=1,3
4314 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4315 cgrad          enddo
4316 cgrad          kstart=min0(i+1,j)
4317 cgrad          kend=max0(i-1,j-1)
4318 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4319 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4320 cgrad          do k=kstart,kend
4321 cgrad            do l=1,3
4322 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4323 cgrad            enddo
4324 cgrad          enddo
4325           do k=1,3
4326             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4327             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4328           enddo
4329         enddo
4330
4331         enddo ! iint
4332       enddo ! i
4333       do i=1,nct
4334         do j=1,3
4335           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4336           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4337           gradx_scp(j,i)=expon*gradx_scp(j,i)
4338         enddo
4339       enddo
4340 C******************************************************************************
4341 C
4342 C                              N O T E !!!
4343 C
4344 C To save time the factor EXPON has been extracted from ALL components
4345 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4346 C use!
4347 C
4348 C******************************************************************************
4349       return
4350       end
4351 C--------------------------------------------------------------------------
4352       subroutine edis(ehpb)
4353 C
4354 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4355 C
4356       implicit real*8 (a-h,o-z)
4357       include 'DIMENSIONS'
4358       include 'COMMON.SBRIDGE'
4359       include 'COMMON.CHAIN'
4360       include 'COMMON.DERIV'
4361       include 'COMMON.VAR'
4362       include 'COMMON.INTERACT'
4363       include 'COMMON.IOUNITS'
4364       dimension ggg(3)
4365       ehpb=0.0D0
4366 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4367 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4368       if (link_end.eq.0) return
4369       do i=link_start,link_end
4370 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4371 C CA-CA distance used in regularization of structure.
4372         ii=ihpb(i)
4373         jj=jhpb(i)
4374 C iii and jjj point to the residues for which the distance is assigned.
4375         if (ii.gt.nres) then
4376           iii=ii-nres
4377           jjj=jj-nres
4378         else
4379           iii=ii
4380           jjj=jj
4381         endif
4382 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4383 c     &    dhpb(i),dhpb1(i),forcon(i)
4384 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4385 C    distance and angle dependent SS bond potential.
4386 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4387 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4388         if (.not.dyn_ss .and. i.le.nss) then
4389 C 15/02/13 CC dynamic SSbond - additional check
4390          if (ii.gt.nres
4391      &       .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4392           call ssbond_ene(iii,jjj,eij)
4393           ehpb=ehpb+2*eij
4394          endif
4395 cd          write (iout,*) "eij",eij
4396         else if (ii.gt.nres .and. jj.gt.nres) then
4397 c Restraints from contact prediction
4398           dd=dist(ii,jj)
4399           if (dhpb1(i).gt.0.0d0) then
4400             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4401             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4402 c            write (iout,*) "beta nmr",
4403 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4404           else
4405             dd=dist(ii,jj)
4406             rdis=dd-dhpb(i)
4407 C Get the force constant corresponding to this distance.
4408             waga=forcon(i)
4409 C Calculate the contribution to energy.
4410             ehpb=ehpb+waga*rdis*rdis
4411 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
4412 C
4413 C Evaluate gradient.
4414 C
4415             fac=waga*rdis/dd
4416           endif
4417           do j=1,3
4418             ggg(j)=fac*(c(j,jj)-c(j,ii))
4419           enddo
4420           do j=1,3
4421             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4422             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4423           enddo
4424           do k=1,3
4425             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4426             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4427           enddo
4428         else
4429 C Calculate the distance between the two points and its difference from the
4430 C target distance.
4431           dd=dist(ii,jj)
4432           if (dhpb1(i).gt.0.0d0) then
4433             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4434             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4435 c            write (iout,*) "alph nmr",
4436 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4437           else
4438             rdis=dd-dhpb(i)
4439 C Get the force constant corresponding to this distance.
4440             waga=forcon(i)
4441 C Calculate the contribution to energy.
4442             ehpb=ehpb+waga*rdis*rdis
4443 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
4444 C
4445 C Evaluate gradient.
4446 C
4447             fac=waga*rdis/dd
4448           endif
4449 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4450 cd   &   ' waga=',waga,' fac=',fac
4451             do j=1,3
4452               ggg(j)=fac*(c(j,jj)-c(j,ii))
4453             enddo
4454 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4455 C If this is a SC-SC distance, we need to calculate the contributions to the
4456 C Cartesian gradient in the SC vectors (ghpbx).
4457           if (iii.lt.ii) then
4458           do j=1,3
4459             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4460             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4461           enddo
4462           endif
4463 cgrad        do j=iii,jjj-1
4464 cgrad          do k=1,3
4465 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4466 cgrad          enddo
4467 cgrad        enddo
4468           do k=1,3
4469             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4470             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4471           enddo
4472         endif
4473       enddo
4474       ehpb=0.5D0*ehpb
4475       return
4476       end
4477 C--------------------------------------------------------------------------
4478       subroutine ssbond_ene(i,j,eij)
4479 C
4480 C Calculate the distance and angle dependent SS-bond potential energy
4481 C using a free-energy function derived based on RHF/6-31G** ab initio
4482 C calculations of diethyl disulfide.
4483 C
4484 C A. Liwo and U. Kozlowska, 11/24/03
4485 C
4486       implicit real*8 (a-h,o-z)
4487       include 'DIMENSIONS'
4488       include 'COMMON.SBRIDGE'
4489       include 'COMMON.CHAIN'
4490       include 'COMMON.DERIV'
4491       include 'COMMON.LOCAL'
4492       include 'COMMON.INTERACT'
4493       include 'COMMON.VAR'
4494       include 'COMMON.IOUNITS'
4495       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4496       itypi=itype(i)
4497       xi=c(1,nres+i)
4498       yi=c(2,nres+i)
4499       zi=c(3,nres+i)
4500       dxi=dc_norm(1,nres+i)
4501       dyi=dc_norm(2,nres+i)
4502       dzi=dc_norm(3,nres+i)
4503 c      dsci_inv=dsc_inv(itypi)
4504       dsci_inv=vbld_inv(nres+i)
4505       itypj=itype(j)
4506 c      dscj_inv=dsc_inv(itypj)
4507       dscj_inv=vbld_inv(nres+j)
4508       xj=c(1,nres+j)-xi
4509       yj=c(2,nres+j)-yi
4510       zj=c(3,nres+j)-zi
4511       dxj=dc_norm(1,nres+j)
4512       dyj=dc_norm(2,nres+j)
4513       dzj=dc_norm(3,nres+j)
4514       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4515       rij=dsqrt(rrij)
4516       erij(1)=xj*rij
4517       erij(2)=yj*rij
4518       erij(3)=zj*rij
4519       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4520       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4521       om12=dxi*dxj+dyi*dyj+dzi*dzj
4522       do k=1,3
4523         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4524         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4525       enddo
4526       rij=1.0d0/rij
4527       deltad=rij-d0cm
4528       deltat1=1.0d0-om1
4529       deltat2=1.0d0+om2
4530       deltat12=om2-om1+2.0d0
4531       cosphi=om12-om1*om2
4532       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4533      &  +akct*deltad*deltat12+ebr
4534      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4535 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4536 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4537 c     &  " deltat12",deltat12," eij",eij
4538       ed=2*akcm*deltad+akct*deltat12
4539       pom1=akct*deltad
4540       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4541       eom1=-2*akth*deltat1-pom1-om2*pom2
4542       eom2= 2*akth*deltat2+pom1-om1*pom2
4543       eom12=pom2
4544       do k=1,3
4545         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4546         ghpbx(k,i)=ghpbx(k,i)-ggk
4547      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4548      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4549         ghpbx(k,j)=ghpbx(k,j)+ggk
4550      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4551      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4552         ghpbc(k,i)=ghpbc(k,i)-ggk
4553         ghpbc(k,j)=ghpbc(k,j)+ggk
4554       enddo
4555 C
4556 C Calculate the components of the gradient in DC and X
4557 C
4558 cgrad      do k=i,j-1
4559 cgrad        do l=1,3
4560 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4561 cgrad        enddo
4562 cgrad      enddo
4563       return
4564       end
4565 C--------------------------------------------------------------------------
4566       subroutine ebond(estr)
4567 c
4568 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4569 c
4570       implicit real*8 (a-h,o-z)
4571       include 'DIMENSIONS'
4572       include 'COMMON.LOCAL'
4573       include 'COMMON.GEO'
4574       include 'COMMON.INTERACT'
4575       include 'COMMON.DERIV'
4576       include 'COMMON.VAR'
4577       include 'COMMON.CHAIN'
4578       include 'COMMON.IOUNITS'
4579       include 'COMMON.NAMES'
4580       include 'COMMON.FFIELD'
4581       include 'COMMON.CONTROL'
4582       include 'COMMON.SETUP'
4583       double precision u(3),ud(3)
4584       estr=0.0d0
4585       do i=ibondp_start,ibondp_end
4586         diff = vbld(i)-vbldp0
4587 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4588         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
4589      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4590         estr=estr+diff*diff
4591         do j=1,3
4592           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4593         enddo
4594 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4595       enddo
4596       estr=0.5d0*AKP*estr
4597 c
4598 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4599 c
4600       do i=ibond_start,ibond_end
4601         iti=itype(i)
4602         if (iti.ne.10) then
4603           nbi=nbondterm(iti)
4604           if (nbi.eq.1) then
4605             diff=vbld(i+nres)-vbldsc0(1,iti)
4606 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4607 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4608             if (energy_dec)  then
4609               write (iout,*)
4610      &         "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4611      &         AKSC(1,iti),AKSC(1,iti)*diff*diff
4612               call flush(iout)
4613             endif
4614             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4615             do j=1,3
4616               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4617             enddo
4618           else
4619             do j=1,nbi
4620               diff=vbld(i+nres)-vbldsc0(j,iti)
4621               ud(j)=aksc(j,iti)*diff
4622               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4623             enddo
4624             uprod=u(1)
4625             do j=2,nbi
4626               uprod=uprod*u(j)
4627             enddo
4628             usum=0.0d0
4629             usumsqder=0.0d0
4630             do j=1,nbi
4631               uprod1=1.0d0
4632               uprod2=1.0d0
4633               do k=1,nbi
4634                 if (k.ne.j) then
4635                   uprod1=uprod1*u(k)
4636                   uprod2=uprod2*u(k)*u(k)
4637                 endif
4638               enddo
4639               usum=usum+uprod1
4640               usumsqder=usumsqder+ud(j)*uprod2
4641             enddo
4642             estr=estr+uprod/usum
4643             do j=1,3
4644              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4645             enddo
4646           endif
4647         endif
4648       enddo
4649       return
4650       end
4651 #ifdef CRYST_THETA
4652 C--------------------------------------------------------------------------
4653       subroutine ebend(etheta)
4654 C
4655 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4656 C angles gamma and its derivatives in consecutive thetas and gammas.
4657 C
4658       implicit real*8 (a-h,o-z)
4659       include 'DIMENSIONS'
4660       include 'COMMON.LOCAL'
4661       include 'COMMON.GEO'
4662       include 'COMMON.INTERACT'
4663       include 'COMMON.DERIV'
4664       include 'COMMON.VAR'
4665       include 'COMMON.CHAIN'
4666       include 'COMMON.IOUNITS'
4667       include 'COMMON.NAMES'
4668       include 'COMMON.FFIELD'
4669       include 'COMMON.CONTROL'
4670       common /calcthet/ term1,term2,termm,diffak,ratak,
4671      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4672      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4673       double precision y(2),z(2)
4674       delta=0.02d0*pi
4675 c      time11=dexp(-2*time)
4676 c      time12=1.0d0
4677       etheta=0.0D0
4678 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4679       do i=ithet_start,ithet_end
4680 C Zero the energy function and its derivative at 0 or pi.
4681         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4682         it=itype(i-1)
4683         if (i.gt.3) then
4684 #ifdef OSF
4685           phii=phi(i)
4686           if (phii.ne.phii) phii=150.0
4687 #else
4688           phii=phi(i)
4689 #endif
4690           y(1)=dcos(phii)
4691           y(2)=dsin(phii)
4692         else
4693           y(1)=0.0D0
4694           y(2)=0.0D0
4695         endif
4696         if (i.lt.nres) then
4697 #ifdef OSF
4698           phii1=phi(i+1)
4699           if (phii1.ne.phii1) phii1=150.0
4700           phii1=pinorm(phii1)
4701           z(1)=cos(phii1)
4702 #else
4703           phii1=phi(i+1)
4704           z(1)=dcos(phii1)
4705 #endif
4706           z(2)=dsin(phii1)
4707         else
4708           z(1)=0.0D0
4709           z(2)=0.0D0
4710         endif
4711 C Calculate the "mean" value of theta from the part of the distribution
4712 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4713 C In following comments this theta will be referred to as t_c.
4714         thet_pred_mean=0.0d0
4715         do k=1,2
4716           athetk=athet(k,it)
4717           bthetk=bthet(k,it)
4718           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4719         enddo
4720         dthett=thet_pred_mean*ssd
4721         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4722 C Derivatives of the "mean" values in gamma1 and gamma2.
4723         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
4724         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
4725         if (theta(i).gt.pi-delta) then
4726           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4727      &         E_tc0)
4728           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4729           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4730           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4731      &        E_theta)
4732           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4733      &        E_tc)
4734         else if (theta(i).lt.delta) then
4735           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4736           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4737           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4738      &        E_theta)
4739           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4740           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4741      &        E_tc)
4742         else
4743           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4744      &        E_theta,E_tc)
4745         endif
4746         etheta=etheta+ethetai
4747         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4748      &      'ebend',i,ethetai
4749         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4750         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4751         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
4752       enddo
4753 C Ufff.... We've done all this!!!
4754       return
4755       end
4756 C---------------------------------------------------------------------------
4757       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4758      &     E_tc)
4759       implicit real*8 (a-h,o-z)
4760       include 'DIMENSIONS'
4761       include 'COMMON.LOCAL'
4762       include 'COMMON.IOUNITS'
4763       common /calcthet/ term1,term2,termm,diffak,ratak,
4764      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4765      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4766 C Calculate the contributions to both Gaussian lobes.
4767 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4768 C The "polynomial part" of the "standard deviation" of this part of
4769 C the distribution.
4770         sig=polthet(3,it)
4771         do j=2,0,-1
4772           sig=sig*thet_pred_mean+polthet(j,it)
4773         enddo
4774 C Derivative of the "interior part" of the "standard deviation of the"
4775 C gamma-dependent Gaussian lobe in t_c.
4776         sigtc=3*polthet(3,it)
4777         do j=2,1,-1
4778           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4779         enddo
4780         sigtc=sig*sigtc
4781 C Set the parameters of both Gaussian lobes of the distribution.
4782 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4783         fac=sig*sig+sigc0(it)
4784         sigcsq=fac+fac
4785         sigc=1.0D0/sigcsq
4786 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4787         sigsqtc=-4.0D0*sigcsq*sigtc
4788 c       print *,i,sig,sigtc,sigsqtc
4789 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4790         sigtc=-sigtc/(fac*fac)
4791 C Following variable is sigma(t_c)**(-2)
4792         sigcsq=sigcsq*sigcsq
4793         sig0i=sig0(it)
4794         sig0inv=1.0D0/sig0i**2
4795         delthec=thetai-thet_pred_mean
4796         delthe0=thetai-theta0i
4797         term1=-0.5D0*sigcsq*delthec*delthec
4798         term2=-0.5D0*sig0inv*delthe0*delthe0
4799 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4800 C NaNs in taking the logarithm. We extract the largest exponent which is added
4801 C to the energy (this being the log of the distribution) at the end of energy
4802 C term evaluation for this virtual-bond angle.
4803         if (term1.gt.term2) then
4804           termm=term1
4805           term2=dexp(term2-termm)
4806           term1=1.0d0
4807         else
4808           termm=term2
4809           term1=dexp(term1-termm)
4810           term2=1.0d0
4811         endif
4812 C The ratio between the gamma-independent and gamma-dependent lobes of
4813 C the distribution is a Gaussian function of thet_pred_mean too.
4814         diffak=gthet(2,it)-thet_pred_mean
4815         ratak=diffak/gthet(3,it)**2
4816         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4817 C Let's differentiate it in thet_pred_mean NOW.
4818         aktc=ak*ratak
4819 C Now put together the distribution terms to make complete distribution.
4820         termexp=term1+ak*term2
4821         termpre=sigc+ak*sig0i
4822 C Contribution of the bending energy from this theta is just the -log of
4823 C the sum of the contributions from the two lobes and the pre-exponential
4824 C factor. Simple enough, isn't it?
4825         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4826 C NOW the derivatives!!!
4827 C 6/6/97 Take into account the deformation.
4828         E_theta=(delthec*sigcsq*term1
4829      &       +ak*delthe0*sig0inv*term2)/termexp
4830         E_tc=((sigtc+aktc*sig0i)/termpre
4831      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4832      &       aktc*term2)/termexp)
4833       return
4834       end
4835 c-----------------------------------------------------------------------------
4836       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4837       implicit real*8 (a-h,o-z)
4838       include 'DIMENSIONS'
4839       include 'COMMON.LOCAL'
4840       include 'COMMON.IOUNITS'
4841       common /calcthet/ term1,term2,termm,diffak,ratak,
4842      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4843      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4844       delthec=thetai-thet_pred_mean
4845       delthe0=thetai-theta0i
4846 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4847       t3 = thetai-thet_pred_mean
4848       t6 = t3**2
4849       t9 = term1
4850       t12 = t3*sigcsq
4851       t14 = t12+t6*sigsqtc
4852       t16 = 1.0d0
4853       t21 = thetai-theta0i
4854       t23 = t21**2
4855       t26 = term2
4856       t27 = t21*t26
4857       t32 = termexp
4858       t40 = t32**2
4859       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4860      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4861      & *(-t12*t9-ak*sig0inv*t27)
4862       return
4863       end
4864 #else
4865 C--------------------------------------------------------------------------
4866       subroutine ebend(etheta)
4867 C
4868 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4869 C angles gamma and its derivatives in consecutive thetas and gammas.
4870 C ab initio-derived potentials from
4871 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4872 C
4873       implicit real*8 (a-h,o-z)
4874       include 'DIMENSIONS'
4875       include 'COMMON.LOCAL'
4876       include 'COMMON.GEO'
4877       include 'COMMON.INTERACT'
4878       include 'COMMON.DERIV'
4879       include 'COMMON.VAR'
4880       include 'COMMON.CHAIN'
4881       include 'COMMON.IOUNITS'
4882       include 'COMMON.NAMES'
4883       include 'COMMON.FFIELD'
4884       include 'COMMON.CONTROL'
4885       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4886      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4887      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4888      & sinph1ph2(maxdouble,maxdouble)
4889       logical lprn /.false./, lprn1 /.false./
4890       etheta=0.0D0
4891 c      write (iout,*) "EBEND ithet_start",ithet_start,
4892 c     &     " ithet_end",ithet_end
4893       do i=ithet_start,ithet_end
4894         if ((itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
4895      &(itype(i).eq.ntyp1)) cycle
4896         dethetai=0.0d0
4897         dephii=0.0d0
4898         dephii1=0.0d0
4899         theti2=0.5d0*theta(i)
4900         ityp2=ithetyp(itype(i-1))
4901         do k=1,nntheterm
4902           coskt(k)=dcos(k*theti2)
4903           sinkt(k)=dsin(k*theti2)
4904         enddo
4905 C        if (i.gt.3) then
4906         if (i.gt.3 .and. itype(imax0(i-3,1)).ne.ntyp1) then
4907 #ifdef OSF
4908           phii=phi(i)
4909           if (phii.ne.phii) phii=150.0
4910 #else
4911           phii=phi(i)
4912 #endif
4913           ityp1=ithetyp(itype(i-2))
4914           do k=1,nsingle
4915             cosph1(k)=dcos(k*phii)
4916             sinph1(k)=dsin(k*phii)
4917           enddo
4918         else
4919           phii=0.0d0
4920           ityp1=ithetyp(itype(i-2))
4921           do k=1,nsingle
4922             cosph1(k)=0.0d0
4923             sinph1(k)=0.0d0
4924           enddo
4925         endif
4926         if ((i.lt.nres).and. itype(i+1).ne.ntyp1) then
4927 #ifdef OSF
4928           phii1=phi(i+1)
4929           if (phii1.ne.phii1) phii1=150.0
4930           phii1=pinorm(phii1)
4931 #else
4932           phii1=phi(i+1)
4933 #endif
4934           ityp3=ithetyp(itype(i))
4935           do k=1,nsingle
4936             cosph2(k)=dcos(k*phii1)
4937             sinph2(k)=dsin(k*phii1)
4938           enddo
4939         else
4940           phii1=0.0d0
4941           ityp3=ithetyp(itype(i))
4942           do k=1,nsingle
4943             cosph2(k)=0.0d0
4944             sinph2(k)=0.0d0
4945           enddo
4946         endif
4947         ethetai=aa0thet(ityp1,ityp2,ityp3)
4948         do k=1,ndouble
4949           do l=1,k-1
4950             ccl=cosph1(l)*cosph2(k-l)
4951             ssl=sinph1(l)*sinph2(k-l)
4952             scl=sinph1(l)*cosph2(k-l)
4953             csl=cosph1(l)*sinph2(k-l)
4954             cosph1ph2(l,k)=ccl-ssl
4955             cosph1ph2(k,l)=ccl+ssl
4956             sinph1ph2(l,k)=scl+csl
4957             sinph1ph2(k,l)=scl-csl
4958           enddo
4959         enddo
4960         if (lprn) then
4961         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4962      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4963         write (iout,*) "coskt and sinkt"
4964         do k=1,nntheterm
4965           write (iout,*) k,coskt(k),sinkt(k)
4966         enddo
4967         endif
4968         do k=1,ntheterm
4969           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4970           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4971      &      *coskt(k)
4972           if (lprn)
4973      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4974      &     " ethetai",ethetai
4975         enddo
4976         if (lprn) then
4977         write (iout,*) "cosph and sinph"
4978         do k=1,nsingle
4979           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4980         enddo
4981         write (iout,*) "cosph1ph2 and sinph2ph2"
4982         do k=2,ndouble
4983           do l=1,k-1
4984             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4985      &         sinph1ph2(l,k),sinph1ph2(k,l)
4986           enddo
4987         enddo
4988         write(iout,*) "ethetai",ethetai
4989         endif
4990         do m=1,ntheterm2
4991           do k=1,nsingle
4992             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4993      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4994      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4995      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4996             ethetai=ethetai+sinkt(m)*aux
4997             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4998             dephii=dephii+k*sinkt(m)*(
4999      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
5000      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
5001             dephii1=dephii1+k*sinkt(m)*(
5002      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
5003      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
5004             if (lprn)
5005      &      write (iout,*) "m",m," k",k," bbthet",
5006      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
5007      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
5008      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
5009      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
5010           enddo
5011         enddo
5012         if (lprn)
5013      &  write(iout,*) "ethetai",ethetai
5014         do m=1,ntheterm3
5015           do k=2,ndouble
5016             do l=1,k-1
5017               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
5018      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
5019      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
5020      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
5021               ethetai=ethetai+sinkt(m)*aux
5022               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5023               dephii=dephii+l*sinkt(m)*(
5024      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
5025      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
5026      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
5027      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
5028               dephii1=dephii1+(k-l)*sinkt(m)*(
5029      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
5030      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
5031      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
5032      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
5033               if (lprn) then
5034               write (iout,*) "m",m," k",k," l",l," ffthet",
5035      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
5036      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
5037      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
5038      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
5039               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5040      &            cosph1ph2(k,l)*sinkt(m),
5041      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5042               endif
5043             enddo
5044           enddo
5045         enddo
5046 10      continue
5047 c        lprn1=.true.
5048         if (lprn1) write (iout,'(a4,i2,3f8.1,9h ethetai ,f10.5)')
5049      &  'ebe', i,theta(i)*rad2deg,phii*rad2deg,
5050      &   phii1*rad2deg,ethetai
5051 c        lprn1=.false.
5052         etheta=etheta+ethetai
5053         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5054      &      'ebend',i,ethetai
5055         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5056         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5057         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
5058       enddo
5059       return
5060       end
5061 #endif
5062 #ifdef CRYST_SC
5063 c-----------------------------------------------------------------------------
5064       subroutine esc(escloc)
5065 C Calculate the local energy of a side chain and its derivatives in the
5066 C corresponding virtual-bond valence angles THETA and the spherical angles
5067 C ALPHA and OMEGA.
5068       implicit real*8 (a-h,o-z)
5069       include 'DIMENSIONS'
5070       include 'COMMON.GEO'
5071       include 'COMMON.LOCAL'
5072       include 'COMMON.VAR'
5073       include 'COMMON.INTERACT'
5074       include 'COMMON.DERIV'
5075       include 'COMMON.CHAIN'
5076       include 'COMMON.IOUNITS'
5077       include 'COMMON.NAMES'
5078       include 'COMMON.FFIELD'
5079       include 'COMMON.CONTROL'
5080       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5081      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5082       common /sccalc/ time11,time12,time112,theti,it,nlobit
5083       delta=0.02d0*pi
5084       escloc=0.0D0
5085 c     write (iout,'(a)') 'ESC'
5086       do i=loc_start,loc_end
5087         it=itype(i)
5088         if (it.eq.10) goto 1
5089         nlobit=nlob(it)
5090 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5091 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5092         theti=theta(i+1)-pipol
5093         x(1)=dtan(theti)
5094         x(2)=alph(i)
5095         x(3)=omeg(i)
5096
5097         if (x(2).gt.pi-delta) then
5098           xtemp(1)=x(1)
5099           xtemp(2)=pi-delta
5100           xtemp(3)=x(3)
5101           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5102           xtemp(2)=pi
5103           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5104           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5105      &        escloci,dersc(2))
5106           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5107      &        ddersc0(1),dersc(1))
5108           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5109      &        ddersc0(3),dersc(3))
5110           xtemp(2)=pi-delta
5111           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5112           xtemp(2)=pi
5113           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5114           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5115      &            dersc0(2),esclocbi,dersc02)
5116           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5117      &            dersc12,dersc01)
5118           call splinthet(x(2),0.5d0*delta,ss,ssd)
5119           dersc0(1)=dersc01
5120           dersc0(2)=dersc02
5121           dersc0(3)=0.0d0
5122           do k=1,3
5123             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5124           enddo
5125           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5126 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5127 c    &             esclocbi,ss,ssd
5128           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5129 c         escloci=esclocbi
5130 c         write (iout,*) escloci
5131         else if (x(2).lt.delta) then
5132           xtemp(1)=x(1)
5133           xtemp(2)=delta
5134           xtemp(3)=x(3)
5135           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5136           xtemp(2)=0.0d0
5137           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5138           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5139      &        escloci,dersc(2))
5140           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5141      &        ddersc0(1),dersc(1))
5142           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5143      &        ddersc0(3),dersc(3))
5144           xtemp(2)=delta
5145           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5146           xtemp(2)=0.0d0
5147           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5148           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5149      &            dersc0(2),esclocbi,dersc02)
5150           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5151      &            dersc12,dersc01)
5152           dersc0(1)=dersc01
5153           dersc0(2)=dersc02
5154           dersc0(3)=0.0d0
5155           call splinthet(x(2),0.5d0*delta,ss,ssd)
5156           do k=1,3
5157             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5158           enddo
5159           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5160 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5161 c    &             esclocbi,ss,ssd
5162           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5163 c         write (iout,*) escloci
5164         else
5165           call enesc(x,escloci,dersc,ddummy,.false.)
5166         endif
5167
5168         escloc=escloc+escloci
5169         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5170      &     'escloc',i,escloci
5171 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5172
5173         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5174      &   wscloc*dersc(1)
5175         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5176         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5177     1   continue
5178       enddo
5179       return
5180       end
5181 C---------------------------------------------------------------------------
5182       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5183       implicit real*8 (a-h,o-z)
5184       include 'DIMENSIONS'
5185       include 'COMMON.GEO'
5186       include 'COMMON.LOCAL'
5187       include 'COMMON.IOUNITS'
5188       common /sccalc/ time11,time12,time112,theti,it,nlobit
5189       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5190       double precision contr(maxlob,-1:1)
5191       logical mixed
5192 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5193         escloc_i=0.0D0
5194         do j=1,3
5195           dersc(j)=0.0D0
5196           if (mixed) ddersc(j)=0.0d0
5197         enddo
5198         x3=x(3)
5199
5200 C Because of periodicity of the dependence of the SC energy in omega we have
5201 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5202 C To avoid underflows, first compute & store the exponents.
5203
5204         do iii=-1,1
5205
5206           x(3)=x3+iii*dwapi
5207
5208           do j=1,nlobit
5209             do k=1,3
5210               z(k)=x(k)-censc(k,j,it)
5211             enddo
5212             do k=1,3
5213               Axk=0.0D0
5214               do l=1,3
5215                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5216               enddo
5217               Ax(k,j,iii)=Axk
5218             enddo
5219             expfac=0.0D0
5220             do k=1,3
5221               expfac=expfac+Ax(k,j,iii)*z(k)
5222             enddo
5223             contr(j,iii)=expfac
5224           enddo ! j
5225
5226         enddo ! iii
5227
5228         x(3)=x3
5229 C As in the case of ebend, we want to avoid underflows in exponentiation and
5230 C subsequent NaNs and INFs in energy calculation.
5231 C Find the largest exponent
5232         emin=contr(1,-1)
5233         do iii=-1,1
5234           do j=1,nlobit
5235             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5236           enddo
5237         enddo
5238         emin=0.5D0*emin
5239 cd      print *,'it=',it,' emin=',emin
5240
5241 C Compute the contribution to SC energy and derivatives
5242         do iii=-1,1
5243
5244           do j=1,nlobit
5245 #ifdef OSF
5246             adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin
5247             if(adexp.ne.adexp) adexp=1.0
5248             expfac=dexp(adexp)
5249 #else
5250             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
5251 #endif
5252 cd          print *,'j=',j,' expfac=',expfac
5253             escloc_i=escloc_i+expfac
5254             do k=1,3
5255               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5256             enddo
5257             if (mixed) then
5258               do k=1,3,2
5259                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5260      &            +gaussc(k,2,j,it))*expfac
5261               enddo
5262             endif
5263           enddo
5264
5265         enddo ! iii
5266
5267         dersc(1)=dersc(1)/cos(theti)**2
5268         ddersc(1)=ddersc(1)/cos(theti)**2
5269         ddersc(3)=ddersc(3)
5270
5271         escloci=-(dlog(escloc_i)-emin)
5272         do j=1,3
5273           dersc(j)=dersc(j)/escloc_i
5274         enddo
5275         if (mixed) then
5276           do j=1,3,2
5277             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5278           enddo
5279         endif
5280       return
5281       end
5282 C------------------------------------------------------------------------------
5283       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5284       implicit real*8 (a-h,o-z)
5285       include 'DIMENSIONS'
5286       include 'COMMON.GEO'
5287       include 'COMMON.LOCAL'
5288       include 'COMMON.IOUNITS'
5289       common /sccalc/ time11,time12,time112,theti,it,nlobit
5290       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5291       double precision contr(maxlob)
5292       logical mixed
5293
5294       escloc_i=0.0D0
5295
5296       do j=1,3
5297         dersc(j)=0.0D0
5298       enddo
5299
5300       do j=1,nlobit
5301         do k=1,2
5302           z(k)=x(k)-censc(k,j,it)
5303         enddo
5304         z(3)=dwapi
5305         do k=1,3
5306           Axk=0.0D0
5307           do l=1,3
5308             Axk=Axk+gaussc(l,k,j,it)*z(l)
5309           enddo
5310           Ax(k,j)=Axk
5311         enddo
5312         expfac=0.0D0
5313         do k=1,3
5314           expfac=expfac+Ax(k,j)*z(k)
5315         enddo
5316         contr(j)=expfac
5317       enddo ! j
5318
5319 C As in the case of ebend, we want to avoid underflows in exponentiation and
5320 C subsequent NaNs and INFs in energy calculation.
5321 C Find the largest exponent
5322       emin=contr(1)
5323       do j=1,nlobit
5324         if (emin.gt.contr(j)) emin=contr(j)
5325       enddo
5326       emin=0.5D0*emin
5327
5328 C Compute the contribution to SC energy and derivatives
5329
5330       dersc12=0.0d0
5331       do j=1,nlobit
5332         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
5333         escloc_i=escloc_i+expfac
5334         do k=1,2
5335           dersc(k)=dersc(k)+Ax(k,j)*expfac
5336         enddo
5337         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5338      &            +gaussc(1,2,j,it))*expfac
5339         dersc(3)=0.0d0
5340       enddo
5341
5342       dersc(1)=dersc(1)/cos(theti)**2
5343       dersc12=dersc12/cos(theti)**2
5344       escloci=-(dlog(escloc_i)-emin)
5345       do j=1,2
5346         dersc(j)=dersc(j)/escloc_i
5347       enddo
5348       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5349       return
5350       end
5351 #else
5352 c----------------------------------------------------------------------------------
5353       subroutine esc(escloc)
5354 C Calculate the local energy of a side chain and its derivatives in the
5355 C corresponding virtual-bond valence angles THETA and the spherical angles
5356 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5357 C added by Urszula Kozlowska. 07/11/2007
5358 C
5359       implicit real*8 (a-h,o-z)
5360       include 'DIMENSIONS'
5361       include 'COMMON.GEO'
5362       include 'COMMON.LOCAL'
5363       include 'COMMON.VAR'
5364       include 'COMMON.SCROT'
5365       include 'COMMON.INTERACT'
5366       include 'COMMON.DERIV'
5367       include 'COMMON.CHAIN'
5368       include 'COMMON.IOUNITS'
5369       include 'COMMON.NAMES'
5370       include 'COMMON.FFIELD'
5371       include 'COMMON.CONTROL'
5372       include 'COMMON.VECTORS'
5373       double precision x_prime(3),y_prime(3),z_prime(3)
5374      &    , sumene,dsc_i,dp2_i,x(65),
5375      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5376      &    de_dxx,de_dyy,de_dzz,de_dt
5377       double precision s1_t,s1_6_t,s2_t,s2_6_t
5378       double precision
5379      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5380      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5381      & dt_dCi(3),dt_dCi1(3)
5382       common /sccalc/ time11,time12,time112,theti,it,nlobit
5383       delta=0.02d0*pi
5384       escloc=0.0D0
5385 c      write(iout,*) "ESC: loc_start",loc_start," loc_end",loc_end
5386       do i=loc_start,loc_end
5387         costtab(i+1) =dcos(theta(i+1))
5388         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5389         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5390         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5391         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5392         cosfac=dsqrt(cosfac2)
5393         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5394         sinfac=dsqrt(sinfac2)
5395         it=itype(i)
5396         if (it.eq.10) goto 1
5397 c
5398 C  Compute the axes of tghe local cartesian coordinates system; store in
5399 c   x_prime, y_prime and z_prime
5400 c
5401         do j=1,3
5402           x_prime(j) = 0.00
5403           y_prime(j) = 0.00
5404           z_prime(j) = 0.00
5405         enddo
5406 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5407 C     &   dc_norm(3,i+nres)
5408         do j = 1,3
5409           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5410           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5411         enddo
5412         do j = 1,3
5413           z_prime(j) = -uz(j,i-1)
5414         enddo
5415 c       write (2,*) "i",i
5416 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5417 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5418 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5419 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5420 c      & " xy",scalar(x_prime(1),y_prime(1)),
5421 c      & " xz",scalar(x_prime(1),z_prime(1)),
5422 c      & " yy",scalar(y_prime(1),y_prime(1)),
5423 c      & " yz",scalar(y_prime(1),z_prime(1)),
5424 c      & " zz",scalar(z_prime(1),z_prime(1))
5425 c
5426 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5427 C to local coordinate system. Store in xx, yy, zz.
5428 c
5429         xx=0.0d0
5430         yy=0.0d0
5431         zz=0.0d0
5432         do j = 1,3
5433           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5434           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5435           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5436         enddo
5437
5438         xxtab(i)=xx
5439         yytab(i)=yy
5440         zztab(i)=zz
5441 C
5442 C Compute the energy of the ith side cbain
5443 C
5444 c        write (2,*) "xx",xx," yy",yy," zz",zz
5445         it=itype(i)
5446         do j = 1,65
5447           x(j) = sc_parmin(j,it)
5448         enddo
5449 #ifdef CHECK_COORD
5450 Cc diagnostics - remove later
5451         xx1 = dcos(alph(2))
5452         yy1 = dsin(alph(2))*dcos(omeg(2))
5453         zz1 = -dsin(alph(2))*dsin(omeg(2))
5454         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5455      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5456      &    xx1,yy1,zz1
5457 C,"  --- ", xx_w,yy_w,zz_w
5458 c end diagnostics
5459 #endif
5460         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5461      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5462      &   + x(10)*yy*zz
5463         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5464      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5465      & + x(20)*yy*zz
5466         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5467      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5468      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5469      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5470      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5471      &  +x(40)*xx*yy*zz
5472         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5473      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5474      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5475      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5476      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5477      &  +x(60)*xx*yy*zz
5478         dsc_i   = 0.743d0+x(61)
5479         dp2_i   = 1.9d0+x(62)
5480         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5481      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5482         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5483      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5484         s1=(1+x(63))/(0.1d0 + dscp1)
5485         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5486         s2=(1+x(65))/(0.1d0 + dscp2)
5487         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5488         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5489      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5490 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5491 c     &   sumene4,
5492 c     &   dscp1,dscp2,sumene
5493 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5494         escloc = escloc + sumene
5495 c        write (2,*) "i",i," escloc",sumene,escloc
5496 #ifdef DEBUG
5497 C
5498 C This section to check the numerical derivatives of the energy of ith side
5499 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5500 C #define DEBUG in the code to turn it on.
5501 C
5502         write (2,*) "sumene               =",sumene
5503         aincr=1.0d-7
5504         xxsave=xx
5505         xx=xx+aincr
5506         write (2,*) xx,yy,zz
5507         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5508         de_dxx_num=(sumenep-sumene)/aincr
5509         xx=xxsave
5510         write (2,*) "xx+ sumene from enesc=",sumenep
5511         yysave=yy
5512         yy=yy+aincr
5513         write (2,*) xx,yy,zz
5514         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5515         de_dyy_num=(sumenep-sumene)/aincr
5516         yy=yysave
5517         write (2,*) "yy+ sumene from enesc=",sumenep
5518         zzsave=zz
5519         zz=zz+aincr
5520         write (2,*) xx,yy,zz
5521         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5522         de_dzz_num=(sumenep-sumene)/aincr
5523         zz=zzsave
5524         write (2,*) "zz+ sumene from enesc=",sumenep
5525         costsave=cost2tab(i+1)
5526         sintsave=sint2tab(i+1)
5527         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5528         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5529         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5530         de_dt_num=(sumenep-sumene)/aincr
5531         write (2,*) " t+ sumene from enesc=",sumenep
5532         cost2tab(i+1)=costsave
5533         sint2tab(i+1)=sintsave
5534 C End of diagnostics section.
5535 #endif
5536 C
5537 C Compute the gradient of esc
5538 C
5539         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5540         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5541         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5542         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5543         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5544         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5545         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5546         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5547         pom1=(sumene3*sint2tab(i+1)+sumene1)
5548      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5549         pom2=(sumene4*cost2tab(i+1)+sumene2)
5550      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5551         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5552         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5553      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5554      &  +x(40)*yy*zz
5555         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5556         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5557      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5558      &  +x(60)*yy*zz
5559         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5560      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5561      &        +(pom1+pom2)*pom_dx
5562 #ifdef DEBUG
5563         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5564 #endif
5565 C
5566         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5567         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5568      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5569      &  +x(40)*xx*zz
5570         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5571         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5572      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5573      &  +x(59)*zz**2 +x(60)*xx*zz
5574         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5575      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5576      &        +(pom1-pom2)*pom_dy
5577 #ifdef DEBUG
5578         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5579 #endif
5580 C
5581         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5582      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5583      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5584      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5585      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5586      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5587      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5588      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5589 #ifdef DEBUG
5590         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5591 #endif
5592 C
5593         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5594      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5595      &  +pom1*pom_dt1+pom2*pom_dt2
5596 #ifdef DEBUG
5597         write(2,*), "de_dt = ", de_dt,de_dt_num
5598 #endif
5599 c
5600 C
5601        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5602        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5603        cosfac2xx=cosfac2*xx
5604        sinfac2yy=sinfac2*yy
5605        do k = 1,3
5606          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5607      &      vbld_inv(i+1)
5608          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5609      &      vbld_inv(i)
5610          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5611          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5612 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5613 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5614 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5615 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5616          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5617          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5618          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5619          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5620          dZZ_Ci1(k)=0.0d0
5621          dZZ_Ci(k)=0.0d0
5622          do j=1,3
5623            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5624            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5625          enddo
5626
5627          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5628          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5629          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5630 c
5631          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5632          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5633        enddo
5634
5635        do k=1,3
5636          dXX_Ctab(k,i)=dXX_Ci(k)
5637          dXX_C1tab(k,i)=dXX_Ci1(k)
5638          dYY_Ctab(k,i)=dYY_Ci(k)
5639          dYY_C1tab(k,i)=dYY_Ci1(k)
5640          dZZ_Ctab(k,i)=dZZ_Ci(k)
5641          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5642          dXX_XYZtab(k,i)=dXX_XYZ(k)
5643          dYY_XYZtab(k,i)=dYY_XYZ(k)
5644          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5645        enddo
5646
5647        do k = 1,3
5648 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5649 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5650 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5651 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5652 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5653 c     &    dt_dci(k)
5654 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5655 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5656          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5657      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5658          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5659      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5660          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5661      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5662        enddo
5663 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5664 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5665
5666 C to check gradient call subroutine check_grad
5667
5668     1 continue
5669       enddo
5670       return
5671       end
5672 c------------------------------------------------------------------------------
5673       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5674       implicit none
5675       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5676      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5677       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5678      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5679      &   + x(10)*yy*zz
5680       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5681      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5682      & + x(20)*yy*zz
5683       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5684      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5685      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5686      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5687      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5688      &  +x(40)*xx*yy*zz
5689       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5690      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5691      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5692      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5693      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5694      &  +x(60)*xx*yy*zz
5695       dsc_i   = 0.743d0+x(61)
5696       dp2_i   = 1.9d0+x(62)
5697       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5698      &          *(xx*cost2+yy*sint2))
5699       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5700      &          *(xx*cost2-yy*sint2))
5701       s1=(1+x(63))/(0.1d0 + dscp1)
5702       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5703       s2=(1+x(65))/(0.1d0 + dscp2)
5704       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5705       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5706      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5707       enesc=sumene
5708       return
5709       end
5710 #endif
5711 c------------------------------------------------------------------------------
5712       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5713 C
5714 C This procedure calculates two-body contact function g(rij) and its derivative:
5715 C
5716 C           eps0ij                                     !       x < -1
5717 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5718 C            0                                         !       x > 1
5719 C
5720 C where x=(rij-r0ij)/delta
5721 C
5722 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5723 C
5724       implicit none
5725       double precision rij,r0ij,eps0ij,fcont,fprimcont
5726       double precision x,x2,x4,delta
5727 c     delta=0.02D0*r0ij
5728 c      delta=0.2D0*r0ij
5729       x=(rij-r0ij)/delta
5730       if (x.lt.-1.0D0) then
5731         fcont=eps0ij
5732         fprimcont=0.0D0
5733       else if (x.le.1.0D0) then
5734         x2=x*x
5735         x4=x2*x2
5736         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5737         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5738       else
5739         fcont=0.0D0
5740         fprimcont=0.0D0
5741       endif
5742       return
5743       end
5744 c------------------------------------------------------------------------------
5745       subroutine splinthet(theti,delta,ss,ssder)
5746       implicit real*8 (a-h,o-z)
5747       include 'DIMENSIONS'
5748       include 'COMMON.VAR'
5749       include 'COMMON.GEO'
5750       thetup=pi-delta
5751       thetlow=delta
5752       if (theti.gt.pipol) then
5753         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5754       else
5755         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5756         ssder=-ssder
5757       endif
5758       return
5759       end
5760 c------------------------------------------------------------------------------
5761       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5762       implicit none
5763       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5764       double precision ksi,ksi2,ksi3,a1,a2,a3
5765       a1=fprim0*delta/(f1-f0)
5766       a2=3.0d0-2.0d0*a1
5767       a3=a1-2.0d0
5768       ksi=(x-x0)/delta
5769       ksi2=ksi*ksi
5770       ksi3=ksi2*ksi
5771       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5772       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5773       return
5774       end
5775 c------------------------------------------------------------------------------
5776       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5777       implicit none
5778       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5779       double precision ksi,ksi2,ksi3,a1,a2,a3
5780       ksi=(x-x0)/delta
5781       ksi2=ksi*ksi
5782       ksi3=ksi2*ksi
5783       a1=fprim0x*delta
5784       a2=3*(f1x-f0x)-2*fprim0x*delta
5785       a3=fprim0x*delta-2*(f1x-f0x)
5786       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5787       return
5788       end
5789 C-----------------------------------------------------------------------------
5790 #ifdef CRYST_TOR
5791 C-----------------------------------------------------------------------------
5792       subroutine etor(etors,edihcnstr)
5793       implicit real*8 (a-h,o-z)
5794       include 'DIMENSIONS'
5795       include 'COMMON.VAR'
5796       include 'COMMON.GEO'
5797       include 'COMMON.LOCAL'
5798       include 'COMMON.TORSION'
5799       include 'COMMON.INTERACT'
5800       include 'COMMON.DERIV'
5801       include 'COMMON.CHAIN'
5802       include 'COMMON.NAMES'
5803       include 'COMMON.IOUNITS'
5804       include 'COMMON.FFIELD'
5805       include 'COMMON.TORCNSTR'
5806       include 'COMMON.CONTROL'
5807       logical lprn
5808 C Set lprn=.true. for debugging
5809       lprn=.false.
5810 c      lprn=.true.
5811       etors=0.0D0
5812       do i=iphi_start,iphi_end
5813       etors_ii=0.0D0
5814         itori=itortyp(itype(i-2))
5815         itori1=itortyp(itype(i-1))
5816         phii=phi(i)
5817         gloci=0.0D0
5818 C Proline-Proline pair is a special case...
5819         if (itori.eq.3 .and. itori1.eq.3) then
5820           if (phii.gt.-dwapi3) then
5821             cosphi=dcos(3*phii)
5822             fac=1.0D0/(1.0D0-cosphi)
5823             etorsi=v1(1,3,3)*fac
5824             etorsi=etorsi+etorsi
5825             etors=etors+etorsi-v1(1,3,3)
5826             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5827             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5828           endif
5829           do j=1,3
5830             v1ij=v1(j+1,itori,itori1)
5831             v2ij=v2(j+1,itori,itori1)
5832             cosphi=dcos(j*phii)
5833             sinphi=dsin(j*phii)
5834             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5835             if (energy_dec) etors_ii=etors_ii+
5836      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5837             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5838           enddo
5839         else
5840           do j=1,nterm_old
5841             v1ij=v1(j,itori,itori1)
5842             v2ij=v2(j,itori,itori1)
5843             cosphi=dcos(j*phii)
5844             sinphi=dsin(j*phii)
5845             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5846             if (energy_dec) etors_ii=etors_ii+
5847      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5848             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5849           enddo
5850         endif
5851         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5852      &        'etor',i,etors_ii
5853         if (lprn)
5854      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5855      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5856      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5857         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5858         write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5859       enddo
5860 ! 6/20/98 - dihedral angle constraints
5861       edihcnstr=0.0d0
5862       do i=1,ndih_constr
5863         itori=idih_constr(i)
5864         phii=phi(itori)
5865         difi=phii-phi0(i)
5866         if (difi.gt.drange(i)) then
5867           difi=difi-drange(i)
5868           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5869           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5870         else if (difi.lt.-drange(i)) then
5871           difi=difi+drange(i)
5872           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5873           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5874         endif
5875 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5876 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5877       enddo
5878 !      write (iout,*) 'edihcnstr',edihcnstr
5879       return
5880       end
5881 c------------------------------------------------------------------------------
5882 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
5883       subroutine e_modeller(ehomology_constr)
5884       ehomology_constr=0.0d0
5885       write (iout,*) "!!!!!UWAGA, JESTEM W DZIWNEJ PETLI, TEST!!!!!"
5886       return
5887       end
5888 C !!!!!!!! NIE CZYTANE !!!!!!!!!!!
5889
5890 c------------------------------------------------------------------------------
5891       subroutine etor_d(etors_d)
5892       etors_d=0.0d0
5893       return
5894       end
5895 c----------------------------------------------------------------------------
5896 #else
5897       subroutine etor(etors,edihcnstr)
5898       implicit real*8 (a-h,o-z)
5899       include 'DIMENSIONS'
5900       include 'COMMON.VAR'
5901       include 'COMMON.GEO'
5902       include 'COMMON.LOCAL'
5903       include 'COMMON.TORSION'
5904       include 'COMMON.INTERACT'
5905       include 'COMMON.DERIV'
5906       include 'COMMON.CHAIN'
5907       include 'COMMON.NAMES'
5908       include 'COMMON.IOUNITS'
5909       include 'COMMON.FFIELD'
5910       include 'COMMON.TORCNSTR'
5911       include 'COMMON.CONTROL'
5912       logical lprn
5913 C Set lprn=.true. for debugging
5914       lprn=.false.
5915 c     lprn=.true.
5916       etors=0.0D0
5917       do i=iphi_start,iphi_end
5918       etors_ii=0.0D0
5919         itori=itortyp(itype(i-2))
5920         itori1=itortyp(itype(i-1))
5921         phii=phi(i)
5922         gloci=0.0D0
5923 C Regular cosine and sine terms
5924         do j=1,nterm(itori,itori1)
5925           v1ij=v1(j,itori,itori1)
5926           v2ij=v2(j,itori,itori1)
5927           cosphi=dcos(j*phii)
5928           sinphi=dsin(j*phii)
5929           etors=etors+v1ij*cosphi+v2ij*sinphi
5930           if (energy_dec) etors_ii=etors_ii+
5931      &                v1ij*cosphi+v2ij*sinphi
5932           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5933         enddo
5934 C Lorentz terms
5935 C                         v1
5936 C  E = SUM ----------------------------------- - v1
5937 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5938 C
5939         cosphi=dcos(0.5d0*phii)
5940         sinphi=dsin(0.5d0*phii)
5941         do j=1,nlor(itori,itori1)
5942           vl1ij=vlor1(j,itori,itori1)
5943           vl2ij=vlor2(j,itori,itori1)
5944           vl3ij=vlor3(j,itori,itori1)
5945           pom=vl2ij*cosphi+vl3ij*sinphi
5946           pom1=1.0d0/(pom*pom+1.0d0)
5947           etors=etors+vl1ij*pom1
5948           if (energy_dec) etors_ii=etors_ii+
5949      &                vl1ij*pom1
5950           pom=-pom*pom1*pom1
5951           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5952         enddo
5953 C Subtract the constant term
5954         etors=etors-v0(itori,itori1)
5955           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5956      &         'etor',i,etors_ii-v0(itori,itori1)
5957         if (lprn)
5958      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5959      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5960      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5961         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5962 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5963       enddo
5964 ! 6/20/98 - dihedral angle constraints
5965       edihcnstr=0.0d0
5966 c      do i=1,ndih_constr
5967       do i=idihconstr_start,idihconstr_end
5968         itori=idih_constr(i)
5969         phii=phi(itori)
5970         difi=pinorm(phii-phi0(i))
5971         if (difi.gt.drange(i)) then
5972           difi=difi-drange(i)
5973           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5974           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5975         else if (difi.lt.-drange(i)) then
5976           difi=difi+drange(i)
5977           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5978           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5979         else
5980           difi=0.0
5981         endif
5982 c        write (iout,*) "gloci", gloc(i-3,icg)
5983 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5984 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5985 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5986       enddo
5987 cd       write (iout,*) 'edihcnstr',edihcnstr
5988       return
5989       end
5990 c----------------------------------------------------------------------------
5991 c MODELLER restraint function
5992       subroutine e_modeller(ehomology_constr)
5993       implicit real*8 (a-h,o-z)
5994       include 'DIMENSIONS'
5995
5996       integer nnn, i, j, k, ki, irec, l
5997       integer katy, odleglosci, test7
5998       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
5999       real*8 Eval,Erot
6000       real*8 distance(max_template),distancek(max_template),
6001      &    min_odl,godl(max_template),dih_diff(max_template)
6002
6003 c
6004 c     FP - 30/10/2014 Temporary specifications for homology restraints
6005 c
6006       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
6007      &                 sgtheta
6008       double precision, dimension (maxres) :: guscdiff,usc_diff
6009       double precision, dimension (max_template) ::
6010      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
6011      &           theta_diff
6012 c
6013
6014       include 'COMMON.SBRIDGE'
6015       include 'COMMON.CHAIN'
6016       include 'COMMON.GEO'
6017       include 'COMMON.DERIV'
6018       include 'COMMON.LOCAL'
6019       include 'COMMON.INTERACT'
6020       include 'COMMON.VAR'
6021       include 'COMMON.IOUNITS'
6022       include 'COMMON.MD'
6023       include 'COMMON.CONTROL'
6024 c
6025 c     From subroutine Econstr_back
6026 c
6027       include 'COMMON.NAMES'
6028       include 'COMMON.TIME1'
6029 c
6030
6031
6032       do i=1,max_template
6033         distancek(i)=9999999.9
6034       enddo
6035
6036
6037       odleg=0.0d0
6038
6039 c Pseudo-energy and gradient from homology restraints (MODELLER-like
6040 c function)
6041 C AL 5/2/14 - Introduce list of restraints
6042 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
6043 #ifdef DEBUG
6044       write(iout,*) "------- dist restrs start -------"
6045 #endif
6046       do ii = link_start_homo,link_end_homo
6047          i = ires_homo(ii)
6048          j = jres_homo(ii)
6049          dij=dist(i,j)
6050 c        write (iout,*) "dij(",i,j,") =",dij
6051          do k=1,constr_homology
6052 c           write(iout,*) ii,k,i,j,l_homo(k,ii),dij,odl(k,ii)
6053            if(.not.l_homo(k,ii)) cycle
6054            distance(k)=odl(k,ii)-dij
6055 c          write (iout,*) "distance(",k,") =",distance(k)
6056 c
6057 c          For Gaussian-type Urestr
6058 c
6059            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
6060 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
6061 c          write (iout,*) "distancek(",k,") =",distancek(k)
6062 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
6063 c
6064 c          For Lorentzian-type Urestr
6065 c
6066            if (waga_dist.lt.0.0d0) then
6067               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
6068               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
6069      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
6070            endif
6071          enddo
6072
6073
6074 c         min_odl=minval(distancek)
6075          do kk=1,constr_homology
6076           if(l_homo(kk,ii)) then
6077             min_odl=distancek(kk)
6078             exit
6079           endif
6080          enddo
6081          do kk=1,constr_homology
6082           if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
6083      &              min_odl=distancek(kk)
6084          enddo
6085 c        write (iout,* )"min_odl",min_odl
6086 #ifdef DEBUG
6087          write (iout,*) "ij dij",i,j,dij
6088          write (iout,*) "distance",(distance(k),k=1,constr_homology)
6089          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
6090          write (iout,* )"min_odl",min_odl
6091 #endif
6092          odleg2=0.0d0
6093          do k=1,constr_homology
6094 c Nie wiem po co to liczycie jeszcze raz!
6095 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
6096 c     &              (2*(sigma_odl(i,j,k))**2))
6097            if(.not.l_homo(k,ii)) cycle
6098            if (waga_dist.ge.0.0d0) then
6099 c
6100 c          For Gaussian-type Urestr
6101 c
6102             godl(k)=dexp(-distancek(k)+min_odl)
6103             odleg2=odleg2+godl(k)
6104 c
6105 c          For Lorentzian-type Urestr
6106 c
6107            else
6108             odleg2=odleg2+distancek(k)
6109            endif
6110
6111 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
6112 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
6113 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
6114 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
6115
6116          enddo
6117 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
6118 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
6119 #ifdef DEBUG
6120          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
6121          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
6122 #endif
6123            if (waga_dist.ge.0.0d0) then
6124 c
6125 c          For Gaussian-type Urestr
6126 c
6127               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
6128 c
6129 c          For Lorentzian-type Urestr
6130 c
6131            else
6132               odleg=odleg+odleg2/constr_homology
6133            endif
6134 c
6135 c        write (iout,*) "odleg",odleg ! sum of -ln-s
6136 c Gradient
6137 c
6138 c          For Gaussian-type Urestr
6139 c
6140          if (waga_dist.ge.0.0d0) sum_godl=odleg2
6141          sum_sgodl=0.0d0
6142          do k=1,constr_homology
6143 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
6144 c     &           *waga_dist)+min_odl
6145 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
6146 c
6147          if(.not.l_homo(k,ii)) cycle
6148          if (waga_dist.ge.0.0d0) then
6149 c          For Gaussian-type Urestr
6150 c
6151            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
6152 c
6153 c          For Lorentzian-type Urestr
6154 c
6155          else
6156            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
6157      &           sigma_odlir(k,ii)**2)**2)
6158          endif
6159            sum_sgodl=sum_sgodl+sgodl
6160
6161 c            sgodl2=sgodl2+sgodl
6162 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
6163 c      write(iout,*) "constr_homology=",constr_homology
6164 c      write(iout,*) i, j, k, "TEST K"
6165          enddo
6166          if (waga_dist.ge.0.0d0) then
6167 c
6168 c          For Gaussian-type Urestr
6169 c
6170             grad_odl3=waga_homology(iset)*waga_dist
6171      &                *sum_sgodl/(sum_godl*dij)
6172 c
6173 c          For Lorentzian-type Urestr
6174 c
6175          else
6176 c Original grad expr modified by analogy w Gaussian-type Urestr grad
6177 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
6178             grad_odl3=-waga_homology(iset)*waga_dist*
6179      &                sum_sgodl/(constr_homology*dij)
6180          endif
6181 c
6182 c        grad_odl3=sum_sgodl/(sum_godl*dij)
6183
6184
6185 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
6186 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
6187 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
6188
6189 ccc      write(iout,*) godl, sgodl, grad_odl3
6190
6191 c          grad_odl=grad_odl+grad_odl3
6192
6193          do jik=1,3
6194             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
6195 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
6196 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
6197 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
6198             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
6199             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
6200 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
6201 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
6202 c         if (i.eq.25.and.j.eq.27) then
6203 c         write(iout,*) "jik",jik,"i",i,"j",j
6204 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
6205 c         write(iout,*) "grad_odl3",grad_odl3
6206 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
6207 c         write(iout,*) "ggodl",ggodl
6208 c         write(iout,*) "ghpbc(",jik,i,")",
6209 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
6210 c     &                 ghpbc(jik,j)
6211 c         endif
6212          enddo
6213 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
6214 ccc     & dLOG(odleg2),"-odleg=", -odleg
6215
6216       enddo ! ii-loop for dist
6217 #ifdef DEBUG
6218       write(iout,*) "------- dist restrs end -------"
6219 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
6220 c    &     waga_d.eq.1.0d0) call sum_gradient
6221 #endif
6222 c Pseudo-energy and gradient from dihedral-angle restraints from
6223 c homology templates
6224 c      write (iout,*) "End of distance loop"
6225 c      call flush(iout)
6226       kat=0.0d0
6227 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
6228 #ifdef DEBUG
6229       write(iout,*) "------- dih restrs start -------"
6230       do i=idihconstr_start_homo,idihconstr_end_homo
6231         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
6232       enddo
6233 #endif
6234       do i=idihconstr_start_homo,idihconstr_end_homo
6235         kat2=0.0d0
6236 c        betai=beta(i,i+1,i+2,i+3)
6237         betai = phi(i)
6238 c       write (iout,*) "betai =",betai
6239         do k=1,constr_homology
6240           dih_diff(k)=pinorm(dih(k,i)-betai)
6241 c         write (iout,*) "dih_diff(",k,") =",dih_diff(k)
6242 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
6243 c     &                                   -(6.28318-dih_diff(i,k))
6244 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
6245 c     &                                   6.28318+dih_diff(i,k)
6246
6247           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
6248 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
6249           gdih(k)=dexp(kat3)
6250           kat2=kat2+gdih(k)
6251 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
6252 c          write(*,*)""
6253         enddo
6254 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
6255 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
6256 #ifdef DEBUG
6257         write (iout,*) "i",i," betai",betai," kat2",kat2
6258         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
6259 #endif
6260         if (kat2.le.1.0d-14) cycle
6261         kat=kat-dLOG(kat2/constr_homology)
6262 c       write (iout,*) "kat",kat ! sum of -ln-s
6263
6264 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
6265 ccc     & dLOG(kat2), "-kat=", -kat
6266
6267 c ----------------------------------------------------------------------
6268 c Gradient
6269 c ----------------------------------------------------------------------
6270
6271         sum_gdih=kat2
6272         sum_sgdih=0.0d0
6273         do k=1,constr_homology
6274           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
6275 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
6276           sum_sgdih=sum_sgdih+sgdih
6277         enddo
6278 c       grad_dih3=sum_sgdih/sum_gdih
6279         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
6280
6281 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
6282 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
6283 ccc     & gloc(nphi+i-3,icg)
6284         gloc(i,icg)=gloc(i,icg)+grad_dih3
6285 c        if (i.eq.25) then
6286 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
6287 c        endif
6288 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
6289 ccc     & gloc(nphi+i-3,icg)
6290
6291       enddo ! i-loop for dih
6292 #ifdef DEBUG
6293       write(iout,*) "------- dih restrs end -------"
6294 #endif
6295
6296 c Pseudo-energy and gradient for theta angle restraints from
6297 c homology templates
6298 c FP 01/15 - inserted from econstr_local_test.F, loop structure
6299 c adapted
6300
6301 c
6302 c     For constr_homology reference structures (FP)
6303 c
6304 c     Uconst_back_tot=0.0d0
6305       Eval=0.0d0
6306       Erot=0.0d0
6307 c     Econstr_back legacy
6308       do i=1,nres
6309 c     do i=ithet_start,ithet_end
6310        dutheta(i)=0.0d0
6311 c     enddo
6312 c     do i=loc_start,loc_end
6313         do j=1,3
6314           duscdiff(j,i)=0.0d0
6315           duscdiffx(j,i)=0.0d0
6316         enddo
6317       enddo
6318 c
6319 c     do iref=1,nref
6320 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
6321 c     write (iout,*) "waga_theta",waga_theta
6322       if (waga_theta.gt.0.0d0) then
6323 #ifdef DEBUG
6324       write (iout,*) "usampl",usampl
6325       write(iout,*) "------- theta restrs start -------"
6326 c     do i=ithet_start,ithet_end
6327 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
6328 c     enddo
6329 #endif
6330 c     write (iout,*) "maxres",maxres,"nres",nres
6331
6332       do i=ithet_start,ithet_end
6333 c
6334 c     do i=1,nfrag_back
6335 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
6336 c
6337 c Deviation of theta angles wrt constr_homology ref structures
6338 c
6339         utheta_i=0.0d0 ! argument of Gaussian for single k
6340         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
6341 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
6342 c       over residues in a fragment
6343 c       write (iout,*) "theta(",i,")=",theta(i)
6344         do k=1,constr_homology
6345 c
6346 c         dtheta_i=theta(j)-thetaref(j,iref)
6347 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
6348           theta_diff(k)=thetatpl(k,i)-theta(i)
6349 c
6350           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
6351 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
6352           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
6353           gutheta_i=gutheta_i+dexp(utheta_i)   ! Sum of Gaussians (pk)
6354 c         Gradient for single Gaussian restraint in subr Econstr_back
6355 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
6356 c
6357         enddo
6358 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
6359 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
6360
6361 c
6362 c         Gradient for multiple Gaussian restraint
6363         sum_gtheta=gutheta_i
6364         sum_sgtheta=0.0d0
6365         do k=1,constr_homology
6366 c        New generalized expr for multiple Gaussian from Econstr_back
6367          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
6368 c
6369 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
6370           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
6371         enddo
6372 c       Final value of gradient using same var as in Econstr_back
6373         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)
6374      &      +sum_sgtheta/sum_gtheta*waga_theta
6375      &               *waga_homology(iset)
6376 c        dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
6377 c     &               *waga_homology(iset)
6378 c       dutheta(i)=sum_sgtheta/sum_gtheta
6379 c
6380 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
6381         Eval=Eval-dLOG(gutheta_i/constr_homology)
6382 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
6383 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
6384 c       Uconst_back=Uconst_back+utheta(i)
6385       enddo ! (i-loop for theta)
6386 #ifdef DEBUG
6387       write(iout,*) "------- theta restrs end -------"
6388 #endif
6389       endif
6390 c
6391 c Deviation of local SC geometry
6392 c
6393 c Separation of two i-loops (instructed by AL - 11/3/2014)
6394 c
6395 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
6396 c     write (iout,*) "waga_d",waga_d
6397
6398 #ifdef DEBUG
6399       write(iout,*) "------- SC restrs start -------"
6400       write (iout,*) "Initial duscdiff,duscdiffx"
6401       do i=loc_start,loc_end
6402         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
6403      &                 (duscdiffx(jik,i),jik=1,3)
6404       enddo
6405 #endif
6406       do i=loc_start,loc_end
6407         usc_diff_i=0.0d0 ! argument of Gaussian for single k
6408         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
6409 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
6410 c       write(iout,*) "xxtab, yytab, zztab"
6411 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
6412         do k=1,constr_homology
6413 c
6414           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
6415 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
6416           dyy=-yytpl(k,i)+yytab(i) ! ibid y
6417           dzz=-zztpl(k,i)+zztab(i) ! ibid z
6418 c         write(iout,*) "dxx, dyy, dzz"
6419 c         write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
6420 c
6421           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
6422 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
6423 c         uscdiffk(k)=usc_diff(i)
6424           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
6425           guscdiff(i)=guscdiff(i)+dexp(usc_diff_i)   !Sum of Gaussians (pk)
6426 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
6427 c     &      xxref(j),yyref(j),zzref(j)
6428         enddo
6429 c
6430 c       Gradient
6431 c
6432 c       Generalized expression for multiple Gaussian acc to that for a single
6433 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
6434 c
6435 c       Original implementation
6436 c       sum_guscdiff=guscdiff(i)
6437 c
6438 c       sum_sguscdiff=0.0d0
6439 c       do k=1,constr_homology
6440 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
6441 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
6442 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
6443 c       enddo
6444 c
6445 c       Implementation of new expressions for gradient (Jan. 2015)
6446 c
6447 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
6448         do k=1,constr_homology
6449 c
6450 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
6451 c       before. Now the drivatives should be correct
6452 c
6453           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
6454 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
6455           dyy=-yytpl(k,i)+yytab(i) ! ibid y
6456           dzz=-zztpl(k,i)+zztab(i) ! ibid z
6457 c
6458 c         New implementation
6459 c
6460           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
6461      &                 sigma_d(k,i) ! for the grad wrt r'
6462 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
6463 c
6464 c
6465 c        New implementation
6466          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
6467          do jik=1,3
6468             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
6469      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
6470      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
6471             duscdiff(jik,i)=duscdiff(jik,i)+
6472      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
6473      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
6474             duscdiffx(jik,i)=duscdiffx(jik,i)+
6475      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
6476      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
6477 c
6478 #ifdef DEBUG
6479              write(iout,*) "jik",jik,"i",i
6480              write(iout,*) "dxx, dyy, dzz"
6481              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
6482              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
6483 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
6484 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
6485 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
6486 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
6487 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
6488 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
6489 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
6490 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
6491 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
6492 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
6493 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
6494 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
6495 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
6496 c            endif
6497 #endif
6498          enddo
6499         enddo
6500 c
6501 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
6502 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
6503 c
6504 c        write (iout,*) i," uscdiff",uscdiff(i)
6505 c
6506 c Put together deviations from local geometry
6507
6508 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
6509 c      &            wfrag_back(3,i,iset)*uscdiff(i)
6510         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
6511 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
6512 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
6513 c       Uconst_back=Uconst_back+usc_diff(i)
6514 c
6515 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
6516 c
6517 c     New implment: multiplied by sum_sguscdiff
6518 c
6519
6520       enddo ! (i-loop for dscdiff)
6521
6522 c      endif
6523
6524 #ifdef DEBUG
6525       write(iout,*) "------- SC restrs end -------"
6526         write (iout,*) "------ After SC loop in e_modeller ------"
6527         do i=loc_start,loc_end
6528          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
6529          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
6530         enddo
6531       if (waga_theta.eq.1.0d0) then
6532       write (iout,*) "in e_modeller after SC restr end: dutheta"
6533       do i=ithet_start,ithet_end
6534         write (iout,*) i,dutheta(i)
6535       enddo
6536       endif
6537       if (waga_d.eq.1.0d0) then
6538       write (iout,*) "e_modeller after SC loop: duscdiff/x"
6539       do i=1,nres
6540         write (iout,*) i,(duscdiff(j,i),j=1,3)
6541         write (iout,*) i,(duscdiffx(j,i),j=1,3)
6542       enddo
6543       endif
6544 #endif
6545
6546 c Total energy from homology restraints
6547 #ifdef DEBUG
6548       write (iout,*) "odleg",odleg," kat",kat
6549 #endif
6550 c
6551 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
6552 c
6553 c     ehomology_constr=odleg+kat
6554 c
6555 c     For Lorentzian-type Urestr
6556 c
6557
6558       if (waga_dist.ge.0.0d0) then
6559 c
6560 c          For Gaussian-type Urestr
6561 c
6562         ehomology_constr=(waga_dist*odleg+waga_angle*kat+
6563      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
6564 c     write (iout,*) "ehomology_constr=",ehomology_constr
6565       else
6566 c
6567 c          For Lorentzian-type Urestr
6568 c
6569         ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
6570      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
6571 c     write (iout,*) "ehomology_constr=",ehomology_constr
6572       endif
6573 #ifdef DEBUG
6574       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
6575      & "Eval",waga_theta,eval,
6576      &   "Erot",waga_d,Erot
6577       write (iout,*) "ehomology_constr",ehomology_constr
6578 #endif
6579       return
6580 c
6581 c FP 01/15 end
6582 c
6583   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
6584   747 format(a12,i4,i4,i4,f8.3,f8.3)
6585   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
6586   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
6587   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
6588      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
6589       end
6590
6591 c------------------------------------------------------------------------------
6592       subroutine etor_d(etors_d)
6593 C 6/23/01 Compute double torsional energy
6594       implicit real*8 (a-h,o-z)
6595       include 'DIMENSIONS'
6596       include 'COMMON.VAR'
6597       include 'COMMON.GEO'
6598       include 'COMMON.LOCAL'
6599       include 'COMMON.TORSION'
6600       include 'COMMON.INTERACT'
6601       include 'COMMON.DERIV'
6602       include 'COMMON.CHAIN'
6603       include 'COMMON.NAMES'
6604       include 'COMMON.IOUNITS'
6605       include 'COMMON.FFIELD'
6606       include 'COMMON.TORCNSTR'
6607       include 'COMMON.CONTROL'
6608       logical lprn
6609 C Set lprn=.true. for debugging
6610       lprn=.false.
6611 c     lprn=.true.
6612       etors_d=0.0D0
6613       do i=iphid_start,iphid_end
6614         etors_d_ii=0.0D0
6615         itori=itortyp(itype(i-2))
6616         itori1=itortyp(itype(i-1))
6617         itori2=itortyp(itype(i))
6618         phii=phi(i)
6619         phii1=phi(i+1)
6620         gloci1=0.0D0
6621         gloci2=0.0D0
6622         do j=1,ntermd_1(itori,itori1,itori2)
6623           v1cij=v1c(1,j,itori,itori1,itori2)
6624           v1sij=v1s(1,j,itori,itori1,itori2)
6625           v2cij=v1c(2,j,itori,itori1,itori2)
6626           v2sij=v1s(2,j,itori,itori1,itori2)
6627           cosphi1=dcos(j*phii)
6628           sinphi1=dsin(j*phii)
6629           cosphi2=dcos(j*phii1)
6630           sinphi2=dsin(j*phii1)
6631           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
6632      &     v2cij*cosphi2+v2sij*sinphi2
6633           if (energy_dec) etors_d_ii=etors_d_ii+
6634      &     v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
6635           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6636           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6637         enddo
6638         do k=2,ntermd_2(itori,itori1,itori2)
6639           do l=1,k-1
6640             v1cdij = v2c(k,l,itori,itori1,itori2)
6641             v2cdij = v2c(l,k,itori,itori1,itori2)
6642             v1sdij = v2s(k,l,itori,itori1,itori2)
6643             v2sdij = v2s(l,k,itori,itori1,itori2)
6644             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6645             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6646             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6647             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6648             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6649      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6650             if (energy_dec) etors_d_ii=etors_d_ii+
6651      &        v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6652      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6653             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
6654      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6655             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
6656      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6657           enddo
6658         enddo
6659         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6660      &        'etor_d',i,etors_d_ii
6661         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
6662         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
6663 c        write (iout,*) "gloci", gloc(i-3,icg)
6664       enddo
6665       return
6666       end
6667 #endif
6668 c------------------------------------------------------------------------------
6669       subroutine eback_sc_corr(esccor)
6670 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6671 c        conformational states; temporarily implemented as differences
6672 c        between UNRES torsional potentials (dependent on three types of
6673 c        residues) and the torsional potentials dependent on all 20 types
6674 c        of residues computed from AM1  energy surfaces of terminally-blocked
6675 c        amino-acid residues.
6676       implicit real*8 (a-h,o-z)
6677       include 'DIMENSIONS'
6678       include 'COMMON.VAR'
6679       include 'COMMON.GEO'
6680       include 'COMMON.LOCAL'
6681       include 'COMMON.TORSION'
6682       include 'COMMON.SCCOR'
6683       include 'COMMON.INTERACT'
6684       include 'COMMON.DERIV'
6685       include 'COMMON.CHAIN'
6686       include 'COMMON.NAMES'
6687       include 'COMMON.IOUNITS'
6688       include 'COMMON.FFIELD'
6689       include 'COMMON.CONTROL'
6690       logical lprn
6691 C Set lprn=.true. for debugging
6692       lprn=.false.
6693 c      lprn=.true.
6694 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
6695       esccor=0.0D0
6696       do i=itau_start,itau_end
6697         esccor_ii=0.0D0
6698         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6699         isccori=isccortyp(itype(i-2))
6700         isccori1=isccortyp(itype(i-1))
6701         phii=phi(i)
6702 cccc  Added 9 May 2012
6703 cc Tauangle is torsional engle depending on the value of first digit
6704 c(see comment below)
6705 cc Omicron is flat angle depending on the value of first digit
6706 c(see comment below)
6707
6708
6709         do intertyp=1,3 !intertyp
6710 cc Added 09 May 2012 (Adasko)
6711 cc  Intertyp means interaction type of backbone mainchain correlation:
6712 c   1 = SC...Ca...Ca...Ca
6713 c   2 = Ca...Ca...Ca...SC
6714 c   3 = SC...Ca...Ca...SCi
6715         gloci=0.0D0
6716         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6717      &      (itype(i-1).eq.10).or.(itype(i-2).eq.21).or.
6718      &      (itype(i-1).eq.21)))
6719      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6720      &     .or.(itype(i-2).eq.21)))
6721      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6722      &      (itype(i-1).eq.21)))) cycle
6723         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle
6724         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21))
6725      & cycle
6726         do j=1,nterm_sccor(isccori,isccori1)
6727           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6728           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6729           cosphi=dcos(j*tauangle(intertyp,i))
6730           sinphi=dsin(j*tauangle(intertyp,i))
6731           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6732           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6733         enddo
6734         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6735 c        write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
6736 c     &gloc_sc(intertyp,i-3,icg)
6737         if (lprn)
6738      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6739      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6740      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
6741      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
6742         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6743        enddo !intertyp
6744       enddo
6745 c        do i=1,nres
6746 c        write (iout,*) "W@T@F",  gloc_sc(1,i,icg),gloc(i,icg)
6747 c        enddo
6748       return
6749       end
6750 c----------------------------------------------------------------------------
6751       subroutine multibody(ecorr)
6752 C This subroutine calculates multi-body contributions to energy following
6753 C the idea of Skolnick et al. If side chains I and J make a contact and
6754 C at the same time side chains I+1 and J+1 make a contact, an extra
6755 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6756       implicit real*8 (a-h,o-z)
6757       include 'DIMENSIONS'
6758       include 'COMMON.IOUNITS'
6759       include 'COMMON.DERIV'
6760       include 'COMMON.INTERACT'
6761       include 'COMMON.CONTACTS'
6762       double precision gx(3),gx1(3)
6763       logical lprn
6764
6765 C Set lprn=.true. for debugging
6766       lprn=.false.
6767
6768       if (lprn) then
6769         write (iout,'(a)') 'Contact function values:'
6770         do i=nnt,nct-2
6771           write (iout,'(i2,20(1x,i2,f10.5))')
6772      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6773         enddo
6774       endif
6775       ecorr=0.0D0
6776       do i=nnt,nct
6777         do j=1,3
6778           gradcorr(j,i)=0.0D0
6779           gradxorr(j,i)=0.0D0
6780         enddo
6781       enddo
6782       do i=nnt,nct-2
6783
6784         DO ISHIFT = 3,4
6785
6786         i1=i+ishift
6787         num_conti=num_cont(i)
6788         num_conti1=num_cont(i1)
6789         do jj=1,num_conti
6790           j=jcont(jj,i)
6791           do kk=1,num_conti1
6792             j1=jcont(kk,i1)
6793             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6794 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6795 cd   &                   ' ishift=',ishift
6796 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6797 C The system gains extra energy.
6798               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6799             endif   ! j1==j+-ishift
6800           enddo     ! kk
6801         enddo       ! jj
6802
6803         ENDDO ! ISHIFT
6804
6805       enddo         ! i
6806       return
6807       end
6808 c------------------------------------------------------------------------------
6809       double precision function esccorr(i,j,k,l,jj,kk)
6810       implicit real*8 (a-h,o-z)
6811       include 'DIMENSIONS'
6812       include 'COMMON.IOUNITS'
6813       include 'COMMON.DERIV'
6814       include 'COMMON.INTERACT'
6815       include 'COMMON.CONTACTS'
6816       double precision gx(3),gx1(3)
6817       logical lprn
6818       lprn=.false.
6819       eij=facont(jj,i)
6820       ekl=facont(kk,k)
6821 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6822 C Calculate the multi-body contribution to energy.
6823 C Calculate multi-body contributions to the gradient.
6824 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6825 cd   & k,l,(gacont(m,kk,k),m=1,3)
6826       do m=1,3
6827         gx(m) =ekl*gacont(m,jj,i)
6828         gx1(m)=eij*gacont(m,kk,k)
6829         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6830         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6831         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6832         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6833       enddo
6834       do m=i,j-1
6835         do ll=1,3
6836           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6837         enddo
6838       enddo
6839       do m=k,l-1
6840         do ll=1,3
6841           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6842         enddo
6843       enddo
6844       esccorr=-eij*ekl
6845       return
6846       end
6847 c------------------------------------------------------------------------------
6848       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6849 C This subroutine calculates multi-body contributions to hydrogen-bonding
6850       implicit real*8 (a-h,o-z)
6851       include 'DIMENSIONS'
6852       include 'COMMON.IOUNITS'
6853 #ifdef MPI
6854       include "mpif.h"
6855       parameter (max_cont=maxconts)
6856       parameter (max_dim=26)
6857       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6858       double precision zapas(max_dim,maxconts,max_fg_procs),
6859      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6860       common /przechowalnia/ zapas
6861       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6862      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6863 #endif
6864       include 'COMMON.SETUP'
6865       include 'COMMON.FFIELD'
6866       include 'COMMON.DERIV'
6867       include 'COMMON.INTERACT'
6868       include 'COMMON.CONTACTS'
6869       include 'COMMON.CONTROL'
6870       include 'COMMON.LOCAL'
6871       double precision gx(3),gx1(3),time00
6872       logical lprn,ldone
6873
6874 C Set lprn=.true. for debugging
6875       lprn=.false.
6876 #ifdef MPI
6877       n_corr=0
6878       n_corr1=0
6879       if (nfgtasks.le.1) goto 30
6880       if (lprn) then
6881         write (iout,'(a)') 'Contact function values before RECEIVE:'
6882         do i=nnt,nct-2
6883           write (iout,'(2i3,50(1x,i2,f5.2))')
6884      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6885      &    j=1,num_cont_hb(i))
6886         enddo
6887       endif
6888       call flush(iout)
6889       do i=1,ntask_cont_from
6890         ncont_recv(i)=0
6891       enddo
6892       do i=1,ntask_cont_to
6893         ncont_sent(i)=0
6894       enddo
6895 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6896 c     & ntask_cont_to
6897 C Make the list of contacts to send to send to other procesors
6898 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6899 c      call flush(iout)
6900       do i=iturn3_start,iturn3_end
6901 c        write (iout,*) "make contact list turn3",i," num_cont",
6902 c     &    num_cont_hb(i)
6903         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6904       enddo
6905       do i=iturn4_start,iturn4_end
6906 c        write (iout,*) "make contact list turn4",i," num_cont",
6907 c     &   num_cont_hb(i)
6908         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6909       enddo
6910       do ii=1,nat_sent
6911         i=iat_sent(ii)
6912 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6913 c     &    num_cont_hb(i)
6914         do j=1,num_cont_hb(i)
6915         do k=1,4
6916           jjc=jcont_hb(j,i)
6917           iproc=iint_sent_local(k,jjc,ii)
6918 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6919           if (iproc.gt.0) then
6920             ncont_sent(iproc)=ncont_sent(iproc)+1
6921             nn=ncont_sent(iproc)
6922             zapas(1,nn,iproc)=i
6923             zapas(2,nn,iproc)=jjc
6924             zapas(3,nn,iproc)=facont_hb(j,i)
6925             zapas(4,nn,iproc)=ees0p(j,i)
6926             zapas(5,nn,iproc)=ees0m(j,i)
6927             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6928             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6929             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6930             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6931             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6932             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6933             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6934             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6935             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6936             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6937             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6938             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6939             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6940             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6941             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6942             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6943             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6944             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6945             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6946             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6947             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6948           endif
6949         enddo
6950         enddo
6951       enddo
6952       if (lprn) then
6953       write (iout,*)
6954      &  "Numbers of contacts to be sent to other processors",
6955      &  (ncont_sent(i),i=1,ntask_cont_to)
6956       write (iout,*) "Contacts sent"
6957       do ii=1,ntask_cont_to
6958         nn=ncont_sent(ii)
6959         iproc=itask_cont_to(ii)
6960         write (iout,*) nn," contacts to processor",iproc,
6961      &   " of CONT_TO_COMM group"
6962         do i=1,nn
6963           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6964         enddo
6965       enddo
6966       call flush(iout)
6967       endif
6968       CorrelType=477
6969       CorrelID=fg_rank+1
6970       CorrelType1=478
6971       CorrelID1=nfgtasks+fg_rank+1
6972       ireq=0
6973 C Receive the numbers of needed contacts from other processors
6974       do ii=1,ntask_cont_from
6975         iproc=itask_cont_from(ii)
6976         ireq=ireq+1
6977         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6978      &    FG_COMM,req(ireq),IERR)
6979       enddo
6980 c      write (iout,*) "IRECV ended"
6981 c      call flush(iout)
6982 C Send the number of contacts needed by other processors
6983       do ii=1,ntask_cont_to
6984         iproc=itask_cont_to(ii)
6985         ireq=ireq+1
6986         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6987      &    FG_COMM,req(ireq),IERR)
6988       enddo
6989 c      write (iout,*) "ISEND ended"
6990 c      write (iout,*) "number of requests (nn)",ireq
6991       call flush(iout)
6992       if (ireq.gt.0)
6993      &  call MPI_Waitall(ireq,req,status_array,ierr)
6994 c      write (iout,*)
6995 c     &  "Numbers of contacts to be received from other processors",
6996 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6997 c      call flush(iout)
6998 C Receive contacts
6999       ireq=0
7000       do ii=1,ntask_cont_from
7001         iproc=itask_cont_from(ii)
7002         nn=ncont_recv(ii)
7003 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7004 c     &   " of CONT_TO_COMM group"
7005         call flush(iout)
7006         if (nn.gt.0) then
7007           ireq=ireq+1
7008           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
7009      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7010 c          write (iout,*) "ireq,req",ireq,req(ireq)
7011         endif
7012       enddo
7013 C Send the contacts to processors that need them
7014       do ii=1,ntask_cont_to
7015         iproc=itask_cont_to(ii)
7016         nn=ncont_sent(ii)
7017 c        write (iout,*) nn," contacts to processor",iproc,
7018 c     &   " of CONT_TO_COMM group"
7019         if (nn.gt.0) then
7020           ireq=ireq+1
7021           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
7022      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7023 c          write (iout,*) "ireq,req",ireq,req(ireq)
7024 c          do i=1,nn
7025 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7026 c          enddo
7027         endif
7028       enddo
7029 c      write (iout,*) "number of requests (contacts)",ireq
7030 c      write (iout,*) "req",(req(i),i=1,4)
7031 c      call flush(iout)
7032       if (ireq.gt.0)
7033      & call MPI_Waitall(ireq,req,status_array,ierr)
7034       do iii=1,ntask_cont_from
7035         iproc=itask_cont_from(iii)
7036         nn=ncont_recv(iii)
7037         if (lprn) then
7038         write (iout,*) "Received",nn," contacts from processor",iproc,
7039      &   " of CONT_FROM_COMM group"
7040         call flush(iout)
7041         do i=1,nn
7042           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
7043         enddo
7044         call flush(iout)
7045         endif
7046         do i=1,nn
7047           ii=zapas_recv(1,i,iii)
7048 c Flag the received contacts to prevent double-counting
7049           jj=-zapas_recv(2,i,iii)
7050 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7051 c          call flush(iout)
7052           nnn=num_cont_hb(ii)+1
7053           num_cont_hb(ii)=nnn
7054           jcont_hb(nnn,ii)=jj
7055           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
7056           ees0p(nnn,ii)=zapas_recv(4,i,iii)
7057           ees0m(nnn,ii)=zapas_recv(5,i,iii)
7058           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
7059           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
7060           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
7061           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
7062           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
7063           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
7064           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
7065           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
7066           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
7067           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
7068           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
7069           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
7070           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
7071           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
7072           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
7073           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
7074           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
7075           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
7076           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
7077           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
7078           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
7079         enddo
7080       enddo
7081       call flush(iout)
7082       if (lprn) then
7083         write (iout,'(a)') 'Contact function values after receive:'
7084         do i=nnt,nct-2
7085           write (iout,'(2i3,50(1x,i3,f5.2))')
7086      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7087      &    j=1,num_cont_hb(i))
7088         enddo
7089         call flush(iout)
7090       endif
7091    30 continue
7092 #endif
7093       if (lprn) then
7094         write (iout,'(a)') 'Contact function values:'
7095         do i=nnt,nct-2
7096           write (iout,'(2i3,50(1x,i3,f5.2))')
7097      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7098      &    j=1,num_cont_hb(i))
7099         enddo
7100       endif
7101       ecorr=0.0D0
7102 C Remove the loop below after debugging !!!
7103       do i=nnt,nct
7104         do j=1,3
7105           gradcorr(j,i)=0.0D0
7106           gradxorr(j,i)=0.0D0
7107         enddo
7108       enddo
7109 C Calculate the local-electrostatic correlation terms
7110       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
7111         i1=i+1
7112         num_conti=num_cont_hb(i)
7113         num_conti1=num_cont_hb(i+1)
7114         do jj=1,num_conti
7115           j=jcont_hb(jj,i)
7116           jp=iabs(j)
7117           do kk=1,num_conti1
7118             j1=jcont_hb(kk,i1)
7119             jp1=iabs(j1)
7120 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7121 c     &         ' jj=',jj,' kk=',kk
7122             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7123      &          .or. j.lt.0 .and. j1.gt.0) .and.
7124      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7125 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7126 C The system gains extra energy.
7127               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7128               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
7129      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
7130               n_corr=n_corr+1
7131             else if (j1.eq.j) then
7132 C Contacts I-J and I-(J+1) occur simultaneously.
7133 C The system loses extra energy.
7134 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7135             endif
7136           enddo ! kk
7137           do kk=1,num_conti
7138             j1=jcont_hb(kk,i)
7139 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7140 c    &         ' jj=',jj,' kk=',kk
7141             if (j1.eq.j+1) then
7142 C Contacts I-J and (I+1)-J occur simultaneously.
7143 C The system loses extra energy.
7144 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7145             endif ! j1==j+1
7146           enddo ! kk
7147         enddo ! jj
7148       enddo ! i
7149       return
7150       end
7151 c------------------------------------------------------------------------------
7152       subroutine add_hb_contact(ii,jj,itask)
7153       implicit real*8 (a-h,o-z)
7154       include "DIMENSIONS"
7155       include "COMMON.IOUNITS"
7156       integer max_cont
7157       integer max_dim
7158       parameter (max_cont=maxconts)
7159       parameter (max_dim=26)
7160       include "COMMON.CONTACTS"
7161       double precision zapas(max_dim,maxconts,max_fg_procs),
7162      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7163       common /przechowalnia/ zapas
7164       integer i,j,ii,jj,iproc,itask(4),nn
7165 c      write (iout,*) "itask",itask
7166       do i=1,2
7167         iproc=itask(i)
7168         if (iproc.gt.0) then
7169           do j=1,num_cont_hb(ii)
7170             jjc=jcont_hb(j,ii)
7171 c            write (iout,*) "i",ii," j",jj," jjc",jjc
7172             if (jjc.eq.jj) then
7173               ncont_sent(iproc)=ncont_sent(iproc)+1
7174               nn=ncont_sent(iproc)
7175               zapas(1,nn,iproc)=ii
7176               zapas(2,nn,iproc)=jjc
7177               zapas(3,nn,iproc)=facont_hb(j,ii)
7178               zapas(4,nn,iproc)=ees0p(j,ii)
7179               zapas(5,nn,iproc)=ees0m(j,ii)
7180               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
7181               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
7182               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
7183               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
7184               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
7185               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
7186               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
7187               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
7188               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
7189               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
7190               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
7191               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
7192               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
7193               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
7194               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
7195               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
7196               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
7197               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
7198               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
7199               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
7200               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
7201               exit
7202             endif
7203           enddo
7204         endif
7205       enddo
7206       return
7207       end
7208 c------------------------------------------------------------------------------
7209       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
7210      &  n_corr1)
7211 C This subroutine calculates multi-body contributions to hydrogen-bonding
7212       implicit real*8 (a-h,o-z)
7213       include 'DIMENSIONS'
7214       include 'COMMON.IOUNITS'
7215 #ifdef MPI
7216       include "mpif.h"
7217       parameter (max_cont=maxconts)
7218       parameter (max_dim=70)
7219       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7220       double precision zapas(max_dim,maxconts,max_fg_procs),
7221      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7222       common /przechowalnia/ zapas
7223       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7224      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7225 #endif
7226       include 'COMMON.SETUP'
7227       include 'COMMON.FFIELD'
7228       include 'COMMON.DERIV'
7229       include 'COMMON.LOCAL'
7230       include 'COMMON.INTERACT'
7231       include 'COMMON.CONTACTS'
7232       include 'COMMON.CHAIN'
7233       include 'COMMON.CONTROL'
7234       double precision gx(3),gx1(3)
7235       integer num_cont_hb_old(maxres)
7236       logical lprn,ldone
7237       double precision eello4,eello5,eelo6,eello_turn6
7238       external eello4,eello5,eello6,eello_turn6
7239 C Set lprn=.true. for debugging
7240       lprn=.false.
7241       eturn6=0.0d0
7242 #ifdef MPI
7243       do i=1,nres
7244         num_cont_hb_old(i)=num_cont_hb(i)
7245       enddo
7246       n_corr=0
7247       n_corr1=0
7248       if (nfgtasks.le.1) goto 30
7249       if (lprn) then
7250         write (iout,'(a)') 'Contact function values before RECEIVE:'
7251         do i=nnt,nct-2
7252           write (iout,'(2i3,50(1x,i2,f5.2))')
7253      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7254      &    j=1,num_cont_hb(i))
7255         enddo
7256       endif
7257       call flush(iout)
7258       do i=1,ntask_cont_from
7259         ncont_recv(i)=0
7260       enddo
7261       do i=1,ntask_cont_to
7262         ncont_sent(i)=0
7263       enddo
7264 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7265 c     & ntask_cont_to
7266 C Make the list of contacts to send to send to other procesors
7267       do i=iturn3_start,iturn3_end
7268 c        write (iout,*) "make contact list turn3",i," num_cont",
7269 c     &    num_cont_hb(i)
7270         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
7271       enddo
7272       do i=iturn4_start,iturn4_end
7273 c        write (iout,*) "make contact list turn4",i," num_cont",
7274 c     &   num_cont_hb(i)
7275         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
7276       enddo
7277       do ii=1,nat_sent
7278         i=iat_sent(ii)
7279 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7280 c     &    num_cont_hb(i)
7281         do j=1,num_cont_hb(i)
7282         do k=1,4
7283           jjc=jcont_hb(j,i)
7284           iproc=iint_sent_local(k,jjc,ii)
7285 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7286           if (iproc.ne.0) then
7287             ncont_sent(iproc)=ncont_sent(iproc)+1
7288             nn=ncont_sent(iproc)
7289             zapas(1,nn,iproc)=i
7290             zapas(2,nn,iproc)=jjc
7291             zapas(3,nn,iproc)=d_cont(j,i)
7292             ind=3
7293             do kk=1,3
7294               ind=ind+1
7295               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
7296             enddo
7297             do kk=1,2
7298               do ll=1,2
7299                 ind=ind+1
7300                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
7301               enddo
7302             enddo
7303             do jj=1,5
7304               do kk=1,3
7305                 do ll=1,2
7306                   do mm=1,2
7307                     ind=ind+1
7308                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
7309                   enddo
7310                 enddo
7311               enddo
7312             enddo
7313           endif
7314         enddo
7315         enddo
7316       enddo
7317       if (lprn) then
7318       write (iout,*)
7319      &  "Numbers of contacts to be sent to other processors",
7320      &  (ncont_sent(i),i=1,ntask_cont_to)
7321       write (iout,*) "Contacts sent"
7322       do ii=1,ntask_cont_to
7323         nn=ncont_sent(ii)
7324         iproc=itask_cont_to(ii)
7325         write (iout,*) nn," contacts to processor",iproc,
7326      &   " of CONT_TO_COMM group"
7327         do i=1,nn
7328           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
7329         enddo
7330       enddo
7331       call flush(iout)
7332       endif
7333       CorrelType=477
7334       CorrelID=fg_rank+1
7335       CorrelType1=478
7336       CorrelID1=nfgtasks+fg_rank+1
7337       ireq=0
7338 C Receive the numbers of needed contacts from other processors
7339       do ii=1,ntask_cont_from
7340         iproc=itask_cont_from(ii)
7341         ireq=ireq+1
7342         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7343      &    FG_COMM,req(ireq),IERR)
7344       enddo
7345 c      write (iout,*) "IRECV ended"
7346 c      call flush(iout)
7347 C Send the number of contacts needed by other processors
7348       do ii=1,ntask_cont_to
7349         iproc=itask_cont_to(ii)
7350         ireq=ireq+1
7351         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7352      &    FG_COMM,req(ireq),IERR)
7353       enddo
7354 c      write (iout,*) "ISEND ended"
7355 c      write (iout,*) "number of requests (nn)",ireq
7356       call flush(iout)
7357       if (ireq.gt.0)
7358      &  call MPI_Waitall(ireq,req,status_array,ierr)
7359 c      write (iout,*)
7360 c     &  "Numbers of contacts to be received from other processors",
7361 c     &  (ncont_recv(i),i=1,ntask_cont_from)
7362 c      call flush(iout)
7363 C Receive contacts
7364       ireq=0
7365       do ii=1,ntask_cont_from
7366         iproc=itask_cont_from(ii)
7367         nn=ncont_recv(ii)
7368 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7369 c     &   " of CONT_TO_COMM group"
7370         call flush(iout)
7371         if (nn.gt.0) then
7372           ireq=ireq+1
7373           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
7374      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7375 c          write (iout,*) "ireq,req",ireq,req(ireq)
7376         endif
7377       enddo
7378 C Send the contacts to processors that need them
7379       do ii=1,ntask_cont_to
7380         iproc=itask_cont_to(ii)
7381         nn=ncont_sent(ii)
7382 c        write (iout,*) nn," contacts to processor",iproc,
7383 c     &   " of CONT_TO_COMM group"
7384         if (nn.gt.0) then
7385           ireq=ireq+1
7386           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
7387      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7388 c          write (iout,*) "ireq,req",ireq,req(ireq)
7389 c          do i=1,nn
7390 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7391 c          enddo
7392         endif
7393       enddo
7394 c      write (iout,*) "number of requests (contacts)",ireq
7395 c      write (iout,*) "req",(req(i),i=1,4)
7396 c      call flush(iout)
7397       if (ireq.gt.0)
7398      & call MPI_Waitall(ireq,req,status_array,ierr)
7399       do iii=1,ntask_cont_from
7400         iproc=itask_cont_from(iii)
7401         nn=ncont_recv(iii)
7402         if (lprn) then
7403         write (iout,*) "Received",nn," contacts from processor",iproc,
7404      &   " of CONT_FROM_COMM group"
7405         call flush(iout)
7406         do i=1,nn
7407           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
7408         enddo
7409         call flush(iout)
7410         endif
7411         do i=1,nn
7412           ii=zapas_recv(1,i,iii)
7413 c Flag the received contacts to prevent double-counting
7414           jj=-zapas_recv(2,i,iii)
7415 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7416 c          call flush(iout)
7417           nnn=num_cont_hb(ii)+1
7418           num_cont_hb(ii)=nnn
7419           jcont_hb(nnn,ii)=jj
7420           d_cont(nnn,ii)=zapas_recv(3,i,iii)
7421           ind=3
7422           do kk=1,3
7423             ind=ind+1
7424             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
7425           enddo
7426           do kk=1,2
7427             do ll=1,2
7428               ind=ind+1
7429               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
7430             enddo
7431           enddo
7432           do jj=1,5
7433             do kk=1,3
7434               do ll=1,2
7435                 do mm=1,2
7436                   ind=ind+1
7437                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
7438                 enddo
7439               enddo
7440             enddo
7441           enddo
7442         enddo
7443       enddo
7444       call flush(iout)
7445       if (lprn) then
7446         write (iout,'(a)') 'Contact function values after receive:'
7447         do i=nnt,nct-2
7448           write (iout,'(2i3,50(1x,i3,5f6.3))')
7449      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7450      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7451         enddo
7452         call flush(iout)
7453       endif
7454    30 continue
7455 #endif
7456       if (lprn) then
7457         write (iout,'(a)') 'Contact function values:'
7458         do i=nnt,nct-2
7459           write (iout,'(2i3,50(1x,i2,5f6.3))')
7460      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7461      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7462         enddo
7463       endif
7464       ecorr=0.0D0
7465       ecorr5=0.0d0
7466       ecorr6=0.0d0
7467 C Remove the loop below after debugging !!!
7468       do i=nnt,nct
7469         do j=1,3
7470           gradcorr(j,i)=0.0D0
7471           gradxorr(j,i)=0.0D0
7472         enddo
7473       enddo
7474 C Calculate the dipole-dipole interaction energies
7475       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7476       do i=iatel_s,iatel_e+1
7477         num_conti=num_cont_hb(i)
7478         do jj=1,num_conti
7479           j=jcont_hb(jj,i)
7480 #ifdef MOMENT
7481           call dipole(i,j,jj)
7482 #endif
7483         enddo
7484       enddo
7485       endif
7486 C Calculate the local-electrostatic correlation terms
7487 c                write (iout,*) "gradcorr5 in eello5 before loop"
7488 c                do iii=1,nres
7489 c                  write (iout,'(i5,3f10.5)')
7490 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7491 c                enddo
7492       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7493 c        write (iout,*) "corr loop i",i
7494         i1=i+1
7495         num_conti=num_cont_hb(i)
7496         num_conti1=num_cont_hb(i+1)
7497         do jj=1,num_conti
7498           j=jcont_hb(jj,i)
7499           jp=iabs(j)
7500           do kk=1,num_conti1
7501             j1=jcont_hb(kk,i1)
7502             jp1=iabs(j1)
7503 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7504 c     &         ' jj=',jj,' kk=',kk
7505 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
7506             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7507      &          .or. j.lt.0 .and. j1.gt.0) .and.
7508      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7509 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7510 C The system gains extra energy.
7511               n_corr=n_corr+1
7512               sqd1=dsqrt(d_cont(jj,i))
7513               sqd2=dsqrt(d_cont(kk,i1))
7514               sred_geom = sqd1*sqd2
7515               IF (sred_geom.lt.cutoff_corr) THEN
7516                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
7517      &            ekont,fprimcont)
7518 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7519 cd     &         ' jj=',jj,' kk=',kk
7520                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7521                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7522                 do l=1,3
7523                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7524                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7525                 enddo
7526                 n_corr1=n_corr1+1
7527 cd               write (iout,*) 'sred_geom=',sred_geom,
7528 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
7529 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7530 cd               write (iout,*) "g_contij",g_contij
7531 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7532 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7533                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7534                 if (wcorr4.gt.0.0d0)
7535      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7536                   if (energy_dec.and.wcorr4.gt.0.0d0)
7537      1                 write (iout,'(a6,4i5,0pf7.3)')
7538      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7539 c                write (iout,*) "gradcorr5 before eello5"
7540 c                do iii=1,nres
7541 c                  write (iout,'(i5,3f10.5)')
7542 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7543 c                enddo
7544                 if (wcorr5.gt.0.0d0)
7545      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7546 c                write (iout,*) "gradcorr5 after eello5"
7547 c                do iii=1,nres
7548 c                  write (iout,'(i5,3f10.5)')
7549 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7550 c                enddo
7551                   if (energy_dec.and.wcorr5.gt.0.0d0)
7552      1                 write (iout,'(a6,4i5,0pf7.3)')
7553      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7554 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7555 cd                write(2,*)'ijkl',i,jp,i+1,jp1
7556                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
7557      &               .or. wturn6.eq.0.0d0))then
7558 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7559                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7560                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7561      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7562 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7563 cd     &            'ecorr6=',ecorr6
7564 cd                write (iout,'(4e15.5)') sred_geom,
7565 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7566 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7567 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7568                 else if (wturn6.gt.0.0d0
7569      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7570 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7571                   eturn6=eturn6+eello_turn6(i,jj,kk)
7572                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7573      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7574 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
7575                 endif
7576               ENDIF
7577 1111          continue
7578             endif
7579           enddo ! kk
7580         enddo ! jj
7581       enddo ! i
7582       do i=1,nres
7583         num_cont_hb(i)=num_cont_hb_old(i)
7584       enddo
7585 c                write (iout,*) "gradcorr5 in eello5"
7586 c                do iii=1,nres
7587 c                  write (iout,'(i5,3f10.5)')
7588 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7589 c                enddo
7590       return
7591       end
7592 c------------------------------------------------------------------------------
7593       subroutine add_hb_contact_eello(ii,jj,itask)
7594       implicit real*8 (a-h,o-z)
7595       include "DIMENSIONS"
7596       include "COMMON.IOUNITS"
7597       integer max_cont
7598       integer max_dim
7599       parameter (max_cont=maxconts)
7600       parameter (max_dim=70)
7601       include "COMMON.CONTACTS"
7602       double precision zapas(max_dim,maxconts,max_fg_procs),
7603      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7604       common /przechowalnia/ zapas
7605       integer i,j,ii,jj,iproc,itask(4),nn
7606 c      write (iout,*) "itask",itask
7607       do i=1,2
7608         iproc=itask(i)
7609         if (iproc.gt.0) then
7610           do j=1,num_cont_hb(ii)
7611             jjc=jcont_hb(j,ii)
7612 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
7613             if (jjc.eq.jj) then
7614               ncont_sent(iproc)=ncont_sent(iproc)+1
7615               nn=ncont_sent(iproc)
7616               zapas(1,nn,iproc)=ii
7617               zapas(2,nn,iproc)=jjc
7618               zapas(3,nn,iproc)=d_cont(j,ii)
7619               ind=3
7620               do kk=1,3
7621                 ind=ind+1
7622                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
7623               enddo
7624               do kk=1,2
7625                 do ll=1,2
7626                   ind=ind+1
7627                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
7628                 enddo
7629               enddo
7630               do jj=1,5
7631                 do kk=1,3
7632                   do ll=1,2
7633                     do mm=1,2
7634                       ind=ind+1
7635                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
7636                     enddo
7637                   enddo
7638                 enddo
7639               enddo
7640               exit
7641             endif
7642           enddo
7643         endif
7644       enddo
7645       return
7646       end
7647 c------------------------------------------------------------------------------
7648       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7649       implicit real*8 (a-h,o-z)
7650       include 'DIMENSIONS'
7651       include 'COMMON.IOUNITS'
7652       include 'COMMON.DERIV'
7653       include 'COMMON.INTERACT'
7654       include 'COMMON.CONTACTS'
7655       double precision gx(3),gx1(3)
7656       logical lprn
7657       lprn=.false.
7658       eij=facont_hb(jj,i)
7659       ekl=facont_hb(kk,k)
7660       ees0pij=ees0p(jj,i)
7661       ees0pkl=ees0p(kk,k)
7662       ees0mij=ees0m(jj,i)
7663       ees0mkl=ees0m(kk,k)
7664       ekont=eij*ekl
7665       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7666 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7667 C Following 4 lines for diagnostics.
7668 cd    ees0pkl=0.0D0
7669 cd    ees0pij=1.0D0
7670 cd    ees0mkl=0.0D0
7671 cd    ees0mij=1.0D0
7672 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7673 c     & 'Contacts ',i,j,
7674 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7675 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7676 c     & 'gradcorr_long'
7677 C Calculate the multi-body contribution to energy.
7678 c      ecorr=ecorr+ekont*ees
7679 C Calculate multi-body contributions to the gradient.
7680       coeffpees0pij=coeffp*ees0pij
7681       coeffmees0mij=coeffm*ees0mij
7682       coeffpees0pkl=coeffp*ees0pkl
7683       coeffmees0mkl=coeffm*ees0mkl
7684       do ll=1,3
7685 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7686         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
7687      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
7688      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
7689         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
7690      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
7691      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
7692 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7693         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
7694      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
7695      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
7696         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
7697      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
7698      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
7699         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
7700      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
7701      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
7702         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7703         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7704         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
7705      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
7706      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
7707         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7708         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7709 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7710       enddo
7711 c      write (iout,*)
7712 cgrad      do m=i+1,j-1
7713 cgrad        do ll=1,3
7714 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7715 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7716 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7717 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7718 cgrad        enddo
7719 cgrad      enddo
7720 cgrad      do m=k+1,l-1
7721 cgrad        do ll=1,3
7722 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7723 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7724 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7725 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7726 cgrad        enddo
7727 cgrad      enddo
7728 c      write (iout,*) "ehbcorr",ekont*ees
7729       ehbcorr=ekont*ees
7730       return
7731       end
7732 #ifdef MOMENT
7733 C---------------------------------------------------------------------------
7734       subroutine dipole(i,j,jj)
7735       implicit real*8 (a-h,o-z)
7736       include 'DIMENSIONS'
7737       include 'COMMON.IOUNITS'
7738       include 'COMMON.CHAIN'
7739       include 'COMMON.FFIELD'
7740       include 'COMMON.DERIV'
7741       include 'COMMON.INTERACT'
7742       include 'COMMON.CONTACTS'
7743       include 'COMMON.TORSION'
7744       include 'COMMON.VAR'
7745       include 'COMMON.GEO'
7746       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7747      &  auxmat(2,2)
7748       iti1 = itortyp(itype(i+1))
7749       if (j.lt.nres-1) then
7750         itj1 = itortyp(itype(j+1))
7751       else
7752         itj1=ntortyp+1
7753       endif
7754       do iii=1,2
7755         dipi(iii,1)=Ub2(iii,i)
7756         dipderi(iii)=Ub2der(iii,i)
7757         dipi(iii,2)=b1(iii,iti1)
7758         dipj(iii,1)=Ub2(iii,j)
7759         dipderj(iii)=Ub2der(iii,j)
7760         dipj(iii,2)=b1(iii,itj1)
7761       enddo
7762       kkk=0
7763       do iii=1,2
7764         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7765         do jjj=1,2
7766           kkk=kkk+1
7767           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7768         enddo
7769       enddo
7770       do kkk=1,5
7771         do lll=1,3
7772           mmm=0
7773           do iii=1,2
7774             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7775      &        auxvec(1))
7776             do jjj=1,2
7777               mmm=mmm+1
7778               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7779             enddo
7780           enddo
7781         enddo
7782       enddo
7783       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7784       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7785       do iii=1,2
7786         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7787       enddo
7788       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7789       do iii=1,2
7790         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7791       enddo
7792       return
7793       end
7794 #endif
7795 C---------------------------------------------------------------------------
7796       subroutine calc_eello(i,j,k,l,jj,kk)
7797 C
7798 C This subroutine computes matrices and vectors needed to calculate
7799 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7800 C
7801       implicit real*8 (a-h,o-z)
7802       include 'DIMENSIONS'
7803       include 'COMMON.IOUNITS'
7804       include 'COMMON.CHAIN'
7805       include 'COMMON.DERIV'
7806       include 'COMMON.INTERACT'
7807       include 'COMMON.CONTACTS'
7808       include 'COMMON.TORSION'
7809       include 'COMMON.VAR'
7810       include 'COMMON.GEO'
7811       include 'COMMON.FFIELD'
7812       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7813      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7814       logical lprn
7815       common /kutas/ lprn
7816 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7817 cd     & ' jj=',jj,' kk=',kk
7818 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7819 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7820 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7821       do iii=1,2
7822         do jjj=1,2
7823           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7824           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7825         enddo
7826       enddo
7827       call transpose2(aa1(1,1),aa1t(1,1))
7828       call transpose2(aa2(1,1),aa2t(1,1))
7829       do kkk=1,5
7830         do lll=1,3
7831           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7832      &      aa1tder(1,1,lll,kkk))
7833           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7834      &      aa2tder(1,1,lll,kkk))
7835         enddo
7836       enddo
7837       if (l.eq.j+1) then
7838 C parallel orientation of the two CA-CA-CA frames.
7839         if (i.gt.1) then
7840           iti=itortyp(itype(i))
7841         else
7842           iti=ntortyp+1
7843         endif
7844         itk1=itortyp(itype(k+1))
7845         itj=itortyp(itype(j))
7846         if (l.lt.nres-1) then
7847           itl1=itortyp(itype(l+1))
7848         else
7849           itl1=ntortyp+1
7850         endif
7851 C A1 kernel(j+1) A2T
7852 cd        do iii=1,2
7853 cd          write (iout,'(3f10.5,5x,3f10.5)')
7854 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7855 cd        enddo
7856         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7857      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7858      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7859 C Following matrices are needed only for 6-th order cumulants
7860         IF (wcorr6.gt.0.0d0) THEN
7861         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7862      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7863      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7864         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7865      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7866      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7867      &   ADtEAderx(1,1,1,1,1,1))
7868         lprn=.false.
7869         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7870      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7871      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7872      &   ADtEA1derx(1,1,1,1,1,1))
7873         ENDIF
7874 C End 6-th order cumulants
7875 cd        lprn=.false.
7876 cd        if (lprn) then
7877 cd        write (2,*) 'In calc_eello6'
7878 cd        do iii=1,2
7879 cd          write (2,*) 'iii=',iii
7880 cd          do kkk=1,5
7881 cd            write (2,*) 'kkk=',kkk
7882 cd            do jjj=1,2
7883 cd              write (2,'(3(2f10.5),5x)')
7884 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7885 cd            enddo
7886 cd          enddo
7887 cd        enddo
7888 cd        endif
7889         call transpose2(EUgder(1,1,k),auxmat(1,1))
7890         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7891         call transpose2(EUg(1,1,k),auxmat(1,1))
7892         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7893         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7894         do iii=1,2
7895           do kkk=1,5
7896             do lll=1,3
7897               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7898      &          EAEAderx(1,1,lll,kkk,iii,1))
7899             enddo
7900           enddo
7901         enddo
7902 C A1T kernel(i+1) A2
7903         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7904      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7905      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7906 C Following matrices are needed only for 6-th order cumulants
7907         IF (wcorr6.gt.0.0d0) THEN
7908         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7909      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7910      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7911         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7912      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7913      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7914      &   ADtEAderx(1,1,1,1,1,2))
7915         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7916      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7917      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7918      &   ADtEA1derx(1,1,1,1,1,2))
7919         ENDIF
7920 C End 6-th order cumulants
7921         call transpose2(EUgder(1,1,l),auxmat(1,1))
7922         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7923         call transpose2(EUg(1,1,l),auxmat(1,1))
7924         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7925         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7926         do iii=1,2
7927           do kkk=1,5
7928             do lll=1,3
7929               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7930      &          EAEAderx(1,1,lll,kkk,iii,2))
7931             enddo
7932           enddo
7933         enddo
7934 C AEAb1 and AEAb2
7935 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7936 C They are needed only when the fifth- or the sixth-order cumulants are
7937 C indluded.
7938         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7939         call transpose2(AEA(1,1,1),auxmat(1,1))
7940         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7941         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7942         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7943         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7944         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7945         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7946         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7947         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7948         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7949         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7950         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7951         call transpose2(AEA(1,1,2),auxmat(1,1))
7952         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7953         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7954         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7955         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7956         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7957         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7958         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7959         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7960         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7961         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7962         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7963 C Calculate the Cartesian derivatives of the vectors.
7964         do iii=1,2
7965           do kkk=1,5
7966             do lll=1,3
7967               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7968               call matvec2(auxmat(1,1),b1(1,iti),
7969      &          AEAb1derx(1,lll,kkk,iii,1,1))
7970               call matvec2(auxmat(1,1),Ub2(1,i),
7971      &          AEAb2derx(1,lll,kkk,iii,1,1))
7972               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7973      &          AEAb1derx(1,lll,kkk,iii,2,1))
7974               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7975      &          AEAb2derx(1,lll,kkk,iii,2,1))
7976               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7977               call matvec2(auxmat(1,1),b1(1,itj),
7978      &          AEAb1derx(1,lll,kkk,iii,1,2))
7979               call matvec2(auxmat(1,1),Ub2(1,j),
7980      &          AEAb2derx(1,lll,kkk,iii,1,2))
7981               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7982      &          AEAb1derx(1,lll,kkk,iii,2,2))
7983               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7984      &          AEAb2derx(1,lll,kkk,iii,2,2))
7985             enddo
7986           enddo
7987         enddo
7988         ENDIF
7989 C End vectors
7990       else
7991 C Antiparallel orientation of the two CA-CA-CA frames.
7992         if (i.gt.1) then
7993           iti=itortyp(itype(i))
7994         else
7995           iti=ntortyp+1
7996         endif
7997         itk1=itortyp(itype(k+1))
7998         itl=itortyp(itype(l))
7999         itj=itortyp(itype(j))
8000         if (j.lt.nres-1) then
8001           itj1=itortyp(itype(j+1))
8002         else
8003           itj1=ntortyp+1
8004         endif
8005 C A2 kernel(j-1)T A1T
8006         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8007      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
8008      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8009 C Following matrices are needed only for 6-th order cumulants
8010         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8011      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8012         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8013      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
8014      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8015         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8016      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
8017      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8018      &   ADtEAderx(1,1,1,1,1,1))
8019         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8020      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
8021      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8022      &   ADtEA1derx(1,1,1,1,1,1))
8023         ENDIF
8024 C End 6-th order cumulants
8025         call transpose2(EUgder(1,1,k),auxmat(1,1))
8026         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8027         call transpose2(EUg(1,1,k),auxmat(1,1))
8028         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8029         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8030         do iii=1,2
8031           do kkk=1,5
8032             do lll=1,3
8033               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8034      &          EAEAderx(1,1,lll,kkk,iii,1))
8035             enddo
8036           enddo
8037         enddo
8038 C A2T kernel(i+1)T A1
8039         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8040      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
8041      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8042 C Following matrices are needed only for 6-th order cumulants
8043         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8044      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8045         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8046      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
8047      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8048         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8049      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
8050      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8051      &   ADtEAderx(1,1,1,1,1,2))
8052         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8053      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
8054      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8055      &   ADtEA1derx(1,1,1,1,1,2))
8056         ENDIF
8057 C End 6-th order cumulants
8058         call transpose2(EUgder(1,1,j),auxmat(1,1))
8059         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
8060         call transpose2(EUg(1,1,j),auxmat(1,1))
8061         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8062         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8063         do iii=1,2
8064           do kkk=1,5
8065             do lll=1,3
8066               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8067      &          EAEAderx(1,1,lll,kkk,iii,2))
8068             enddo
8069           enddo
8070         enddo
8071 C AEAb1 and AEAb2
8072 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8073 C They are needed only when the fifth- or the sixth-order cumulants are
8074 C indluded.
8075         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
8076      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
8077         call transpose2(AEA(1,1,1),auxmat(1,1))
8078         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
8079         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8080         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8081         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8082         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
8083         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8084         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
8085         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
8086         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8087         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8088         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8089         call transpose2(AEA(1,1,2),auxmat(1,1))
8090         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
8091         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
8092         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
8093         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8094         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
8095         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
8096         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
8097         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
8098         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
8099         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
8100         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
8101 C Calculate the Cartesian derivatives of the vectors.
8102         do iii=1,2
8103           do kkk=1,5
8104             do lll=1,3
8105               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8106               call matvec2(auxmat(1,1),b1(1,iti),
8107      &          AEAb1derx(1,lll,kkk,iii,1,1))
8108               call matvec2(auxmat(1,1),Ub2(1,i),
8109      &          AEAb2derx(1,lll,kkk,iii,1,1))
8110               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8111      &          AEAb1derx(1,lll,kkk,iii,2,1))
8112               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8113      &          AEAb2derx(1,lll,kkk,iii,2,1))
8114               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8115               call matvec2(auxmat(1,1),b1(1,itl),
8116      &          AEAb1derx(1,lll,kkk,iii,1,2))
8117               call matvec2(auxmat(1,1),Ub2(1,l),
8118      &          AEAb2derx(1,lll,kkk,iii,1,2))
8119               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
8120      &          AEAb1derx(1,lll,kkk,iii,2,2))
8121               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
8122      &          AEAb2derx(1,lll,kkk,iii,2,2))
8123             enddo
8124           enddo
8125         enddo
8126         ENDIF
8127 C End vectors
8128       endif
8129       return
8130       end
8131 C---------------------------------------------------------------------------
8132       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
8133      &  KK,KKderg,AKA,AKAderg,AKAderx)
8134       implicit none
8135       integer nderg
8136       logical transp
8137       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
8138      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
8139      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
8140       integer iii,kkk,lll
8141       integer jjj,mmm
8142       logical lprn
8143       common /kutas/ lprn
8144       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
8145       do iii=1,nderg
8146         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
8147      &    AKAderg(1,1,iii))
8148       enddo
8149 cd      if (lprn) write (2,*) 'In kernel'
8150       do kkk=1,5
8151 cd        if (lprn) write (2,*) 'kkk=',kkk
8152         do lll=1,3
8153           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
8154      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
8155 cd          if (lprn) then
8156 cd            write (2,*) 'lll=',lll
8157 cd            write (2,*) 'iii=1'
8158 cd            do jjj=1,2
8159 cd              write (2,'(3(2f10.5),5x)')
8160 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
8161 cd            enddo
8162 cd          endif
8163           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
8164      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
8165 cd          if (lprn) then
8166 cd            write (2,*) 'lll=',lll
8167 cd            write (2,*) 'iii=2'
8168 cd            do jjj=1,2
8169 cd              write (2,'(3(2f10.5),5x)')
8170 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
8171 cd            enddo
8172 cd          endif
8173         enddo
8174       enddo
8175       return
8176       end
8177 C---------------------------------------------------------------------------
8178       double precision function eello4(i,j,k,l,jj,kk)
8179       implicit real*8 (a-h,o-z)
8180       include 'DIMENSIONS'
8181       include 'COMMON.IOUNITS'
8182       include 'COMMON.CHAIN'
8183       include 'COMMON.DERIV'
8184       include 'COMMON.INTERACT'
8185       include 'COMMON.CONTACTS'
8186       include 'COMMON.TORSION'
8187       include 'COMMON.VAR'
8188       include 'COMMON.GEO'
8189       double precision pizda(2,2),ggg1(3),ggg2(3)
8190 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8191 cd        eello4=0.0d0
8192 cd        return
8193 cd      endif
8194 cd      print *,'eello4:',i,j,k,l,jj,kk
8195 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
8196 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
8197 cold      eij=facont_hb(jj,i)
8198 cold      ekl=facont_hb(kk,k)
8199 cold      ekont=eij*ekl
8200       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8201 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8202       gcorr_loc(k-1)=gcorr_loc(k-1)
8203      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8204       if (l.eq.j+1) then
8205         gcorr_loc(l-1)=gcorr_loc(l-1)
8206      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8207       else
8208         gcorr_loc(j-1)=gcorr_loc(j-1)
8209      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8210       endif
8211       do iii=1,2
8212         do kkk=1,5
8213           do lll=1,3
8214             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
8215      &                        -EAEAderx(2,2,lll,kkk,iii,1)
8216 cd            derx(lll,kkk,iii)=0.0d0
8217           enddo
8218         enddo
8219       enddo
8220 cd      gcorr_loc(l-1)=0.0d0
8221 cd      gcorr_loc(j-1)=0.0d0
8222 cd      gcorr_loc(k-1)=0.0d0
8223 cd      eel4=1.0d0
8224 cd      write (iout,*)'Contacts have occurred for peptide groups',
8225 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
8226 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8227       if (j.lt.nres-1) then
8228         j1=j+1
8229         j2=j-1
8230       else
8231         j1=j-1
8232         j2=j-2
8233       endif
8234       if (l.lt.nres-1) then
8235         l1=l+1
8236         l2=l-1
8237       else
8238         l1=l-1
8239         l2=l-2
8240       endif
8241       do ll=1,3
8242 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
8243 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
8244         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8245         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8246 cgrad        ghalf=0.5d0*ggg1(ll)
8247         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8248         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8249         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8250         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8251         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8252         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8253 cgrad        ghalf=0.5d0*ggg2(ll)
8254         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8255         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8256         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8257         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8258         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8259         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8260       enddo
8261 cgrad      do m=i+1,j-1
8262 cgrad        do ll=1,3
8263 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
8264 cgrad        enddo
8265 cgrad      enddo
8266 cgrad      do m=k+1,l-1
8267 cgrad        do ll=1,3
8268 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
8269 cgrad        enddo
8270 cgrad      enddo
8271 cgrad      do m=i+2,j2
8272 cgrad        do ll=1,3
8273 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8274 cgrad        enddo
8275 cgrad      enddo
8276 cgrad      do m=k+2,l2
8277 cgrad        do ll=1,3
8278 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8279 cgrad        enddo
8280 cgrad      enddo
8281 cd      do iii=1,nres-3
8282 cd        write (2,*) iii,gcorr_loc(iii)
8283 cd      enddo
8284       eello4=ekont*eel4
8285 cd      write (2,*) 'ekont',ekont
8286 cd      write (iout,*) 'eello4',ekont*eel4
8287       return
8288       end
8289 C---------------------------------------------------------------------------
8290       double precision function eello5(i,j,k,l,jj,kk)
8291       implicit real*8 (a-h,o-z)
8292       include 'DIMENSIONS'
8293       include 'COMMON.IOUNITS'
8294       include 'COMMON.CHAIN'
8295       include 'COMMON.DERIV'
8296       include 'COMMON.INTERACT'
8297       include 'COMMON.CONTACTS'
8298       include 'COMMON.TORSION'
8299       include 'COMMON.VAR'
8300       include 'COMMON.GEO'
8301       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
8302       double precision ggg1(3),ggg2(3)
8303 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8304 C                                                                              C
8305 C                            Parallel chains                                   C
8306 C                                                                              C
8307 C          o             o                   o             o                   C
8308 C         /l\           / \             \   / \           / \   /              C
8309 C        /   \         /   \             \ /   \         /   \ /               C
8310 C       j| o |l1       | o |              o| o |         | o |o                C
8311 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8312 C      \i/   \         /   \ /             /   \         /   \                 C
8313 C       o    k1             o                                                  C
8314 C         (I)          (II)                (III)          (IV)                 C
8315 C                                                                              C
8316 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8317 C                                                                              C
8318 C                            Antiparallel chains                               C
8319 C                                                                              C
8320 C          o             o                   o             o                   C
8321 C         /j\           / \             \   / \           / \   /              C
8322 C        /   \         /   \             \ /   \         /   \ /               C
8323 C      j1| o |l        | o |              o| o |         | o |o                C
8324 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8325 C      \i/   \         /   \ /             /   \         /   \                 C
8326 C       o     k1            o                                                  C
8327 C         (I)          (II)                (III)          (IV)                 C
8328 C                                                                              C
8329 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8330 C                                                                              C
8331 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
8332 C                                                                              C
8333 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8334 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8335 cd        eello5=0.0d0
8336 cd        return
8337 cd      endif
8338 cd      write (iout,*)
8339 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8340 cd     &   ' and',k,l
8341       itk=itortyp(itype(k))
8342       itl=itortyp(itype(l))
8343       itj=itortyp(itype(j))
8344       eello5_1=0.0d0
8345       eello5_2=0.0d0
8346       eello5_3=0.0d0
8347       eello5_4=0.0d0
8348 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8349 cd     &   eel5_3_num,eel5_4_num)
8350       do iii=1,2
8351         do kkk=1,5
8352           do lll=1,3
8353             derx(lll,kkk,iii)=0.0d0
8354           enddo
8355         enddo
8356       enddo
8357 cd      eij=facont_hb(jj,i)
8358 cd      ekl=facont_hb(kk,k)
8359 cd      ekont=eij*ekl
8360 cd      write (iout,*)'Contacts have occurred for peptide groups',
8361 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
8362 cd      goto 1111
8363 C Contribution from the graph I.
8364 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8365 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8366       call transpose2(EUg(1,1,k),auxmat(1,1))
8367       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8368       vv(1)=pizda(1,1)-pizda(2,2)
8369       vv(2)=pizda(1,2)+pizda(2,1)
8370       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
8371      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8372 C Explicit gradient in virtual-dihedral angles.
8373       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
8374      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
8375      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8376       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8377       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8378       vv(1)=pizda(1,1)-pizda(2,2)
8379       vv(2)=pizda(1,2)+pizda(2,1)
8380       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8381      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
8382      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8383       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8384       vv(1)=pizda(1,1)-pizda(2,2)
8385       vv(2)=pizda(1,2)+pizda(2,1)
8386       if (l.eq.j+1) then
8387         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
8388      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8389      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8390       else
8391         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
8392      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8393      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8394       endif
8395 C Cartesian gradient
8396       do iii=1,2
8397         do kkk=1,5
8398           do lll=1,3
8399             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
8400      &        pizda(1,1))
8401             vv(1)=pizda(1,1)-pizda(2,2)
8402             vv(2)=pizda(1,2)+pizda(2,1)
8403             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8404      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
8405      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8406           enddo
8407         enddo
8408       enddo
8409 c      goto 1112
8410 c1111  continue
8411 C Contribution from graph II
8412       call transpose2(EE(1,1,itk),auxmat(1,1))
8413       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8414       vv(1)=pizda(1,1)+pizda(2,2)
8415       vv(2)=pizda(2,1)-pizda(1,2)
8416       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
8417      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
8418 C Explicit gradient in virtual-dihedral angles.
8419       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8420      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8421       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8422       vv(1)=pizda(1,1)+pizda(2,2)
8423       vv(2)=pizda(2,1)-pizda(1,2)
8424       if (l.eq.j+1) then
8425         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8426      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
8427      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8428       else
8429         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8430      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
8431      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8432       endif
8433 C Cartesian gradient
8434       do iii=1,2
8435         do kkk=1,5
8436           do lll=1,3
8437             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8438      &        pizda(1,1))
8439             vv(1)=pizda(1,1)+pizda(2,2)
8440             vv(2)=pizda(2,1)-pizda(1,2)
8441             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8442      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
8443      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
8444           enddo
8445         enddo
8446       enddo
8447 cd      goto 1112
8448 cd1111  continue
8449       if (l.eq.j+1) then
8450 cd        goto 1110
8451 C Parallel orientation
8452 C Contribution from graph III
8453         call transpose2(EUg(1,1,l),auxmat(1,1))
8454         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8455         vv(1)=pizda(1,1)-pizda(2,2)
8456         vv(2)=pizda(1,2)+pizda(2,1)
8457         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
8458      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8459 C Explicit gradient in virtual-dihedral angles.
8460         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8461      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
8462      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8463         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8464         vv(1)=pizda(1,1)-pizda(2,2)
8465         vv(2)=pizda(1,2)+pizda(2,1)
8466         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8467      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
8468      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8469         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8470         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8471         vv(1)=pizda(1,1)-pizda(2,2)
8472         vv(2)=pizda(1,2)+pizda(2,1)
8473         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8474      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
8475      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8476 C Cartesian gradient
8477         do iii=1,2
8478           do kkk=1,5
8479             do lll=1,3
8480               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8481      &          pizda(1,1))
8482               vv(1)=pizda(1,1)-pizda(2,2)
8483               vv(2)=pizda(1,2)+pizda(2,1)
8484               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8485      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
8486      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8487             enddo
8488           enddo
8489         enddo
8490 cd        goto 1112
8491 C Contribution from graph IV
8492 cd1110    continue
8493         call transpose2(EE(1,1,itl),auxmat(1,1))
8494         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8495         vv(1)=pizda(1,1)+pizda(2,2)
8496         vv(2)=pizda(2,1)-pizda(1,2)
8497         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
8498      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
8499 C Explicit gradient in virtual-dihedral angles.
8500         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8501      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8502         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8503         vv(1)=pizda(1,1)+pizda(2,2)
8504         vv(2)=pizda(2,1)-pizda(1,2)
8505         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8506      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
8507      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8508 C Cartesian gradient
8509         do iii=1,2
8510           do kkk=1,5
8511             do lll=1,3
8512               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8513      &          pizda(1,1))
8514               vv(1)=pizda(1,1)+pizda(2,2)
8515               vv(2)=pizda(2,1)-pizda(1,2)
8516               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8517      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
8518      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
8519             enddo
8520           enddo
8521         enddo
8522       else
8523 C Antiparallel orientation
8524 C Contribution from graph III
8525 c        goto 1110
8526         call transpose2(EUg(1,1,j),auxmat(1,1))
8527         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8528         vv(1)=pizda(1,1)-pizda(2,2)
8529         vv(2)=pizda(1,2)+pizda(2,1)
8530         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
8531      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8532 C Explicit gradient in virtual-dihedral angles.
8533         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8534      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
8535      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8536         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8537         vv(1)=pizda(1,1)-pizda(2,2)
8538         vv(2)=pizda(1,2)+pizda(2,1)
8539         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8540      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
8541      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8542         call transpose2(EUgder(1,1,j),auxmat1(1,1))
8543         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8544         vv(1)=pizda(1,1)-pizda(2,2)
8545         vv(2)=pizda(1,2)+pizda(2,1)
8546         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8547      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
8548      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8549 C Cartesian gradient
8550         do iii=1,2
8551           do kkk=1,5
8552             do lll=1,3
8553               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8554      &          pizda(1,1))
8555               vv(1)=pizda(1,1)-pizda(2,2)
8556               vv(2)=pizda(1,2)+pizda(2,1)
8557               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8558      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
8559      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8560             enddo
8561           enddo
8562         enddo
8563 cd        goto 1112
8564 C Contribution from graph IV
8565 1110    continue
8566         call transpose2(EE(1,1,itj),auxmat(1,1))
8567         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8568         vv(1)=pizda(1,1)+pizda(2,2)
8569         vv(2)=pizda(2,1)-pizda(1,2)
8570         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
8571      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
8572 C Explicit gradient in virtual-dihedral angles.
8573         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8574      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
8575         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8576         vv(1)=pizda(1,1)+pizda(2,2)
8577         vv(2)=pizda(2,1)-pizda(1,2)
8578         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8579      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
8580      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
8581 C Cartesian gradient
8582         do iii=1,2
8583           do kkk=1,5
8584             do lll=1,3
8585               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8586      &          pizda(1,1))
8587               vv(1)=pizda(1,1)+pizda(2,2)
8588               vv(2)=pizda(2,1)-pizda(1,2)
8589               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8590      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
8591      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
8592             enddo
8593           enddo
8594         enddo
8595       endif
8596 1112  continue
8597       eel5=eello5_1+eello5_2+eello5_3+eello5_4
8598 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
8599 cd        write (2,*) 'ijkl',i,j,k,l
8600 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
8601 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
8602 cd      endif
8603 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
8604 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
8605 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
8606 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
8607       if (j.lt.nres-1) then
8608         j1=j+1
8609         j2=j-1
8610       else
8611         j1=j-1
8612         j2=j-2
8613       endif
8614       if (l.lt.nres-1) then
8615         l1=l+1
8616         l2=l-1
8617       else
8618         l1=l-1
8619         l2=l-2
8620       endif
8621 cd      eij=1.0d0
8622 cd      ekl=1.0d0
8623 cd      ekont=1.0d0
8624 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
8625 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
8626 C        summed up outside the subrouine as for the other subroutines
8627 C        handling long-range interactions. The old code is commented out
8628 C        with "cgrad" to keep track of changes.
8629       do ll=1,3
8630 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
8631 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
8632         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
8633         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
8634 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
8635 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
8636 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
8637 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
8638 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
8639 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
8640 c     &   gradcorr5ij,
8641 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
8642 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
8643 cgrad        ghalf=0.5d0*ggg1(ll)
8644 cd        ghalf=0.0d0
8645         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
8646         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
8647         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
8648         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
8649         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
8650         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
8651 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
8652 cgrad        ghalf=0.5d0*ggg2(ll)
8653 cd        ghalf=0.0d0
8654         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
8655         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
8656         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
8657         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
8658         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
8659         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
8660       enddo
8661 cd      goto 1112
8662 cgrad      do m=i+1,j-1
8663 cgrad        do ll=1,3
8664 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
8665 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
8666 cgrad        enddo
8667 cgrad      enddo
8668 cgrad      do m=k+1,l-1
8669 cgrad        do ll=1,3
8670 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
8671 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
8672 cgrad        enddo
8673 cgrad      enddo
8674 c1112  continue
8675 cgrad      do m=i+2,j2
8676 cgrad        do ll=1,3
8677 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
8678 cgrad        enddo
8679 cgrad      enddo
8680 cgrad      do m=k+2,l2
8681 cgrad        do ll=1,3
8682 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
8683 cgrad        enddo
8684 cgrad      enddo
8685 cd      do iii=1,nres-3
8686 cd        write (2,*) iii,g_corr5_loc(iii)
8687 cd      enddo
8688       eello5=ekont*eel5
8689 cd      write (2,*) 'ekont',ekont
8690 cd      write (iout,*) 'eello5',ekont*eel5
8691       return
8692       end
8693 c--------------------------------------------------------------------------
8694       double precision function eello6(i,j,k,l,jj,kk)
8695       implicit real*8 (a-h,o-z)
8696       include 'DIMENSIONS'
8697       include 'COMMON.IOUNITS'
8698       include 'COMMON.CHAIN'
8699       include 'COMMON.DERIV'
8700       include 'COMMON.INTERACT'
8701       include 'COMMON.CONTACTS'
8702       include 'COMMON.TORSION'
8703       include 'COMMON.VAR'
8704       include 'COMMON.GEO'
8705       include 'COMMON.FFIELD'
8706       double precision ggg1(3),ggg2(3)
8707 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8708 cd        eello6=0.0d0
8709 cd        return
8710 cd      endif
8711 cd      write (iout,*)
8712 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8713 cd     &   ' and',k,l
8714       eello6_1=0.0d0
8715       eello6_2=0.0d0
8716       eello6_3=0.0d0
8717       eello6_4=0.0d0
8718       eello6_5=0.0d0
8719       eello6_6=0.0d0
8720 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8721 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8722       do iii=1,2
8723         do kkk=1,5
8724           do lll=1,3
8725             derx(lll,kkk,iii)=0.0d0
8726           enddo
8727         enddo
8728       enddo
8729 cd      eij=facont_hb(jj,i)
8730 cd      ekl=facont_hb(kk,k)
8731 cd      ekont=eij*ekl
8732 cd      eij=1.0d0
8733 cd      ekl=1.0d0
8734 cd      ekont=1.0d0
8735       if (l.eq.j+1) then
8736         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8737         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8738         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8739         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8740         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8741         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8742       else
8743         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8744         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8745         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8746         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8747         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8748           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8749         else
8750           eello6_5=0.0d0
8751         endif
8752         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8753       endif
8754 C If turn contributions are considered, they will be handled separately.
8755       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8756 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8757 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8758 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8759 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8760 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8761 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8762 cd      goto 1112
8763       if (j.lt.nres-1) then
8764         j1=j+1
8765         j2=j-1
8766       else
8767         j1=j-1
8768         j2=j-2
8769       endif
8770       if (l.lt.nres-1) then
8771         l1=l+1
8772         l2=l-1
8773       else
8774         l1=l-1
8775         l2=l-2
8776       endif
8777       do ll=1,3
8778 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8779 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8780 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8781 cgrad        ghalf=0.5d0*ggg1(ll)
8782 cd        ghalf=0.0d0
8783         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8784         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8785         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8786         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8787         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8788         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8789         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8790         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8791 cgrad        ghalf=0.5d0*ggg2(ll)
8792 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8793 cd        ghalf=0.0d0
8794         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8795         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8796         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8797         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8798         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8799         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8800       enddo
8801 cd      goto 1112
8802 cgrad      do m=i+1,j-1
8803 cgrad        do ll=1,3
8804 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8805 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8806 cgrad        enddo
8807 cgrad      enddo
8808 cgrad      do m=k+1,l-1
8809 cgrad        do ll=1,3
8810 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8811 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8812 cgrad        enddo
8813 cgrad      enddo
8814 cgrad1112  continue
8815 cgrad      do m=i+2,j2
8816 cgrad        do ll=1,3
8817 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8818 cgrad        enddo
8819 cgrad      enddo
8820 cgrad      do m=k+2,l2
8821 cgrad        do ll=1,3
8822 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8823 cgrad        enddo
8824 cgrad      enddo
8825 cd      do iii=1,nres-3
8826 cd        write (2,*) iii,g_corr6_loc(iii)
8827 cd      enddo
8828       eello6=ekont*eel6
8829 cd      write (2,*) 'ekont',ekont
8830 cd      write (iout,*) 'eello6',ekont*eel6
8831       return
8832       end
8833 c--------------------------------------------------------------------------
8834       double precision function eello6_graph1(i,j,k,l,imat,swap)
8835       implicit real*8 (a-h,o-z)
8836       include 'DIMENSIONS'
8837       include 'COMMON.IOUNITS'
8838       include 'COMMON.CHAIN'
8839       include 'COMMON.DERIV'
8840       include 'COMMON.INTERACT'
8841       include 'COMMON.CONTACTS'
8842       include 'COMMON.TORSION'
8843       include 'COMMON.VAR'
8844       include 'COMMON.GEO'
8845       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8846       logical swap
8847       logical lprn
8848       common /kutas/ lprn
8849 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8850 C
8851 C      Parallel       Antiparallel
8852 C
8853 C          o             o
8854 C         /l\           /j\
8855 C        /   \         /   \
8856 C       /| o |         | o |\
8857 C     \ j|/k\|  /   \  |/k\|l /
8858 C      \ /   \ /     \ /   \ /
8859 C       o     o       o     o
8860 C       i             i
8861 C
8862 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8863       itk=itortyp(itype(k))
8864       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8865       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8866       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8867       call transpose2(EUgC(1,1,k),auxmat(1,1))
8868       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8869       vv1(1)=pizda1(1,1)-pizda1(2,2)
8870       vv1(2)=pizda1(1,2)+pizda1(2,1)
8871       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8872       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8873       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8874       s5=scalar2(vv(1),Dtobr2(1,i))
8875 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8876       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8877       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8878      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8879      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8880      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8881      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8882      & +scalar2(vv(1),Dtobr2der(1,i)))
8883       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8884       vv1(1)=pizda1(1,1)-pizda1(2,2)
8885       vv1(2)=pizda1(1,2)+pizda1(2,1)
8886       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8887       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8888       if (l.eq.j+1) then
8889         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8890      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8891      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8892      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8893      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8894       else
8895         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8896      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8897      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8898      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8899      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8900       endif
8901       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8902       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8903       vv1(1)=pizda1(1,1)-pizda1(2,2)
8904       vv1(2)=pizda1(1,2)+pizda1(2,1)
8905       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8906      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8907      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8908      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8909       do iii=1,2
8910         if (swap) then
8911           ind=3-iii
8912         else
8913           ind=iii
8914         endif
8915         do kkk=1,5
8916           do lll=1,3
8917             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8918             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8919             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8920             call transpose2(EUgC(1,1,k),auxmat(1,1))
8921             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8922      &        pizda1(1,1))
8923             vv1(1)=pizda1(1,1)-pizda1(2,2)
8924             vv1(2)=pizda1(1,2)+pizda1(2,1)
8925             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8926             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8927      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8928             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8929      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8930             s5=scalar2(vv(1),Dtobr2(1,i))
8931             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8932           enddo
8933         enddo
8934       enddo
8935       return
8936       end
8937 c----------------------------------------------------------------------------
8938       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8939       implicit real*8 (a-h,o-z)
8940       include 'DIMENSIONS'
8941       include 'COMMON.IOUNITS'
8942       include 'COMMON.CHAIN'
8943       include 'COMMON.DERIV'
8944       include 'COMMON.INTERACT'
8945       include 'COMMON.CONTACTS'
8946       include 'COMMON.TORSION'
8947       include 'COMMON.VAR'
8948       include 'COMMON.GEO'
8949       logical swap
8950       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8951      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8952       logical lprn
8953       common /kutas/ lprn
8954 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8955 C                                                                              C
8956 C      Parallel       Antiparallel                                             C
8957 C                                                                              C
8958 C          o             o                                                     C
8959 C     \   /l\           /j\   /                                                C
8960 C      \ /   \         /   \ /                                                 C
8961 C       o| o |         | o |o                                                  C
8962 C     \ j|/k\|      \  |/k\|l                                                  C
8963 C      \ /   \       \ /   \                                                   C
8964 C       o             o                                                        C
8965 C       i             i                                                        C
8966 C                                                                              C
8967 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8968 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8969 C AL 7/4/01 s1 would occur in the sixth-order moment,
8970 C           but not in a cluster cumulant
8971 #ifdef MOMENT
8972       s1=dip(1,jj,i)*dip(1,kk,k)
8973 #endif
8974       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8975       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8976       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8977       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8978       call transpose2(EUg(1,1,k),auxmat(1,1))
8979       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8980       vv(1)=pizda(1,1)-pizda(2,2)
8981       vv(2)=pizda(1,2)+pizda(2,1)
8982       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8983 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8984 #ifdef MOMENT
8985       eello6_graph2=-(s1+s2+s3+s4)
8986 #else
8987       eello6_graph2=-(s2+s3+s4)
8988 #endif
8989 c      eello6_graph2=-s3
8990 C Derivatives in gamma(i-1)
8991       if (i.gt.1) then
8992 #ifdef MOMENT
8993         s1=dipderg(1,jj,i)*dip(1,kk,k)
8994 #endif
8995         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8996         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8997         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8998         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8999 #ifdef MOMENT
9000         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9001 #else
9002         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9003 #endif
9004 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
9005       endif
9006 C Derivatives in gamma(k-1)
9007 #ifdef MOMENT
9008       s1=dip(1,jj,i)*dipderg(1,kk,k)
9009 #endif
9010       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
9011       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9012       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
9013       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9014       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9015       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
9016       vv(1)=pizda(1,1)-pizda(2,2)
9017       vv(2)=pizda(1,2)+pizda(2,1)
9018       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9019 #ifdef MOMENT
9020       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9021 #else
9022       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9023 #endif
9024 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
9025 C Derivatives in gamma(j-1) or gamma(l-1)
9026       if (j.gt.1) then
9027 #ifdef MOMENT
9028         s1=dipderg(3,jj,i)*dip(1,kk,k)
9029 #endif
9030         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
9031         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9032         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
9033         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
9034         vv(1)=pizda(1,1)-pizda(2,2)
9035         vv(2)=pizda(1,2)+pizda(2,1)
9036         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9037 #ifdef MOMENT
9038         if (swap) then
9039           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9040         else
9041           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9042         endif
9043 #endif
9044         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
9045 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
9046       endif
9047 C Derivatives in gamma(l-1) or gamma(j-1)
9048       if (l.gt.1) then
9049 #ifdef MOMENT
9050         s1=dip(1,jj,i)*dipderg(3,kk,k)
9051 #endif
9052         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
9053         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9054         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
9055         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9056         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
9057         vv(1)=pizda(1,1)-pizda(2,2)
9058         vv(2)=pizda(1,2)+pizda(2,1)
9059         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9060 #ifdef MOMENT
9061         if (swap) then
9062           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9063         else
9064           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9065         endif
9066 #endif
9067         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
9068 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
9069       endif
9070 C Cartesian derivatives.
9071       if (lprn) then
9072         write (2,*) 'In eello6_graph2'
9073         do iii=1,2
9074           write (2,*) 'iii=',iii
9075           do kkk=1,5
9076             write (2,*) 'kkk=',kkk
9077             do jjj=1,2
9078               write (2,'(3(2f10.5),5x)')
9079      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9080             enddo
9081           enddo
9082         enddo
9083       endif
9084       do iii=1,2
9085         do kkk=1,5
9086           do lll=1,3
9087 #ifdef MOMENT
9088             if (iii.eq.1) then
9089               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
9090             else
9091               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
9092             endif
9093 #endif
9094             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
9095      &        auxvec(1))
9096             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9097             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
9098      &        auxvec(1))
9099             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
9100             call transpose2(EUg(1,1,k),auxmat(1,1))
9101             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
9102      &        pizda(1,1))
9103             vv(1)=pizda(1,1)-pizda(2,2)
9104             vv(2)=pizda(1,2)+pizda(2,1)
9105             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9106 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
9107 #ifdef MOMENT
9108             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9109 #else
9110             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9111 #endif
9112             if (swap) then
9113               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9114             else
9115               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9116             endif
9117           enddo
9118         enddo
9119       enddo
9120       return
9121       end
9122 c----------------------------------------------------------------------------
9123       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
9124       implicit real*8 (a-h,o-z)
9125       include 'DIMENSIONS'
9126       include 'COMMON.IOUNITS'
9127       include 'COMMON.CHAIN'
9128       include 'COMMON.DERIV'
9129       include 'COMMON.INTERACT'
9130       include 'COMMON.CONTACTS'
9131       include 'COMMON.TORSION'
9132       include 'COMMON.VAR'
9133       include 'COMMON.GEO'
9134       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
9135       logical swap
9136 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9137 C                                                                              C
9138 C      Parallel       Antiparallel                                             C
9139 C                                                                              C
9140 C          o             o                                                     C
9141 C         /l\   /   \   /j\                                                    C
9142 C        /   \ /     \ /   \                                                   C
9143 C       /| o |o       o| o |\                                                  C
9144 C       j|/k\|  /      |/k\|l /                                                C
9145 C        /   \ /       /   \ /                                                 C
9146 C       /     o       /     o                                                  C
9147 C       i             i                                                        C
9148 C                                                                              C
9149 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9150 C
9151 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9152 C           energy moment and not to the cluster cumulant.
9153       iti=itortyp(itype(i))
9154       if (j.lt.nres-1) then
9155         itj1=itortyp(itype(j+1))
9156       else
9157         itj1=ntortyp+1
9158       endif
9159       itk=itortyp(itype(k))
9160       itk1=itortyp(itype(k+1))
9161       if (l.lt.nres-1) then
9162         itl1=itortyp(itype(l+1))
9163       else
9164         itl1=ntortyp+1
9165       endif
9166 #ifdef MOMENT
9167       s1=dip(4,jj,i)*dip(4,kk,k)
9168 #endif
9169       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
9170       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9171       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
9172       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9173       call transpose2(EE(1,1,itk),auxmat(1,1))
9174       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
9175       vv(1)=pizda(1,1)+pizda(2,2)
9176       vv(2)=pizda(2,1)-pizda(1,2)
9177       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9178 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9179 cd     & "sum",-(s2+s3+s4)
9180 #ifdef MOMENT
9181       eello6_graph3=-(s1+s2+s3+s4)
9182 #else
9183       eello6_graph3=-(s2+s3+s4)
9184 #endif
9185 c      eello6_graph3=-s4
9186 C Derivatives in gamma(k-1)
9187       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
9188       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9189       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9190       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9191 C Derivatives in gamma(l-1)
9192       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
9193       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9194       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9195       vv(1)=pizda(1,1)+pizda(2,2)
9196       vv(2)=pizda(2,1)-pizda(1,2)
9197       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9198       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9199 C Cartesian derivatives.
9200       do iii=1,2
9201         do kkk=1,5
9202           do lll=1,3
9203 #ifdef MOMENT
9204             if (iii.eq.1) then
9205               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9206             else
9207               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9208             endif
9209 #endif
9210             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
9211      &        auxvec(1))
9212             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9213             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
9214      &        auxvec(1))
9215             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9216             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
9217      &        pizda(1,1))
9218             vv(1)=pizda(1,1)+pizda(2,2)
9219             vv(2)=pizda(2,1)-pizda(1,2)
9220             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9221 #ifdef MOMENT
9222             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9223 #else
9224             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9225 #endif
9226             if (swap) then
9227               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9228             else
9229               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9230             endif
9231 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9232           enddo
9233         enddo
9234       enddo
9235       return
9236       end
9237 c----------------------------------------------------------------------------
9238       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
9239       implicit real*8 (a-h,o-z)
9240       include 'DIMENSIONS'
9241       include 'COMMON.IOUNITS'
9242       include 'COMMON.CHAIN'
9243       include 'COMMON.DERIV'
9244       include 'COMMON.INTERACT'
9245       include 'COMMON.CONTACTS'
9246       include 'COMMON.TORSION'
9247       include 'COMMON.VAR'
9248       include 'COMMON.GEO'
9249       include 'COMMON.FFIELD'
9250       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9251      & auxvec1(2),auxmat1(2,2)
9252       logical swap
9253 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9254 C                                                                              C
9255 C      Parallel       Antiparallel                                             C
9256 C                                                                              C
9257 C          o             o                                                     C
9258 C         /l\   /   \   /j\                                                    C
9259 C        /   \ /     \ /   \                                                   C
9260 C       /| o |o       o| o |\                                                  C
9261 C     \ j|/k\|      \  |/k\|l                                                  C
9262 C      \ /   \       \ /   \                                                   C
9263 C       o     \       o     \                                                  C
9264 C       i             i                                                        C
9265 C                                                                              C
9266 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9267 C
9268 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9269 C           energy moment and not to the cluster cumulant.
9270 cd      write (2,*) 'eello_graph4: wturn6',wturn6
9271       iti=itortyp(itype(i))
9272       itj=itortyp(itype(j))
9273       if (j.lt.nres-1) then
9274         itj1=itortyp(itype(j+1))
9275       else
9276         itj1=ntortyp+1
9277       endif
9278       itk=itortyp(itype(k))
9279       if (k.lt.nres-1) then
9280         itk1=itortyp(itype(k+1))
9281       else
9282         itk1=ntortyp+1
9283       endif
9284       itl=itortyp(itype(l))
9285       if (l.lt.nres-1) then
9286         itl1=itortyp(itype(l+1))
9287       else
9288         itl1=ntortyp+1
9289       endif
9290 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9291 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9292 cd     & ' itl',itl,' itl1',itl1
9293 #ifdef MOMENT
9294       if (imat.eq.1) then
9295         s1=dip(3,jj,i)*dip(3,kk,k)
9296       else
9297         s1=dip(2,jj,j)*dip(2,kk,l)
9298       endif
9299 #endif
9300       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9301       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9302       if (j.eq.l+1) then
9303         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
9304         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9305       else
9306         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
9307         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9308       endif
9309       call transpose2(EUg(1,1,k),auxmat(1,1))
9310       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9311       vv(1)=pizda(1,1)-pizda(2,2)
9312       vv(2)=pizda(2,1)+pizda(1,2)
9313       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9314 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9315 #ifdef MOMENT
9316       eello6_graph4=-(s1+s2+s3+s4)
9317 #else
9318       eello6_graph4=-(s2+s3+s4)
9319 #endif
9320 C Derivatives in gamma(i-1)
9321       if (i.gt.1) then
9322 #ifdef MOMENT
9323         if (imat.eq.1) then
9324           s1=dipderg(2,jj,i)*dip(3,kk,k)
9325         else
9326           s1=dipderg(4,jj,j)*dip(2,kk,l)
9327         endif
9328 #endif
9329         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9330         if (j.eq.l+1) then
9331           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
9332           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9333         else
9334           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
9335           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9336         endif
9337         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9338         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9339 cd          write (2,*) 'turn6 derivatives'
9340 #ifdef MOMENT
9341           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9342 #else
9343           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9344 #endif
9345         else
9346 #ifdef MOMENT
9347           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9348 #else
9349           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9350 #endif
9351         endif
9352       endif
9353 C Derivatives in gamma(k-1)
9354 #ifdef MOMENT
9355       if (imat.eq.1) then
9356         s1=dip(3,jj,i)*dipderg(2,kk,k)
9357       else
9358         s1=dip(2,jj,j)*dipderg(4,kk,l)
9359       endif
9360 #endif
9361       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9362       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9363       if (j.eq.l+1) then
9364         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
9365         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9366       else
9367         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
9368         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9369       endif
9370       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9371       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9372       vv(1)=pizda(1,1)-pizda(2,2)
9373       vv(2)=pizda(2,1)+pizda(1,2)
9374       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9375       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9376 #ifdef MOMENT
9377         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9378 #else
9379         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9380 #endif
9381       else
9382 #ifdef MOMENT
9383         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9384 #else
9385         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9386 #endif
9387       endif
9388 C Derivatives in gamma(j-1) or gamma(l-1)
9389       if (l.eq.j+1 .and. l.gt.1) then
9390         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9391         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9392         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9393         vv(1)=pizda(1,1)-pizda(2,2)
9394         vv(2)=pizda(2,1)+pizda(1,2)
9395         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9396         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9397       else if (j.gt.1) then
9398         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9399         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9400         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9401         vv(1)=pizda(1,1)-pizda(2,2)
9402         vv(2)=pizda(2,1)+pizda(1,2)
9403         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9404         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9405           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9406         else
9407           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9408         endif
9409       endif
9410 C Cartesian derivatives.
9411       do iii=1,2
9412         do kkk=1,5
9413           do lll=1,3
9414 #ifdef MOMENT
9415             if (iii.eq.1) then
9416               if (imat.eq.1) then
9417                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9418               else
9419                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9420               endif
9421             else
9422               if (imat.eq.1) then
9423                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9424               else
9425                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9426               endif
9427             endif
9428 #endif
9429             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
9430      &        auxvec(1))
9431             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9432             if (j.eq.l+1) then
9433               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9434      &          b1(1,itj1),auxvec(1))
9435               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
9436             else
9437               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9438      &          b1(1,itl1),auxvec(1))
9439               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
9440             endif
9441             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9442      &        pizda(1,1))
9443             vv(1)=pizda(1,1)-pizda(2,2)
9444             vv(2)=pizda(2,1)+pizda(1,2)
9445             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9446             if (swap) then
9447               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9448 #ifdef MOMENT
9449                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9450      &             -(s1+s2+s4)
9451 #else
9452                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9453      &             -(s2+s4)
9454 #endif
9455                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9456               else
9457 #ifdef MOMENT
9458                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9459 #else
9460                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9461 #endif
9462                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9463               endif
9464             else
9465 #ifdef MOMENT
9466               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9467 #else
9468               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9469 #endif
9470               if (l.eq.j+1) then
9471                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9472               else
9473                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9474               endif
9475             endif
9476           enddo
9477         enddo
9478       enddo
9479       return
9480       end
9481 c----------------------------------------------------------------------------
9482       double precision function eello_turn6(i,jj,kk)
9483       implicit real*8 (a-h,o-z)
9484       include 'DIMENSIONS'
9485       include 'COMMON.IOUNITS'
9486       include 'COMMON.CHAIN'
9487       include 'COMMON.DERIV'
9488       include 'COMMON.INTERACT'
9489       include 'COMMON.CONTACTS'
9490       include 'COMMON.TORSION'
9491       include 'COMMON.VAR'
9492       include 'COMMON.GEO'
9493       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
9494      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
9495      &  ggg1(3),ggg2(3)
9496       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
9497      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
9498 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9499 C           the respective energy moment and not to the cluster cumulant.
9500       s1=0.0d0
9501       s8=0.0d0
9502       s13=0.0d0
9503 c
9504       eello_turn6=0.0d0
9505       j=i+4
9506       k=i+1
9507       l=i+3
9508       iti=itortyp(itype(i))
9509       itk=itortyp(itype(k))
9510       itk1=itortyp(itype(k+1))
9511       itl=itortyp(itype(l))
9512       itj=itortyp(itype(j))
9513 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9514 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
9515 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9516 cd        eello6=0.0d0
9517 cd        return
9518 cd      endif
9519 cd      write (iout,*)
9520 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9521 cd     &   ' and',k,l
9522 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
9523       do iii=1,2
9524         do kkk=1,5
9525           do lll=1,3
9526             derx_turn(lll,kkk,iii)=0.0d0
9527           enddo
9528         enddo
9529       enddo
9530 cd      eij=1.0d0
9531 cd      ekl=1.0d0
9532 cd      ekont=1.0d0
9533       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9534 cd      eello6_5=0.0d0
9535 cd      write (2,*) 'eello6_5',eello6_5
9536 #ifdef MOMENT
9537       call transpose2(AEA(1,1,1),auxmat(1,1))
9538       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
9539       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
9540       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
9541 #endif
9542       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9543       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
9544       s2 = scalar2(b1(1,itk),vtemp1(1))
9545 #ifdef MOMENT
9546       call transpose2(AEA(1,1,2),atemp(1,1))
9547       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
9548       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
9549       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9550 #endif
9551       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
9552       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
9553       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
9554 #ifdef MOMENT
9555       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
9556       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
9557       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
9558       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
9559       ss13 = scalar2(b1(1,itk),vtemp4(1))
9560       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
9561 #endif
9562 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
9563 c      s1=0.0d0
9564 c      s2=0.0d0
9565 c      s8=0.0d0
9566 c      s12=0.0d0
9567 c      s13=0.0d0
9568       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
9569 C Derivatives in gamma(i+2)
9570       s1d =0.0d0
9571       s8d =0.0d0
9572 #ifdef MOMENT
9573       call transpose2(AEA(1,1,1),auxmatd(1,1))
9574       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9575       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9576       call transpose2(AEAderg(1,1,2),atempd(1,1))
9577       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9578       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9579 #endif
9580       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
9581       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9582       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9583 c      s1d=0.0d0
9584 c      s2d=0.0d0
9585 c      s8d=0.0d0
9586 c      s12d=0.0d0
9587 c      s13d=0.0d0
9588       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
9589 C Derivatives in gamma(i+3)
9590 #ifdef MOMENT
9591       call transpose2(AEA(1,1,1),auxmatd(1,1))
9592       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9593       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
9594       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
9595 #endif
9596       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
9597       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
9598       s2d = scalar2(b1(1,itk),vtemp1d(1))
9599 #ifdef MOMENT
9600       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
9601       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
9602 #endif
9603       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
9604 #ifdef MOMENT
9605       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
9606       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9607       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9608 #endif
9609 c      s1d=0.0d0
9610 c      s2d=0.0d0
9611 c      s8d=0.0d0
9612 c      s12d=0.0d0
9613 c      s13d=0.0d0
9614 #ifdef MOMENT
9615       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9616      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9617 #else
9618       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9619      &               -0.5d0*ekont*(s2d+s12d)
9620 #endif
9621 C Derivatives in gamma(i+4)
9622       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
9623       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9624       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9625 #ifdef MOMENT
9626       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
9627       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
9628       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9629 #endif
9630 c      s1d=0.0d0
9631 c      s2d=0.0d0
9632 c      s8d=0.0d0
9633 C      s12d=0.0d0
9634 c      s13d=0.0d0
9635 #ifdef MOMENT
9636       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
9637 #else
9638       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
9639 #endif
9640 C Derivatives in gamma(i+5)
9641 #ifdef MOMENT
9642       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
9643       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9644       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9645 #endif
9646       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
9647       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
9648       s2d = scalar2(b1(1,itk),vtemp1d(1))
9649 #ifdef MOMENT
9650       call transpose2(AEA(1,1,2),atempd(1,1))
9651       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
9652       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9653 #endif
9654       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
9655       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9656 #ifdef MOMENT
9657       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
9658       ss13d = scalar2(b1(1,itk),vtemp4d(1))
9659       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9660 #endif
9661 c      s1d=0.0d0
9662 c      s2d=0.0d0
9663 c      s8d=0.0d0
9664 c      s12d=0.0d0
9665 c      s13d=0.0d0
9666 #ifdef MOMENT
9667       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9668      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9669 #else
9670       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9671      &               -0.5d0*ekont*(s2d+s12d)
9672 #endif
9673 C Cartesian derivatives
9674       do iii=1,2
9675         do kkk=1,5
9676           do lll=1,3
9677 #ifdef MOMENT
9678             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
9679             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9680             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9681 #endif
9682             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9683             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
9684      &          vtemp1d(1))
9685             s2d = scalar2(b1(1,itk),vtemp1d(1))
9686 #ifdef MOMENT
9687             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
9688             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9689             s8d = -(atempd(1,1)+atempd(2,2))*
9690      &           scalar2(cc(1,1,itl),vtemp2(1))
9691 #endif
9692             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
9693      &           auxmatd(1,1))
9694             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9695             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9696 c      s1d=0.0d0
9697 c      s2d=0.0d0
9698 c      s8d=0.0d0
9699 c      s12d=0.0d0
9700 c      s13d=0.0d0
9701 #ifdef MOMENT
9702             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9703      &        - 0.5d0*(s1d+s2d)
9704 #else
9705             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9706      &        - 0.5d0*s2d
9707 #endif
9708 #ifdef MOMENT
9709             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9710      &        - 0.5d0*(s8d+s12d)
9711 #else
9712             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9713      &        - 0.5d0*s12d
9714 #endif
9715           enddo
9716         enddo
9717       enddo
9718 #ifdef MOMENT
9719       do kkk=1,5
9720         do lll=1,3
9721           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9722      &      achuj_tempd(1,1))
9723           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9724           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9725           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9726           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9727           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9728      &      vtemp4d(1))
9729           ss13d = scalar2(b1(1,itk),vtemp4d(1))
9730           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9731           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9732         enddo
9733       enddo
9734 #endif
9735 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9736 cd     &  16*eel_turn6_num
9737 cd      goto 1112
9738       if (j.lt.nres-1) then
9739         j1=j+1
9740         j2=j-1
9741       else
9742         j1=j-1
9743         j2=j-2
9744       endif
9745       if (l.lt.nres-1) then
9746         l1=l+1
9747         l2=l-1
9748       else
9749         l1=l-1
9750         l2=l-2
9751       endif
9752       do ll=1,3
9753 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9754 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9755 cgrad        ghalf=0.5d0*ggg1(ll)
9756 cd        ghalf=0.0d0
9757         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9758         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9759         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9760      &    +ekont*derx_turn(ll,2,1)
9761         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9762         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9763      &    +ekont*derx_turn(ll,4,1)
9764         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9765         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9766         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9767 cgrad        ghalf=0.5d0*ggg2(ll)
9768 cd        ghalf=0.0d0
9769         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9770      &    +ekont*derx_turn(ll,2,2)
9771         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9772         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9773      &    +ekont*derx_turn(ll,4,2)
9774         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9775         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9776         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9777       enddo
9778 cd      goto 1112
9779 cgrad      do m=i+1,j-1
9780 cgrad        do ll=1,3
9781 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9782 cgrad        enddo
9783 cgrad      enddo
9784 cgrad      do m=k+1,l-1
9785 cgrad        do ll=1,3
9786 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9787 cgrad        enddo
9788 cgrad      enddo
9789 cgrad1112  continue
9790 cgrad      do m=i+2,j2
9791 cgrad        do ll=1,3
9792 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9793 cgrad        enddo
9794 cgrad      enddo
9795 cgrad      do m=k+2,l2
9796 cgrad        do ll=1,3
9797 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9798 cgrad        enddo
9799 cgrad      enddo
9800 cd      do iii=1,nres-3
9801 cd        write (2,*) iii,g_corr6_loc(iii)
9802 cd      enddo
9803       eello_turn6=ekont*eel_turn6
9804 cd      write (2,*) 'ekont',ekont
9805 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9806       return
9807       end
9808
9809 C-----------------------------------------------------------------------------
9810       double precision function scalar(u,v)
9811 !DIR$ INLINEALWAYS scalar
9812 #ifndef OSF
9813 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9814 #endif
9815       implicit none
9816       double precision u(3),v(3)
9817 cd      double precision sc
9818 cd      integer i
9819 cd      sc=0.0d0
9820 cd      do i=1,3
9821 cd        sc=sc+u(i)*v(i)
9822 cd      enddo
9823 cd      scalar=sc
9824
9825       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9826       return
9827       end
9828 crc-------------------------------------------------
9829       SUBROUTINE MATVEC2(A1,V1,V2)
9830 !DIR$ INLINEALWAYS MATVEC2
9831 #ifndef OSF
9832 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9833 #endif
9834       implicit real*8 (a-h,o-z)
9835       include 'DIMENSIONS'
9836       DIMENSION A1(2,2),V1(2),V2(2)
9837 c      DO 1 I=1,2
9838 c        VI=0.0
9839 c        DO 3 K=1,2
9840 c    3     VI=VI+A1(I,K)*V1(K)
9841 c        Vaux(I)=VI
9842 c    1 CONTINUE
9843
9844       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9845       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9846
9847       v2(1)=vaux1
9848       v2(2)=vaux2
9849       END
9850 C---------------------------------------
9851       SUBROUTINE MATMAT2(A1,A2,A3)
9852 #ifndef OSF
9853 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9854 #endif
9855       implicit real*8 (a-h,o-z)
9856       include 'DIMENSIONS'
9857       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9858 c      DIMENSION AI3(2,2)
9859 c        DO  J=1,2
9860 c          A3IJ=0.0
9861 c          DO K=1,2
9862 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9863 c          enddo
9864 c          A3(I,J)=A3IJ
9865 c       enddo
9866 c      enddo
9867
9868       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9869       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9870       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9871       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9872
9873       A3(1,1)=AI3_11
9874       A3(2,1)=AI3_21
9875       A3(1,2)=AI3_12
9876       A3(2,2)=AI3_22
9877       END
9878
9879 c-------------------------------------------------------------------------
9880       double precision function scalar2(u,v)
9881 !DIR$ INLINEALWAYS scalar2
9882       implicit none
9883       double precision u(2),v(2)
9884       double precision sc
9885       integer i
9886       scalar2=u(1)*v(1)+u(2)*v(2)
9887       return
9888       end
9889
9890 C-----------------------------------------------------------------------------
9891
9892       subroutine transpose2(a,at)
9893 !DIR$ INLINEALWAYS transpose2
9894 #ifndef OSF
9895 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9896 #endif
9897       implicit none
9898       double precision a(2,2),at(2,2)
9899       at(1,1)=a(1,1)
9900       at(1,2)=a(2,1)
9901       at(2,1)=a(1,2)
9902       at(2,2)=a(2,2)
9903       return
9904       end
9905 c--------------------------------------------------------------------------
9906       subroutine transpose(n,a,at)
9907       implicit none
9908       integer n,i,j
9909       double precision a(n,n),at(n,n)
9910       do i=1,n
9911         do j=1,n
9912           at(j,i)=a(i,j)
9913         enddo
9914       enddo
9915       return
9916       end
9917 C---------------------------------------------------------------------------
9918       subroutine prodmat3(a1,a2,kk,transp,prod)
9919 !DIR$ INLINEALWAYS prodmat3
9920 #ifndef OSF
9921 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9922 #endif
9923       implicit none
9924       integer i,j
9925       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9926       logical transp
9927 crc      double precision auxmat(2,2),prod_(2,2)
9928
9929       if (transp) then
9930 crc        call transpose2(kk(1,1),auxmat(1,1))
9931 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9932 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9933
9934            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9935      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9936            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9937      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9938            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9939      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9940            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9941      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9942
9943       else
9944 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9945 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9946
9947            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9948      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9949            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9950      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9951            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9952      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9953            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9954      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9955
9956       endif
9957 c      call transpose2(a2(1,1),a2t(1,1))
9958
9959 crc      print *,transp
9960 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9961 crc      print *,((prod(i,j),i=1,2),j=1,2)
9962
9963       return
9964       end
9965