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 #ifdef TIMING
 103 #ifdef MPI
 104       time00=MPI_Wtime()
 105 #else
 106       time00=tcpu()
 107 #endif
 108 #endif
 109 C
 110 C Compute the side-chain and electrostatic interaction energy
 111 C
 112       goto (101,102,103,104,105,106) ipot
 113 C Lennard-Jones potential.
 114   101 call elj(evdw,evdw_p,evdw_m)
 115 cd    print '(a)','Exit ELJ'
 116       goto 107
 117 C Lennard-Jones-Kihara potential (shifted).
 118   102 call eljk(evdw,evdw_p,evdw_m)
 119       goto 107
 120 C Berne-Pechukas potential (dilated LJ, angular dependence).
 121   103 call ebp(evdw,evdw_p,evdw_m)
 122       goto 107
 123 C Gay-Berne potential (shifted LJ, angular dependence).
 124   104 call egb(evdw,evdw_p,evdw_m)
 125       goto 107
 126 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 127   105 call egbv(evdw,evdw_p,evdw_m)
 128       goto 107
 129 C Soft-sphere potential
 130   106 call e_softsphere(evdw)
 131 C
 132 C Calculate electrostatic (H-bonding) energy of the main chain.
 133 C
 134   107 continue
 135 C     BARTEK for dfa test!
 136       if (wdfa_dist.gt.0) then
 137         call edfad(edfadis)
 138       else
 139         edfadis=0
 140       endif
 141 c      print*, 'edfad is finished!', edfadis
 142       if (wdfa_tor.gt.0) then
 143         call edfat(edfator)
 144       else
 145         edfator=0
 146       endif
 147 c      print*, 'edfat is finished!', edfator
 148       if (wdfa_nei.gt.0) then
 149         call edfan(edfanei)
 150       else
 151         edfanei=0
 152       endif
 153 c      print*, 'edfan is finished!', edfanei
 154       if (wdfa_beta.gt.0) then
 155         call edfab(edfabet)
 156       else
 157         edfabet=0
 158       endif
 159 c      print*, 'edfab is finished!', edfabet
 160 cmc
 161 cmc Sep-06: egb takes care of dynamic ss bonds too
 162 cmc
 163 c      if (dyn_ss) call dyn_set_nss
 164
 165 c      print *,"Processor",myrank," computed USCSC"
 166 #ifdef TIMING
 167 #ifdef MPI
 168       time01=MPI_Wtime()
 169 #else
 170       time00=tcpu()
 171 #endif
 172 #endif
 173       call vec_and_deriv
 174 #ifdef TIMING
 175 #ifdef MPI
 176       time_vec=time_vec+MPI_Wtime()-time01
 177 #else
 178       time_vec=time_vec+tcpu()-time01
 179 #endif
 180 #endif
 181 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 182       if (ipot.lt.6) then
 183 #ifdef SPLITELE
 184          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 185      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 186      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 187      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 188 #else
 189          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 190      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 191      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 192      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 193 #endif
 194             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 195          else
 196             ees=0.0d0
 197             evdw1=0.0d0
 198             eel_loc=0.0d0
 199             eello_turn3=0.0d0
 200             eello_turn4=0.0d0
 201          endif
 202       else
 203 c        write (iout,*) "Soft-spheer ELEC potential"
 204         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 205      &   eello_turn4)
 206       endif
 207 c      print *,"Processor",myrank," computed UELEC"
 208 C
 209 C Calculate excluded-volume interaction energy between peptide groups
 210 C and side chains.
 211 C
 212       if (ipot.lt.6) then
 213        if(wscp.gt.0d0) then
 214         call escp(evdw2,evdw2_14)
 215        else
 216         evdw2=0
 217         evdw2_14=0
 218        endif
 219       else
 220 c        write (iout,*) "Soft-sphere SCP potential"
 221         call escp_soft_sphere(evdw2,evdw2_14)
 222       endif
 223 c
 224 c Calculate the bond-stretching energy
 225 c
 226       call ebond(estr)
 227 C
 228 C Calculate the disulfide-bridge and other energy and the contributions
 229 C from other distance constraints.
 230 cd    print *,'Calling EHPB'
 231       call edis(ehpb)
 232 cd    print *,'EHPB exitted succesfully.'
 233 C
 234 C Calculate the virtual-bond-angle energy.
 235 C
 236       if (wang.gt.0d0) then
 237         call ebend(ebe)
 238       else
 239         ebe=0
 240       endif
 241 c      print *,"Processor",myrank," computed UB"
 242 C
 243 C Calculate the SC local energy.
 244 C
 245       call esc(escloc)
 246 c      print *,"Processor",myrank," computed USC"
 247 C
 248 C Calculate the virtual-bond torsional energy.
 249 C
 250 cd    print *,'nterm=',nterm
 251       if (wtor.gt.0) then
 252        call etor(etors,edihcnstr)
 253       else
 254        etors=0
 255        edihcnstr=0
 256       endif
 257
 258       if (constr_homology.ge.1) then
 259         call e_modeller(ehomology_constr)
 260 c        print *,'iset=',iset,'me=',me,ehomology_constr,
 261 c     &  'Processor',fg_rank,' CG group',kolor,
 262 c     &  ' absolute rank',MyRank
 263       else
 264         ehomology_constr=0.0d0
 265       endif
 266
 267
 268 c      write(iout,*) ehomology_constr
 269 c      print *,"Processor",myrank," computed Utor"
 270 C
 271 C 6/23/01 Calculate double-torsional energy
 272 C
 273       if (wtor_d.gt.0) then
 274        call etor_d(etors_d)
 275       else
 276        etors_d=0
 277       endif
 278 c      print *,"Processor",myrank," computed Utord"
 279 C
 280 C 21/5/07 Calculate local sicdechain correlation energy
 281 C
 282       if (wsccor.gt.0.0d0) then
 283         call eback_sc_corr(esccor)
 284       else
 285         esccor=0.0d0
 286       endif
 287 c      print *,"Processor",myrank," computed Usccorr"
 288 C
 289 C 12/1/95 Multi-body terms
 290 C
 291       n_corr=0
 292       n_corr1=0
 293       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 294      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 295          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 296 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 297 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 298       else
 299          ecorr=0.0d0
 300          ecorr5=0.0d0
 301          ecorr6=0.0d0
 302          eturn6=0.0d0
 303       endif
 304       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 305          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 306 cd         write (iout,*) "multibody_hb ecorr",ecorr
 307       endif
 308 c      print *,"Processor",myrank," computed Ucorr"
 309 C
 310 C If performing constraint dynamics, call the constraint energy
 311 C  after the equilibration time
 312       if(usampl.and.totT.gt.eq_time) then
 313 c         write (iout,*) "CALL TO ECONSTR_BACK"
 314          call EconstrQ
 315          call Econstr_back
 316       else
 317          Uconst=0.0d0
 318          Uconst_back=0.0d0
 319       endif
 320 #ifdef TIMING
 321 #ifdef MPI
 322       time_enecalc=time_enecalc+MPI_Wtime()-time00
 323 #else
 324       time_enecalc=time_enecalc+tcpu()-time00
 325 #endif
 326 #endif
 327 c      print *,"Processor",myrank," computed Uconstr"
 328 #ifdef TIMING
 329 #ifdef MPI
 330       time00=MPI_Wtime()
 331 #else
 332       time00=tcpu()
 333 #endif
 334 #endif
 335 c
 336 C Sum the energies
 337 C
 338       energia(1)=evdw
 339 #ifdef SCP14
 340       energia(2)=evdw2-evdw2_14
 341       energia(18)=evdw2_14
 342 #else
 343       energia(2)=evdw2
 344       energia(18)=0.0d0
 345 #endif
 346 #ifdef SPLITELE
 347       energia(3)=ees
 348       energia(16)=evdw1
 349 #else
 350       energia(3)=ees+evdw1
 351       energia(16)=0.0d0
 352 #endif
 353       energia(4)=ecorr
 354       energia(5)=ecorr5
 355       energia(6)=ecorr6
 356       energia(7)=eel_loc
 357       energia(8)=eello_turn3
 358       energia(9)=eello_turn4
 359       energia(10)=eturn6
 360       energia(11)=ebe
 361       energia(12)=escloc
 362       energia(13)=etors
 363       energia(14)=etors_d
 364       energia(15)=ehpb
 365       energia(19)=edihcnstr
 366       energia(17)=estr
 367       energia(20)=Uconst+Uconst_back
 368       energia(21)=esccor
 369       energia(22)=evdw_p
 370       energia(23)=evdw_m
 371       energia(24)=ehomology_constr
 372       energia(25)=edfadis
 373       energia(26)=edfator
 374       energia(27)=edfanei
 375       energia(28)=edfabet
 376 c      print *," Processor",myrank," calls SUM_ENERGY"
 377       call sum_energy(energia,.true.)
 378       if (dyn_ss) call dyn_set_nss
 379 c      print *," Processor",myrank," left SUM_ENERGY"
 380 #ifdef TIMING
 381 #ifdef MPI
 382       time_sumene=time_sumene+MPI_Wtime()-time00
 383 #else
 384       time_sumene=time_sumene+tcpu()-time00
 385 #endif
 386 #endif
 387       return
 388       end
 389 c-------------------------------------------------------------------------------
 390       subroutine sum_energy(energia,reduce)
 391       implicit real*8 (a-h,o-z)
 392       include 'DIMENSIONS'
 393 #ifndef ISNAN
 394       external proc_proc
 395 #ifdef WINPGI
 396 cMS$ATTRIBUTES C ::  proc_proc
 397 #endif
 398 #endif
 399 #ifdef MPI
 400       include "mpif.h"
 401 #endif
 402       include 'COMMON.SETUP'
 403       include 'COMMON.IOUNITS'
 404       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 405       include 'COMMON.FFIELD'
 406       include 'COMMON.DERIV'
 407       include 'COMMON.INTERACT'
 408       include 'COMMON.SBRIDGE'
 409       include 'COMMON.CHAIN'
 410       include 'COMMON.VAR'
 411       include 'COMMON.CONTROL'
 412       include 'COMMON.TIME1'
 413       logical reduce
 414 #ifdef MPI
 415       if (nfgtasks.gt.1 .and. reduce) then
 416 #ifdef DEBUG
 417         write (iout,*) "energies before REDUCE"
 418         call enerprint(energia)
 419         call flush(iout)
 420 #endif
 421         do i=0,n_ene
 422           enebuff(i)=energia(i)
 423         enddo
 424         time00=MPI_Wtime()
 425         call MPI_Barrier(FG_COMM,IERR)
 426         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 427         time00=MPI_Wtime()
 428         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 429      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 430 #ifdef DEBUG
 431         write (iout,*) "energies after REDUCE"
 432         call enerprint(energia)
 433         call flush(iout)
 434 #endif
 435         time_Reduce=time_Reduce+MPI_Wtime()-time00
 436       endif
 437       if (fg_rank.eq.0) then
 438 #endif
 439 #ifdef TSCSC
 440       evdw=energia(22)+wsct*energia(23)
 441 #else
 442       evdw=energia(1)
 443 #endif
 444 #ifdef SCP14
 445       evdw2=energia(2)+energia(18)
 446       evdw2_14=energia(18)
 447 #else
 448       evdw2=energia(2)
 449 #endif
 450 #ifdef SPLITELE
 451       ees=energia(3)
 452       evdw1=energia(16)
 453 #else
 454       ees=energia(3)
 455       evdw1=0.0d0
 456 #endif
 457       ecorr=energia(4)
 458       ecorr5=energia(5)
 459       ecorr6=energia(6)
 460       eel_loc=energia(7)
 461       eello_turn3=energia(8)
 462       eello_turn4=energia(9)
 463       eturn6=energia(10)
 464       ebe=energia(11)
 465       escloc=energia(12)
 466       etors=energia(13)
 467       etors_d=energia(14)
 468       ehpb=energia(15)
 469       edihcnstr=energia(19)
 470       estr=energia(17)
 471       Uconst=energia(20)
 472       esccor=energia(21)
 473       ehomology_constr=energia(24)
 474       edfadis=energia(25)
 475       edfator=energia(26)
 476       edfanei=energia(27)
 477       edfabet=energia(28)
 478 #ifdef SPLITELE
 479       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 480      & +wang*ebe+wtor*etors+wscloc*escloc
 481      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 482      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 483      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 484      & +wbond*estr+Uconst+wsccor*esccor+ehomology_constr
 485      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 486      & +wdfa_beta*edfabet
 487 #else
 488       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 489      & +wang*ebe+wtor*etors+wscloc*escloc
 490      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 491      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 492      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 493      & +wbond*estr+Uconst+wsccor*esccor+ehomology_constr
 494      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 495      & +wdfa_beta*edfabet
 496 #endif
 497       energia(0)=etot
 498 c detecting NaNQ
 499 #ifdef ISNAN
 500 #ifdef AIX
 501       if (isnan(etot).ne.0) energia(0)=1.0d+99
 502 #else
 503       if (isnan(etot)) energia(0)=1.0d+99
 504 #endif
 505 #else
 506       i=0
 507 #ifdef WINPGI
 508       idumm=proc_proc(etot,i)
 509 #else
 510       call proc_proc(etot,i)
 511 #endif
 512       if(i.eq.1)energia(0)=1.0d+99
 513 #endif
 514 #ifdef MPI
 515       endif
 516 #endif
 517       return
 518       end
 519 c-------------------------------------------------------------------------------
 520       subroutine sum_gradient
 521       implicit real*8 (a-h,o-z)
 522       include 'DIMENSIONS'
 523 #ifndef ISNAN
 524       external proc_proc
 525 #ifdef WINPGI
 526 cMS$ATTRIBUTES C ::  proc_proc
 527 #endif
 528 #endif
 529 #ifdef MPI
 530       include 'mpif.h'
 531 #endif
 532       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 533      &  glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres)
 534       include 'COMMON.SETUP'
 535       include 'COMMON.IOUNITS'
 536       include 'COMMON.FFIELD'
 537       include 'COMMON.DERIV'
 538       include 'COMMON.INTERACT'
 539       include 'COMMON.SBRIDGE'
 540       include 'COMMON.CHAIN'
 541       include 'COMMON.VAR'
 542       include 'COMMON.CONTROL'
 543       include 'COMMON.TIME1'
 544       include 'COMMON.MAXGRAD'
 545       include 'COMMON.SCCOR'
 546       include 'COMMON.MD'
 547 #ifdef TIMING
 548 #ifdef MPI
 549       time01=MPI_Wtime()
 550 #else
 551       time01=tcpu()
 552 #endif
 553 #endif
 554 #ifdef DEBUG
 555       write (iout,*) "sum_gradient gvdwc, gvdwx"
 556       do i=1,nres
 557         write (iout,'(i3,3f10.5,5x,3f10.5,5x,3f10.5,5x,3f10.5)')
 558      &   i,(gvdwx(j,i),j=1,3),(gvdwcT(j,i),j=1,3),(gvdwc(j,i),j=1,3),
 559      &   (gvdwcT(j,i),j=1,3)
 560       enddo
 561       call flush(iout)
 562 #endif
 563 #ifdef MPI
 564 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 565         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 566      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 567 #endif
 568 C
 569 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 570 C            in virtual-bond-vector coordinates
 571 C
 572 #ifdef DEBUG
 573 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 574 c      do i=1,nres-1
 575 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 576 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 577 c      enddo
 578 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 579 c      do i=1,nres-1
 580 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 581 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 582 c      enddo
 583       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 584       do i=1,nres
 585         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 586      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 587      &   g_corr5_loc(i)
 588       enddo
 589       call flush(iout)
 590 #endif
 591 #ifdef SPLITELE
 592 #ifdef TSCSC
 593       do i=1,nct
 594         do j=1,3
 595           gradbufc(j,i)=wsc*gvdwc(j,i)+wsc*wscT*gvdwcT(j,i)+
 596      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 597      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 598      &                wel_loc*gel_loc_long(j,i)+
 599      &                wcorr*gradcorr_long(j,i)+
 600      &                wcorr5*gradcorr5_long(j,i)+
 601      &                wcorr6*gradcorr6_long(j,i)+
 602      &                wturn6*gcorr6_turn_long(j,i)+
 603      &                wstrain*ghpbc(j,i)+
 604      &                wdfa_dist*gdfad(j,i)+
 605      &                wdfa_tor*gdfat(j,i)+
 606      &                wdfa_nei*gdfan(j,i)+
 607      &                wdfa_beta*gdfab(j,i)
 608         enddo
 609       enddo
 610 #else
 611       do i=1,nct
 612         do j=1,3
 613           gradbufc(j,i)=wsc*gvdwc(j,i)+
 614      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 615      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 616      &                wel_loc*gel_loc_long(j,i)+
 617      &                wcorr*gradcorr_long(j,i)+
 618      &                wcorr5*gradcorr5_long(j,i)+
 619      &                wcorr6*gradcorr6_long(j,i)+
 620      &                wturn6*gcorr6_turn_long(j,i)+
 621      &                wstrain*ghpbc(j,i)+
 622      &                wdfa_dist*gdfad(j,i)+
 623      &                wdfa_tor*gdfat(j,i)+
 624      &                wdfa_nei*gdfan(j,i)+
 625      &                wdfa_beta*gdfab(j,i)
 626         enddo
 627       enddo
 628 #endif
 629 #else
 630       do i=1,nct
 631         do j=1,3
 632           gradbufc(j,i)=wsc*gvdwc(j,i)+
 633      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 634      &                welec*gelc_long(j,i)+
 635      &                wbond*gradb(j,i)+
 636      &                wel_loc*gel_loc_long(j,i)+
 637      &                wcorr*gradcorr_long(j,i)+
 638      &                wcorr5*gradcorr5_long(j,i)+
 639      &                wcorr6*gradcorr6_long(j,i)+
 640      &                wturn6*gcorr6_turn_long(j,i)+
 641      &                wstrain*ghpbc(j,i)+
 642      &                wdfa_dist*gdfad(j,i)+
 643      &                wdfa_tor*gdfat(j,i)+
 644      &                wdfa_nei*gdfan(j,i)+
 645      &                wdfa_beta*gdfab(j,i)
 646         enddo
 647       enddo
 648 #endif
 649 #ifdef MPI
 650       if (nfgtasks.gt.1) then
 651       time00=MPI_Wtime()
 652 #ifdef DEBUG
 653       write (iout,*) "gradbufc before allreduce"
 654       do i=1,nres
 655         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 656       enddo
 657       call flush(iout)
 658 #endif
 659       do i=1,nres
 660         do j=1,3
 661           gradbufc_sum(j,i)=gradbufc(j,i)
 662         enddo
 663       enddo
 664 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 665 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 666 c      time_reduce=time_reduce+MPI_Wtime()-time00
 667 #ifdef DEBUG
 668 c      write (iout,*) "gradbufc_sum after allreduce"
 669 c      do i=1,nres
 670 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 671 c      enddo
 672 c      call flush(iout)
 673 #endif
 674 #ifdef TIMING
 675 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 676 #endif
 677       do i=nnt,nres
 678         do k=1,3
 679           gradbufc(k,i)=0.0d0
 680         enddo
 681       enddo
 682 #ifdef DEBUG
 683       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 684       write (iout,*) (i," jgrad_start",jgrad_start(i),
 685      &                  " jgrad_end  ",jgrad_end(i),
 686      &                  i=igrad_start,igrad_end)
 687 #endif
 688 c
 689 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 690 c do not parallelize this part.
 691 c
 692 c      do i=igrad_start,igrad_end
 693 c        do j=jgrad_start(i),jgrad_end(i)
 694 c          do k=1,3
 695 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 696 c          enddo
 697 c        enddo
 698 c      enddo
 699       do j=1,3
 700         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 701       enddo
 702       do i=nres-2,nnt,-1
 703         do j=1,3
 704           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 705         enddo
 706       enddo
 707 #ifdef DEBUG
 708       write (iout,*) "gradbufc after summing"
 709       do i=1,nres
 710         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 711       enddo
 712       call flush(iout)
 713 #endif
 714       else
 715 #endif
 716 #ifdef DEBUG
 717       write (iout,*) "gradbufc"
 718       do i=1,nres
 719         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 720       enddo
 721       call flush(iout)
 722 #endif
 723       do i=1,nres
 724         do j=1,3
 725           gradbufc_sum(j,i)=gradbufc(j,i)
 726           gradbufc(j,i)=0.0d0
 727         enddo
 728       enddo
 729       do j=1,3
 730         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 731       enddo
 732       do i=nres-2,nnt,-1
 733         do j=1,3
 734           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 735         enddo
 736       enddo
 737 c      do i=nnt,nres-1
 738 c        do k=1,3
 739 c          gradbufc(k,i)=0.0d0
 740 c        enddo
 741 c        do j=i+1,nres
 742 c          do k=1,3
 743 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 744 c          enddo
 745 c        enddo
 746 c      enddo
 747 #ifdef DEBUG
 748       write (iout,*) "gradbufc after summing"
 749       do i=1,nres
 750         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 751       enddo
 752       call flush(iout)
 753 #endif
 754 #ifdef MPI
 755       endif
 756 #endif
 757       do k=1,3
 758         gradbufc(k,nres)=0.0d0
 759       enddo
 760       do i=1,nct
 761         do j=1,3
 762 #ifdef SPLITELE
 763           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 764      &                wel_loc*gel_loc(j,i)+
 765      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 766      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 767      &                wel_loc*gel_loc_long(j,i)+
 768      &                wcorr*gradcorr_long(j,i)+
 769      &                wcorr5*gradcorr5_long(j,i)+
 770      &                wcorr6*gradcorr6_long(j,i)+
 771      &                wturn6*gcorr6_turn_long(j,i))+
 772      &                wbond*gradb(j,i)+
 773      &                wcorr*gradcorr(j,i)+
 774      &                wturn3*gcorr3_turn(j,i)+
 775      &                wturn4*gcorr4_turn(j,i)+
 776      &                wcorr5*gradcorr5(j,i)+
 777      &                wcorr6*gradcorr6(j,i)+
 778      &                wturn6*gcorr6_turn(j,i)+
 779      &                wsccor*gsccorc(j,i)
 780      &               +wscloc*gscloc(j,i)
 781 #else
 782           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 783      &                wel_loc*gel_loc(j,i)+
 784      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 785      &                welec*gelc_long(j,i)+
 786      &                wel_loc*gel_loc_long(j,i)+
 787      &                wcorr*gcorr_long(j,i)+
 788      &                wcorr5*gradcorr5_long(j,i)+
 789      &                wcorr6*gradcorr6_long(j,i)+
 790      &                wturn6*gcorr6_turn_long(j,i))+
 791      &                wbond*gradb(j,i)+
 792      &                wcorr*gradcorr(j,i)+
 793      &                wturn3*gcorr3_turn(j,i)+
 794      &                wturn4*gcorr4_turn(j,i)+
 795      &                wcorr5*gradcorr5(j,i)+
 796      &                wcorr6*gradcorr6(j,i)+
 797      &                wturn6*gcorr6_turn(j,i)+
 798      &                wsccor*gsccorc(j,i)
 799      &               +wscloc*gscloc(j,i)
 800 #endif
 801 #ifdef TSCSC
 802           gradx(j,i,icg)=wsc*gvdwx(j,i)+wsc*wscT*gvdwxT(j,i)+
 803      &                  wscp*gradx_scp(j,i)+
 804      &                  wbond*gradbx(j,i)+
 805      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 806      &                  wsccor*gsccorx(j,i)
 807      &                 +wscloc*gsclocx(j,i)
 808 #else
 809           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 810      &                  wbond*gradbx(j,i)+
 811      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 812      &                  wsccor*gsccorx(j,i)
 813      &                 +wscloc*gsclocx(j,i)
 814 #endif
 815         enddo
 816       enddo
 817       if (constr_homology.gt.0) then
 818         do i=1,nct
 819           do j=1,3
 820             gradc(j,i,icg)=gradc(j,i,icg)+duscdiff(j,i)
 821             gradx(j,i,icg)=gradx(j,i,icg)+duscdiffx(j,i)
 822           enddo
 823         enddo
 824       endif
 825 #ifdef DEBUG
 826       write (iout,*) "gloc before adding corr"
 827       do i=1,4*nres
 828         write (iout,*) i,gloc(i,icg)
 829       enddo
 830 #endif
 831       do i=1,nres-3
 832         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 833      &   +wcorr5*g_corr5_loc(i)
 834      &   +wcorr6*g_corr6_loc(i)
 835      &   +wturn4*gel_loc_turn4(i)
 836      &   +wturn3*gel_loc_turn3(i)
 837      &   +wturn6*gel_loc_turn6(i)
 838      &   +wel_loc*gel_loc_loc(i)
 839       enddo
 840 #ifdef DEBUG
 841       write (iout,*) "gloc after adding corr"
 842       do i=1,4*nres
 843         write (iout,*) i,gloc(i,icg)
 844       enddo
 845 #endif
 846 #ifdef MPI
 847       if (nfgtasks.gt.1) then
 848         do j=1,3
 849           do i=1,nres
 850             gradbufc(j,i)=gradc(j,i,icg)
 851             gradbufx(j,i)=gradx(j,i,icg)
 852           enddo
 853         enddo
 854         do i=1,4*nres
 855           glocbuf(i)=gloc(i,icg)
 856         enddo
 857 #ifdef DEBUG
 858       write (iout,*) "gloc_sc before reduce"
 859       do i=1,nres
 860        do j=1,3
 861         write (iout,*) i,j,gloc_sc(j,i,icg)
 862        enddo
 863       enddo
 864 #endif
 865         do i=1,nres
 866          do j=1,3
 867           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 868          enddo
 869         enddo
 870         time00=MPI_Wtime()
 871         call MPI_Barrier(FG_COMM,IERR)
 872         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 873         time00=MPI_Wtime()
 874         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 875      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 876         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 877      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 878         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 879      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 880         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 881      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 882         time_reduce=time_reduce+MPI_Wtime()-time00
 883 #ifdef DEBUG
 884       write (iout,*) "gloc_sc after reduce"
 885       do i=1,nres
 886        do j=1,3
 887         write (iout,*) i,j,gloc_sc(j,i,icg)
 888        enddo
 889       enddo
 890 #endif
 891 #ifdef DEBUG
 892       write (iout,*) "gloc after reduce"
 893       do i=1,4*nres
 894         write (iout,*) i,gloc(i,icg)
 895       enddo
 896 #endif
 897       endif
 898 #endif
 899       if (gnorm_check) then
 900 c
 901 c Compute the maximum elements of the gradient
 902 c
 903       gvdwc_max=0.0d0
 904       gvdwc_scp_max=0.0d0
 905       gelc_max=0.0d0
 906       gvdwpp_max=0.0d0
 907       gradb_max=0.0d0
 908       ghpbc_max=0.0d0
 909       gradcorr_max=0.0d0
 910       gel_loc_max=0.0d0
 911       gcorr3_turn_max=0.0d0
 912       gcorr4_turn_max=0.0d0
 913       gradcorr5_max=0.0d0
 914       gradcorr6_max=0.0d0
 915       gcorr6_turn_max=0.0d0
 916       gsccorc_max=0.0d0
 917       gscloc_max=0.0d0
 918       gvdwx_max=0.0d0
 919       gradx_scp_max=0.0d0
 920       ghpbx_max=0.0d0
 921       gradxorr_max=0.0d0
 922       gsccorx_max=0.0d0
 923       gsclocx_max=0.0d0
 924       do i=1,nct
 925         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 926         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 927 #ifdef TSCSC
 928         gvdwc_norm=dsqrt(scalar(gvdwcT(1,i),gvdwcT(1,i)))
 929         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 930 #endif
 931         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 932         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 933      &   gvdwc_scp_max=gvdwc_scp_norm
 934         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 935         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 936         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 937         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 938         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 939         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 940         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 941         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 942         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 943         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 944         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 945         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 946         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 947      &    gcorr3_turn(1,i)))
 948         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 949      &    gcorr3_turn_max=gcorr3_turn_norm
 950         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 951      &    gcorr4_turn(1,i)))
 952         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 953      &    gcorr4_turn_max=gcorr4_turn_norm
 954         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 955         if (gradcorr5_norm.gt.gradcorr5_max)
 956      &    gradcorr5_max=gradcorr5_norm
 957         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 958         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 959         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 960      &    gcorr6_turn(1,i)))
 961         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 962      &    gcorr6_turn_max=gcorr6_turn_norm
 963         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 964         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 965         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 966         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 967         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 968         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 969 #ifdef TSCSC
 970         gvdwx_norm=dsqrt(scalar(gvdwxT(1,i),gvdwxT(1,i)))
 971         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 972 #endif
 973         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 974         if (gradx_scp_norm.gt.gradx_scp_max)
 975      &    gradx_scp_max=gradx_scp_norm
 976         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 977         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 978         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 979         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 980         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 981         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 982         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 983         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 984       enddo
 985       if (gradout) then
 986 #ifdef AIX
 987         open(istat,file=statname,position="append")
 988 #else
 989         open(istat,file=statname,access="append")
 990 #endif
 991         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 992      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 993      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 994      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 995      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 996      &     gsccorx_max,gsclocx_max
 997         close(istat)
 998         if (gvdwc_max.gt.1.0d4) then
 999           write (iout,*) "gvdwc gvdwx gradb gradbx"
1000           do i=nnt,nct
1001             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
1002      &        gradb(j,i),gradbx(j,i),j=1,3)
1003           enddo
1004           call pdbout(0.0d0,'cipiszcze',iout)
1005           call flush(iout)
1006         endif
1007       endif
1008       endif
1009 #ifdef DEBUG
1010       write (iout,*) "gradc gradx gloc"
1011       do i=1,nres
1012         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
1013      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
1014       enddo
1015 #endif
1016 #ifdef TIMING
1017 #ifdef MPI
1018       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
1019 #else
1020       time_sumgradient=time_sumgradient+tcpu()-time01
1021 #endif
1022 #endif
1023       return
1024       end
1025 c-------------------------------------------------------------------------------
1026       subroutine rescale_weights(t_bath)
1027       implicit real*8 (a-h,o-z)
1028       include 'DIMENSIONS'
1029       include 'COMMON.IOUNITS'
1030       include 'COMMON.FFIELD'
1031       include 'COMMON.SBRIDGE'
1032       double precision kfac /2.4d0/
1033       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
1034 c      facT=temp0/t_bath
1035 c      facT=2*temp0/(t_bath+temp0)
1036       if (rescale_mode.eq.0) then
1037         facT=1.0d0
1038         facT2=1.0d0
1039         facT3=1.0d0
1040         facT4=1.0d0
1041         facT5=1.0d0
1042       else if (rescale_mode.eq.1) then
1043         facT=kfac/(kfac-1.0d0+t_bath/temp0)
1044         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1045         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1046         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1047         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1048       else if (rescale_mode.eq.2) then
1049         x=t_bath/temp0
1050         x2=x*x
1051         x3=x2*x
1052         x4=x3*x
1053         x5=x4*x
1054         facT=licznik/dlog(dexp(x)+dexp(-x))
1055         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
1056         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
1057         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
1058         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
1059       else
1060         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1061         write (*,*) "Wrong RESCALE_MODE",rescale_mode
1062 #ifdef MPI
1063        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1064 #endif
1065        stop 555
1066       endif
1067       welec=weights(3)*fact
1068       wcorr=weights(4)*fact3
1069       wcorr5=weights(5)*fact4
1070       wcorr6=weights(6)*fact5
1071       wel_loc=weights(7)*fact2
1072       wturn3=weights(8)*fact2
1073       wturn4=weights(9)*fact3
1074       wturn6=weights(10)*fact5
1075       wtor=weights(13)*fact
1076       wtor_d=weights(14)*fact2
1077       wsccor=weights(21)*fact
1078 #ifdef TSCSC
1079 c      wsct=t_bath/temp0
1080       wsct=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
1081 #endif
1082       return
1083       end
1084 C------------------------------------------------------------------------
1085       subroutine enerprint(energia)
1086       implicit real*8 (a-h,o-z)
1087       include 'DIMENSIONS'
1088       include 'COMMON.IOUNITS'
1089       include 'COMMON.FFIELD'
1090       include 'COMMON.SBRIDGE'
1091       include 'COMMON.MD'
1092       double precision energia(0:n_ene)
1093       etot=energia(0)
1094 #ifdef TSCSC
1095       evdw=energia(22)+wsct*energia(23)
1096 #else
1097       evdw=energia(1)
1098 #endif
1099       evdw2=energia(2)
1100 #ifdef SCP14
1101       evdw2=energia(2)+energia(18)
1102 #else
1103       evdw2=energia(2)
1104 #endif
1105       ees=energia(3)
1106 #ifdef SPLITELE
1107       evdw1=energia(16)
1108 #endif
1109       ecorr=energia(4)
1110       ecorr5=energia(5)
1111       ecorr6=energia(6)
1112       eel_loc=energia(7)
1113       eello_turn3=energia(8)
1114       eello_turn4=energia(9)
1115       eello_turn6=energia(10)
1116       ebe=energia(11)
1117       escloc=energia(12)
1118       etors=energia(13)
1119       etors_d=energia(14)
1120       ehpb=energia(15)
1121       edihcnstr=energia(19)
1122       estr=energia(17)
1123       Uconst=energia(20)
1124       esccor=energia(21)
1125       ehomology_constr=energia(24)
1126 C     Bartek
1127       edfadis = energia(25)
1128       edfator = energia(26)
1129       edfanei = energia(27)
1130       edfabet = energia(28)
1131
1132 #ifdef SPLITELE
1133       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1134      &  estr,wbond,ebe,wang,
1135      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1136      &  ecorr,wcorr,
1137      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1138      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
1139      &  edihcnstr,ehomology_constr, ebr*nss,
1140      &  Uconst,edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
1141      &  edfabet,wdfa_beta,etot
1142    10 format (/'Virtual-chain energies:'//
1143      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
1144      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
1145      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
1146      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pE16.6,' (p-p VDW)'/
1147      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
1148      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
1149      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
1150      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
1151      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
1152      & 'EHPB=  ',1pE16.6,' WEIGHT=',1pE16.6,
1153      & ' (SS bridges & dist. cnstr.)'/
1154      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1155      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1156      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1157      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
1158      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
1159      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
1160      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
1161      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
1162      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1163      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1164      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1165      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1166      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
1167      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
1168      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
1169      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
1170      & 'ETOT=  ',1pE16.6,' (total)')
1171 #else
1172       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1173      &  estr,wbond,ebe,wang,
1174      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1175      &  ecorr,wcorr,
1176      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1177      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1178      &  ehomology_constr,ebr*nss,Uconst,edfadis,wdfa_dist,edfator,
1179      &  wdfa_tor,edfanei,wdfa_nei,edfabet,wdfa_beta,
1180      &  etot
1181    10 format (/'Virtual-chain energies:'//
1182      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1183      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1184      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1185      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1186      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1187      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1188      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1189      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1190      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1191      & ' (SS bridges & dist. cnstr.)'/
1192      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1193      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1194      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1195      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1196      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1197      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1198      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1199      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1200      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1201      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1202      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1203      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1204      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA distance energy)'/
1205      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA torsion energy)'/
1206      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA NCa energy)'/
1207      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA Beta energy)'/
1208      & 'ETOT=  ',1pE16.6,' (total)')
1209 #endif
1210       return
1211       end
1212 C-----------------------------------------------------------------------
1213       subroutine elj(evdw,evdw_p,evdw_m)
1214 C
1215 C This subroutine calculates the interaction energy of nonbonded side chains
1216 C assuming the LJ potential of interaction.
1217 C
1218       implicit real*8 (a-h,o-z)
1219       include 'DIMENSIONS'
1220       parameter (accur=1.0d-10)
1221       include 'COMMON.GEO'
1222       include 'COMMON.VAR'
1223       include 'COMMON.LOCAL'
1224       include 'COMMON.CHAIN'
1225       include 'COMMON.DERIV'
1226       include 'COMMON.INTERACT'
1227       include 'COMMON.TORSION'
1228       include 'COMMON.SBRIDGE'
1229       include 'COMMON.NAMES'
1230       include 'COMMON.IOUNITS'
1231       include 'COMMON.CONTACTS'
1232       dimension gg(3)
1233 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1234       evdw=0.0D0
1235       do i=iatsc_s,iatsc_e
1236         itypi=itype(i)
1237         itypi1=itype(i+1)
1238         xi=c(1,nres+i)
1239         yi=c(2,nres+i)
1240         zi=c(3,nres+i)
1241 C Change 12/1/95
1242         num_conti=0
1243 C
1244 C Calculate SC interaction energy.
1245 C
1246         do iint=1,nint_gr(i)
1247 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1248 cd   &                  'iend=',iend(i,iint)
1249           do j=istart(i,iint),iend(i,iint)
1250             itypj=itype(j)
1251             xj=c(1,nres+j)-xi
1252             yj=c(2,nres+j)-yi
1253             zj=c(3,nres+j)-zi
1254 C Change 12/1/95 to calculate four-body interactions
1255             rij=xj*xj+yj*yj+zj*zj
1256             rrij=1.0D0/rij
1257 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1258             eps0ij=eps(itypi,itypj)
1259             fac=rrij**expon2
1260             e1=fac*fac*aa(itypi,itypj)
1261             e2=fac*bb(itypi,itypj)
1262             evdwij=e1+e2
1263 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1264 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1265 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1266 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1267 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1268 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1269 #ifdef TSCSC
1270             if (bb(itypi,itypj).gt.0) then
1271                evdw_p=evdw_p+evdwij
1272             else
1273                evdw_m=evdw_m+evdwij
1274             endif
1275 #else
1276             evdw=evdw+evdwij
1277 #endif
1278 C
1279 C Calculate the components of the gradient in DC and X
1280 C
1281             fac=-rrij*(e1+evdwij)
1282             gg(1)=xj*fac
1283             gg(2)=yj*fac
1284             gg(3)=zj*fac
1285 #ifdef TSCSC
1286             if (bb(itypi,itypj).gt.0.0d0) then
1287               do k=1,3
1288                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1289                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1290                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1291                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1292               enddo
1293             else
1294               do k=1,3
1295                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1296                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1297                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1298                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1299               enddo
1300             endif
1301 #else
1302             do k=1,3
1303               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1304               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1305               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1306               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1307             enddo
1308 #endif
1309 cgrad            do k=i,j-1
1310 cgrad              do l=1,3
1311 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1312 cgrad              enddo
1313 cgrad            enddo
1314 C
1315 C 12/1/95, revised on 5/20/97
1316 C
1317 C Calculate the contact function. The ith column of the array JCONT will
1318 C contain the numbers of atoms that make contacts with the atom I (of numbers
1319 C greater than I). The arrays FACONT and GACONT will contain the values of
1320 C the contact function and its derivative.
1321 C
1322 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1323 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1324 C Uncomment next line, if the correlation interactions are contact function only
1325             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1326               rij=dsqrt(rij)
1327               sigij=sigma(itypi,itypj)
1328               r0ij=rs0(itypi,itypj)
1329 C
1330 C Check whether the SC's are not too far to make a contact.
1331 C
1332               rcut=1.5d0*r0ij
1333               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1334 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1335 C
1336               if (fcont.gt.0.0D0) then
1337 C If the SC-SC distance if close to sigma, apply spline.
1338 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1339 cAdam &             fcont1,fprimcont1)
1340 cAdam           fcont1=1.0d0-fcont1
1341 cAdam           if (fcont1.gt.0.0d0) then
1342 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1343 cAdam             fcont=fcont*fcont1
1344 cAdam           endif
1345 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1346 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1347 cga             do k=1,3
1348 cga               gg(k)=gg(k)*eps0ij
1349 cga             enddo
1350 cga             eps0ij=-evdwij*eps0ij
1351 C Uncomment for AL's type of SC correlation interactions.
1352 cadam           eps0ij=-evdwij
1353                 num_conti=num_conti+1
1354                 jcont(num_conti,i)=j
1355                 facont(num_conti,i)=fcont*eps0ij
1356                 fprimcont=eps0ij*fprimcont/rij
1357                 fcont=expon*fcont
1358 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1359 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1360 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1361 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1362                 gacont(1,num_conti,i)=-fprimcont*xj
1363                 gacont(2,num_conti,i)=-fprimcont*yj
1364                 gacont(3,num_conti,i)=-fprimcont*zj
1365 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1366 cd              write (iout,'(2i3,3f10.5)')
1367 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1368               endif
1369             endif
1370           enddo      ! j
1371         enddo        ! iint
1372 C Change 12/1/95
1373         num_cont(i)=num_conti
1374       enddo          ! i
1375       do i=1,nct
1376         do j=1,3
1377           gvdwc(j,i)=expon*gvdwc(j,i)
1378           gvdwx(j,i)=expon*gvdwx(j,i)
1379         enddo
1380       enddo
1381 C******************************************************************************
1382 C
1383 C                              N O T E !!!
1384 C
1385 C To save time, the factor of EXPON has been extracted from ALL components
1386 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1387 C use!
1388 C
1389 C******************************************************************************
1390       return
1391       end
1392 C-----------------------------------------------------------------------------
1393       subroutine eljk(evdw,evdw_p,evdw_m)
1394 C
1395 C This subroutine calculates the interaction energy of nonbonded side chains
1396 C assuming the LJK potential of interaction.
1397 C
1398       implicit real*8 (a-h,o-z)
1399       include 'DIMENSIONS'
1400       include 'COMMON.GEO'
1401       include 'COMMON.VAR'
1402       include 'COMMON.LOCAL'
1403       include 'COMMON.CHAIN'
1404       include 'COMMON.DERIV'
1405       include 'COMMON.INTERACT'
1406       include 'COMMON.IOUNITS'
1407       include 'COMMON.NAMES'
1408       dimension gg(3)
1409       logical scheck
1410 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1411       evdw=0.0D0
1412       do i=iatsc_s,iatsc_e
1413         itypi=itype(i)
1414         itypi1=itype(i+1)
1415         xi=c(1,nres+i)
1416         yi=c(2,nres+i)
1417         zi=c(3,nres+i)
1418 C
1419 C Calculate SC interaction energy.
1420 C
1421         do iint=1,nint_gr(i)
1422           do j=istart(i,iint),iend(i,iint)
1423             itypj=itype(j)
1424             xj=c(1,nres+j)-xi
1425             yj=c(2,nres+j)-yi
1426             zj=c(3,nres+j)-zi
1427             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1428             fac_augm=rrij**expon
1429             e_augm=augm(itypi,itypj)*fac_augm
1430             r_inv_ij=dsqrt(rrij)
1431             rij=1.0D0/r_inv_ij
1432             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1433             fac=r_shift_inv**expon
1434             e1=fac*fac*aa(itypi,itypj)
1435             e2=fac*bb(itypi,itypj)
1436             evdwij=e_augm+e1+e2
1437 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1438 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1439 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1440 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1441 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1442 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1443 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1444 #ifdef TSCSC
1445             if (bb(itypi,itypj).gt.0) then
1446                evdw_p=evdw_p+evdwij
1447             else
1448                evdw_m=evdw_m+evdwij
1449             endif
1450 #else
1451             evdw=evdw+evdwij
1452 #endif
1453 C
1454 C Calculate the components of the gradient in DC and X
1455 C
1456             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1457             gg(1)=xj*fac
1458             gg(2)=yj*fac
1459             gg(3)=zj*fac
1460 #ifdef TSCSC
1461             if (bb(itypi,itypj).gt.0.0d0) then
1462               do k=1,3
1463                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1464                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1465                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1466                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1467               enddo
1468             else
1469               do k=1,3
1470                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1471                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1472                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1473                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1474               enddo
1475             endif
1476 #else
1477             do k=1,3
1478               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1479               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1480               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1481               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1482             enddo
1483 #endif
1484 cgrad            do k=i,j-1
1485 cgrad              do l=1,3
1486 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1487 cgrad              enddo
1488 cgrad            enddo
1489           enddo      ! j
1490         enddo        ! iint
1491       enddo          ! i
1492       do i=1,nct
1493         do j=1,3
1494           gvdwc(j,i)=expon*gvdwc(j,i)
1495           gvdwx(j,i)=expon*gvdwx(j,i)
1496         enddo
1497       enddo
1498       return
1499       end
1500 C-----------------------------------------------------------------------------
1501       subroutine ebp(evdw,evdw_p,evdw_m)
1502 C
1503 C This subroutine calculates the interaction energy of nonbonded side chains
1504 C assuming the Berne-Pechukas potential of interaction.
1505 C
1506       implicit real*8 (a-h,o-z)
1507       include 'DIMENSIONS'
1508       include 'COMMON.GEO'
1509       include 'COMMON.VAR'
1510       include 'COMMON.LOCAL'
1511       include 'COMMON.CHAIN'
1512       include 'COMMON.DERIV'
1513       include 'COMMON.NAMES'
1514       include 'COMMON.INTERACT'
1515       include 'COMMON.IOUNITS'
1516       include 'COMMON.CALC'
1517       common /srutu/ icall
1518 c     double precision rrsave(maxdim)
1519       logical lprn
1520       evdw=0.0D0
1521 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1522       evdw=0.0D0
1523 c     if (icall.eq.0) then
1524 c       lprn=.true.
1525 c     else
1526         lprn=.false.
1527 c     endif
1528       ind=0
1529       do i=iatsc_s,iatsc_e
1530         itypi=itype(i)
1531         itypi1=itype(i+1)
1532         xi=c(1,nres+i)
1533         yi=c(2,nres+i)
1534         zi=c(3,nres+i)
1535         dxi=dc_norm(1,nres+i)
1536         dyi=dc_norm(2,nres+i)
1537         dzi=dc_norm(3,nres+i)
1538 c        dsci_inv=dsc_inv(itypi)
1539         dsci_inv=vbld_inv(i+nres)
1540 C
1541 C Calculate SC interaction energy.
1542 C
1543         do iint=1,nint_gr(i)
1544           do j=istart(i,iint),iend(i,iint)
1545             ind=ind+1
1546             itypj=itype(j)
1547 c            dscj_inv=dsc_inv(itypj)
1548             dscj_inv=vbld_inv(j+nres)
1549             chi1=chi(itypi,itypj)
1550             chi2=chi(itypj,itypi)
1551             chi12=chi1*chi2
1552             chip1=chip(itypi)
1553             chip2=chip(itypj)
1554             chip12=chip1*chip2
1555             alf1=alp(itypi)
1556             alf2=alp(itypj)
1557             alf12=0.5D0*(alf1+alf2)
1558 C For diagnostics only!!!
1559 c           chi1=0.0D0
1560 c           chi2=0.0D0
1561 c           chi12=0.0D0
1562 c           chip1=0.0D0
1563 c           chip2=0.0D0
1564 c           chip12=0.0D0
1565 c           alf1=0.0D0
1566 c           alf2=0.0D0
1567 c           alf12=0.0D0
1568             xj=c(1,nres+j)-xi
1569             yj=c(2,nres+j)-yi
1570             zj=c(3,nres+j)-zi
1571             dxj=dc_norm(1,nres+j)
1572             dyj=dc_norm(2,nres+j)
1573             dzj=dc_norm(3,nres+j)
1574             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1575 cd          if (icall.eq.0) then
1576 cd            rrsave(ind)=rrij
1577 cd          else
1578 cd            rrij=rrsave(ind)
1579 cd          endif
1580             rij=dsqrt(rrij)
1581 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1582             call sc_angular
1583 C Calculate whole angle-dependent part of epsilon and contributions
1584 C to its derivatives
1585             fac=(rrij*sigsq)**expon2
1586             e1=fac*fac*aa(itypi,itypj)
1587             e2=fac*bb(itypi,itypj)
1588             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1589             eps2der=evdwij*eps3rt
1590             eps3der=evdwij*eps2rt
1591             evdwij=evdwij*eps2rt*eps3rt
1592 #ifdef TSCSC
1593             if (bb(itypi,itypj).gt.0) then
1594                evdw_p=evdw_p+evdwij
1595             else
1596                evdw_m=evdw_m+evdwij
1597             endif
1598 #else
1599             evdw=evdw+evdwij
1600 #endif
1601             if (lprn) then
1602             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1603             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1604 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1605 cd     &        restyp(itypi),i,restyp(itypj),j,
1606 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1607 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1608 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1609 cd     &        evdwij
1610             endif
1611 C Calculate gradient components.
1612             e1=e1*eps1*eps2rt**2*eps3rt**2
1613             fac=-expon*(e1+evdwij)
1614             sigder=fac/sigsq
1615             fac=rrij*fac
1616 C Calculate radial part of the gradient
1617             gg(1)=xj*fac
1618             gg(2)=yj*fac
1619             gg(3)=zj*fac
1620 C Calculate the angular part of the gradient and sum add the contributions
1621 C to the appropriate components of the Cartesian gradient.
1622 #ifdef TSCSC
1623             if (bb(itypi,itypj).gt.0) then
1624                call sc_grad
1625             else
1626                call sc_grad_T
1627             endif
1628 #else
1629             call sc_grad
1630 #endif
1631           enddo      ! j
1632         enddo        ! iint
1633       enddo          ! i
1634 c     stop
1635       return
1636       end
1637 C-----------------------------------------------------------------------------
1638       subroutine egb(evdw,evdw_p,evdw_m)
1639 C
1640 C This subroutine calculates the interaction energy of nonbonded side chains
1641 C assuming the Gay-Berne potential of interaction.
1642 C
1643       implicit real*8 (a-h,o-z)
1644       include 'DIMENSIONS'
1645       include 'COMMON.GEO'
1646       include 'COMMON.VAR'
1647       include 'COMMON.LOCAL'
1648       include 'COMMON.CHAIN'
1649       include 'COMMON.DERIV'
1650       include 'COMMON.NAMES'
1651       include 'COMMON.INTERACT'
1652       include 'COMMON.IOUNITS'
1653       include 'COMMON.CALC'
1654       include 'COMMON.CONTROL'
1655       include 'COMMON.SBRIDGE'
1656       logical lprn
1657       evdw=0.0D0
1658 ccccc      energy_dec=.false.
1659 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1660       evdw=0.0D0
1661       evdw_p=0.0D0
1662       evdw_m=0.0D0
1663       lprn=.false.
1664 c     if (icall.eq.0) lprn=.false.
1665       ind=0
1666       do i=iatsc_s,iatsc_e
1667         itypi=itype(i)
1668         itypi1=itype(i+1)
1669         xi=c(1,nres+i)
1670         yi=c(2,nres+i)
1671         zi=c(3,nres+i)
1672         dxi=dc_norm(1,nres+i)
1673         dyi=dc_norm(2,nres+i)
1674         dzi=dc_norm(3,nres+i)
1675 c        dsci_inv=dsc_inv(itypi)
1676         dsci_inv=vbld_inv(i+nres)
1677 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1678 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1679 C
1680 C Calculate SC interaction energy.
1681 C
1682         do iint=1,nint_gr(i)
1683           do j=istart(i,iint),iend(i,iint)
1684             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1685               call dyn_ssbond_ene(i,j,evdwij)
1686               evdw=evdw+evdwij
1687               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1688      &                        'evdw',i,j,evdwij,' ss'
1689             ELSE
1690             ind=ind+1
1691             itypj=itype(j)
1692 c            dscj_inv=dsc_inv(itypj)
1693             dscj_inv=vbld_inv(j+nres)
1694 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1695 c     &       1.0d0/vbld(j+nres)
1696 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1697             sig0ij=sigma(itypi,itypj)
1698             chi1=chi(itypi,itypj)
1699             chi2=chi(itypj,itypi)
1700             chi12=chi1*chi2
1701             chip1=chip(itypi)
1702             chip2=chip(itypj)
1703             chip12=chip1*chip2
1704             alf1=alp(itypi)
1705             alf2=alp(itypj)
1706             alf12=0.5D0*(alf1+alf2)
1707 C For diagnostics only!!!
1708 c           chi1=0.0D0
1709 c           chi2=0.0D0
1710 c           chi12=0.0D0
1711 c           chip1=0.0D0
1712 c           chip2=0.0D0
1713 c           chip12=0.0D0
1714 c           alf1=0.0D0
1715 c           alf2=0.0D0
1716 c           alf12=0.0D0
1717             xj=c(1,nres+j)-xi
1718             yj=c(2,nres+j)-yi
1719             zj=c(3,nres+j)-zi
1720             dxj=dc_norm(1,nres+j)
1721             dyj=dc_norm(2,nres+j)
1722             dzj=dc_norm(3,nres+j)
1723 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1724 c            write (iout,*) "j",j," dc_norm",
1725 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1726             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1727             rij=dsqrt(rrij)
1728 C Calculate angle-dependent terms of energy and contributions to their
1729 C derivatives.
1730             call sc_angular
1731             sigsq=1.0D0/sigsq
1732             sig=sig0ij*dsqrt(sigsq)
1733             rij_shift=1.0D0/rij-sig+sig0ij
1734 c for diagnostics; uncomment
1735 c            rij_shift=1.2*sig0ij
1736 C I hate to put IF's in the loops, but here don't have another choice!!!!
1737             if (rij_shift.le.0.0D0) then
1738               evdw=1.0D20
1739 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1740 cd     &        restyp(itypi),i,restyp(itypj),j,
1741 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1742               return
1743             endif
1744             sigder=-sig*sigsq
1745 c---------------------------------------------------------------
1746             rij_shift=1.0D0/rij_shift
1747             fac=rij_shift**expon
1748             e1=fac*fac*aa(itypi,itypj)
1749             e2=fac*bb(itypi,itypj)
1750             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1751             eps2der=evdwij*eps3rt
1752             eps3der=evdwij*eps2rt
1753 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1754 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1755             evdwij=evdwij*eps2rt*eps3rt
1756 #ifdef TSCSC
1757             if (bb(itypi,itypj).gt.0) then
1758                evdw_p=evdw_p+evdwij
1759             else
1760                evdw_m=evdw_m+evdwij
1761             endif
1762 #else
1763             evdw=evdw+evdwij
1764 #endif
1765             if (lprn) then
1766             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1767             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1768             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1769      &        restyp(itypi),i,restyp(itypj),j,
1770      &        epsi,sigm,chi1,chi2,chip1,chip2,
1771      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1772      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1773      &        evdwij
1774             endif
1775
1776             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1777      &                        'evdw',i,j,evdwij
1778
1779 C Calculate gradient components.
1780             e1=e1*eps1*eps2rt**2*eps3rt**2
1781             fac=-expon*(e1+evdwij)*rij_shift
1782             sigder=fac*sigder
1783             fac=rij*fac
1784 c            fac=0.0d0
1785 C Calculate the radial part of the gradient
1786             gg(1)=xj*fac
1787             gg(2)=yj*fac
1788             gg(3)=zj*fac
1789 C Calculate angular part of the gradient.
1790 #ifdef TSCSC
1791             if (bb(itypi,itypj).gt.0) then
1792                call sc_grad
1793             else
1794                call sc_grad_T
1795             endif
1796 #else
1797             call sc_grad
1798 #endif
1799             ENDIF    ! dyn_ss
1800           enddo      ! j
1801         enddo        ! iint
1802       enddo          ! i
1803 c      write (iout,*) "Number of loop steps in EGB:",ind
1804 cccc      energy_dec=.false.
1805       return
1806       end
1807 C-----------------------------------------------------------------------------
1808       subroutine egbv(evdw,evdw_p,evdw_m)
1809 C
1810 C This subroutine calculates the interaction energy of nonbonded side chains
1811 C assuming the Gay-Berne-Vorobjev potential of interaction.
1812 C
1813       implicit real*8 (a-h,o-z)
1814       include 'DIMENSIONS'
1815       include 'COMMON.GEO'
1816       include 'COMMON.VAR'
1817       include 'COMMON.LOCAL'
1818       include 'COMMON.CHAIN'
1819       include 'COMMON.DERIV'
1820       include 'COMMON.NAMES'
1821       include 'COMMON.INTERACT'
1822       include 'COMMON.IOUNITS'
1823       include 'COMMON.CALC'
1824       common /srutu/ icall
1825       logical lprn
1826       evdw=0.0D0
1827 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1828       evdw=0.0D0
1829       lprn=.false.
1830 c     if (icall.eq.0) lprn=.true.
1831       ind=0
1832       do i=iatsc_s,iatsc_e
1833         itypi=itype(i)
1834         itypi1=itype(i+1)
1835         xi=c(1,nres+i)
1836         yi=c(2,nres+i)
1837         zi=c(3,nres+i)
1838         dxi=dc_norm(1,nres+i)
1839         dyi=dc_norm(2,nres+i)
1840         dzi=dc_norm(3,nres+i)
1841 c        dsci_inv=dsc_inv(itypi)
1842         dsci_inv=vbld_inv(i+nres)
1843 C
1844 C Calculate SC interaction energy.
1845 C
1846         do iint=1,nint_gr(i)
1847           do j=istart(i,iint),iend(i,iint)
1848             ind=ind+1
1849             itypj=itype(j)
1850 c            dscj_inv=dsc_inv(itypj)
1851             dscj_inv=vbld_inv(j+nres)
1852             sig0ij=sigma(itypi,itypj)
1853             r0ij=r0(itypi,itypj)
1854             chi1=chi(itypi,itypj)
1855             chi2=chi(itypj,itypi)
1856             chi12=chi1*chi2
1857             chip1=chip(itypi)
1858             chip2=chip(itypj)
1859             chip12=chip1*chip2
1860             alf1=alp(itypi)
1861             alf2=alp(itypj)
1862             alf12=0.5D0*(alf1+alf2)
1863 C For diagnostics only!!!
1864 c           chi1=0.0D0
1865 c           chi2=0.0D0
1866 c           chi12=0.0D0
1867 c           chip1=0.0D0
1868 c           chip2=0.0D0
1869 c           chip12=0.0D0
1870 c           alf1=0.0D0
1871 c           alf2=0.0D0
1872 c           alf12=0.0D0
1873             xj=c(1,nres+j)-xi
1874             yj=c(2,nres+j)-yi
1875             zj=c(3,nres+j)-zi
1876             dxj=dc_norm(1,nres+j)
1877             dyj=dc_norm(2,nres+j)
1878             dzj=dc_norm(3,nres+j)
1879             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1880             rij=dsqrt(rrij)
1881 C Calculate angle-dependent terms of energy and contributions to their
1882 C derivatives.
1883             call sc_angular
1884             sigsq=1.0D0/sigsq
1885             sig=sig0ij*dsqrt(sigsq)
1886             rij_shift=1.0D0/rij-sig+r0ij
1887 C I hate to put IF's in the loops, but here don't have another choice!!!!
1888             if (rij_shift.le.0.0D0) then
1889               evdw=1.0D20
1890               return
1891             endif
1892             sigder=-sig*sigsq
1893 c---------------------------------------------------------------
1894             rij_shift=1.0D0/rij_shift
1895             fac=rij_shift**expon
1896             e1=fac*fac*aa(itypi,itypj)
1897             e2=fac*bb(itypi,itypj)
1898             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1899             eps2der=evdwij*eps3rt
1900             eps3der=evdwij*eps2rt
1901             fac_augm=rrij**expon
1902             e_augm=augm(itypi,itypj)*fac_augm
1903             evdwij=evdwij*eps2rt*eps3rt
1904 #ifdef TSCSC
1905             if (bb(itypi,itypj).gt.0) then
1906                evdw_p=evdw_p+evdwij+e_augm
1907             else
1908                evdw_m=evdw_m+evdwij+e_augm
1909             endif
1910 #else
1911             evdw=evdw+evdwij+e_augm
1912 #endif
1913             if (lprn) then
1914             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1915             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1916             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1917      &        restyp(itypi),i,restyp(itypj),j,
1918      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1919      &        chi1,chi2,chip1,chip2,
1920      &        eps1,eps2rt**2,eps3rt**2,
1921      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1922      &        evdwij+e_augm
1923             endif
1924 C Calculate gradient components.
1925             e1=e1*eps1*eps2rt**2*eps3rt**2
1926             fac=-expon*(e1+evdwij)*rij_shift
1927             sigder=fac*sigder
1928             fac=rij*fac-2*expon*rrij*e_augm
1929 C Calculate the radial part of the gradient
1930             gg(1)=xj*fac
1931             gg(2)=yj*fac
1932             gg(3)=zj*fac
1933 C Calculate angular part of the gradient.
1934 #ifdef TSCSC
1935             if (bb(itypi,itypj).gt.0) then
1936                call sc_grad
1937             else
1938                call sc_grad_T
1939             endif
1940 #else
1941             call sc_grad
1942 #endif
1943           enddo      ! j
1944         enddo        ! iint
1945       enddo          ! i
1946       end
1947 C-----------------------------------------------------------------------------
1948       subroutine sc_angular
1949 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1950 C om12. Called by ebp, egb, and egbv.
1951       implicit none
1952       include 'COMMON.CALC'
1953       include 'COMMON.IOUNITS'
1954       erij(1)=xj*rij
1955       erij(2)=yj*rij
1956       erij(3)=zj*rij
1957       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1958       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1959       om12=dxi*dxj+dyi*dyj+dzi*dzj
1960       chiom12=chi12*om12
1961 C Calculate eps1(om12) and its derivative in om12
1962       faceps1=1.0D0-om12*chiom12
1963       faceps1_inv=1.0D0/faceps1
1964       eps1=dsqrt(faceps1_inv)
1965 C Following variable is eps1*deps1/dom12
1966       eps1_om12=faceps1_inv*chiom12
1967 c diagnostics only
1968 c      faceps1_inv=om12
1969 c      eps1=om12
1970 c      eps1_om12=1.0d0
1971 c      write (iout,*) "om12",om12," eps1",eps1
1972 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1973 C and om12.
1974       om1om2=om1*om2
1975       chiom1=chi1*om1
1976       chiom2=chi2*om2
1977       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1978       sigsq=1.0D0-facsig*faceps1_inv
1979       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1980       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1981       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1982 c diagnostics only
1983 c      sigsq=1.0d0
1984 c      sigsq_om1=0.0d0
1985 c      sigsq_om2=0.0d0
1986 c      sigsq_om12=0.0d0
1987 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1988 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1989 c     &    " eps1",eps1
1990 C Calculate eps2 and its derivatives in om1, om2, and om12.
1991       chipom1=chip1*om1
1992       chipom2=chip2*om2
1993       chipom12=chip12*om12
1994       facp=1.0D0-om12*chipom12
1995       facp_inv=1.0D0/facp
1996       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1997 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1998 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1999 C Following variable is the square root of eps2
2000       eps2rt=1.0D0-facp1*facp_inv
2001 C Following three variables are the derivatives of the square root of eps
2002 C in om1, om2, and om12.
2003       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2004       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2005       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2006 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2007       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2008 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2009 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2010 c     &  " eps2rt_om12",eps2rt_om12
2011 C Calculate whole angle-dependent part of epsilon and contributions
2012 C to its derivatives
2013       return
2014       end
2015
2016 C----------------------------------------------------------------------------
2017       subroutine sc_grad_T
2018       implicit real*8 (a-h,o-z)
2019       include 'DIMENSIONS'
2020       include 'COMMON.CHAIN'
2021       include 'COMMON.DERIV'
2022       include 'COMMON.CALC'
2023       include 'COMMON.IOUNITS'
2024       double precision dcosom1(3),dcosom2(3)
2025       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2026       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2027       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2028      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2029 c diagnostics only
2030 c      eom1=0.0d0
2031 c      eom2=0.0d0
2032 c      eom12=evdwij*eps1_om12
2033 c end diagnostics
2034 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2035 c     &  " sigder",sigder
2036 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2037 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2038       do k=1,3
2039         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2040         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2041       enddo
2042       do k=1,3
2043         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
2044       enddo
2045 c      write (iout,*) "gg",(gg(k),k=1,3)
2046       do k=1,3
2047         gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
2048      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2049      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2050         gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
2051      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2052      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2053 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2054 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2055 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2056 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2057       enddo
2058 C
2059 C Calculate the components of the gradient in DC and X
2060 C
2061 cgrad      do k=i,j-1
2062 cgrad        do l=1,3
2063 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2064 cgrad        enddo
2065 cgrad      enddo
2066       do l=1,3
2067         gvdwcT(l,i)=gvdwcT(l,i)-gg(l)
2068         gvdwcT(l,j)=gvdwcT(l,j)+gg(l)
2069       enddo
2070       return
2071       end
2072
2073 C----------------------------------------------------------------------------
2074       subroutine sc_grad
2075       implicit real*8 (a-h,o-z)
2076       include 'DIMENSIONS'
2077       include 'COMMON.CHAIN'
2078       include 'COMMON.DERIV'
2079       include 'COMMON.CALC'
2080       include 'COMMON.IOUNITS'
2081       double precision dcosom1(3),dcosom2(3)
2082       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2083       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2084       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2085      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2086 c diagnostics only
2087 c      eom1=0.0d0
2088 c      eom2=0.0d0
2089 c      eom12=evdwij*eps1_om12
2090 c end diagnostics
2091 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2092 c     &  " sigder",sigder
2093 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2094 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2095       do k=1,3
2096         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2097         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2098       enddo
2099       do k=1,3
2100         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
2101       enddo
2102 c      write (iout,*) "gg",(gg(k),k=1,3)
2103       do k=1,3
2104         gvdwx(k,i)=gvdwx(k,i)-gg(k)
2105      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2106      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2107         gvdwx(k,j)=gvdwx(k,j)+gg(k)
2108      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2109      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2110 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2111 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2112 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2113 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2114       enddo
2115 C
2116 C Calculate the components of the gradient in DC and X
2117 C
2118 cgrad      do k=i,j-1
2119 cgrad        do l=1,3
2120 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2121 cgrad        enddo
2122 cgrad      enddo
2123       do l=1,3
2124         gvdwc(l,i)=gvdwc(l,i)-gg(l)
2125         gvdwc(l,j)=gvdwc(l,j)+gg(l)
2126       enddo
2127       return
2128       end
2129 C-----------------------------------------------------------------------
2130       subroutine e_softsphere(evdw)
2131 C
2132 C This subroutine calculates the interaction energy of nonbonded side chains
2133 C assuming the LJ potential of interaction.
2134 C
2135       implicit real*8 (a-h,o-z)
2136       include 'DIMENSIONS'
2137       parameter (accur=1.0d-10)
2138       include 'COMMON.GEO'
2139       include 'COMMON.VAR'
2140       include 'COMMON.LOCAL'
2141       include 'COMMON.CHAIN'
2142       include 'COMMON.DERIV'
2143       include 'COMMON.INTERACT'
2144       include 'COMMON.TORSION'
2145       include 'COMMON.SBRIDGE'
2146       include 'COMMON.NAMES'
2147       include 'COMMON.IOUNITS'
2148       include 'COMMON.CONTACTS'
2149       dimension gg(3)
2150 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2151       evdw=0.0D0
2152       do i=iatsc_s,iatsc_e
2153         itypi=itype(i)
2154         itypi1=itype(i+1)
2155         xi=c(1,nres+i)
2156         yi=c(2,nres+i)
2157         zi=c(3,nres+i)
2158 C
2159 C Calculate SC interaction energy.
2160 C
2161         do iint=1,nint_gr(i)
2162 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2163 cd   &                  'iend=',iend(i,iint)
2164           do j=istart(i,iint),iend(i,iint)
2165             itypj=itype(j)
2166             xj=c(1,nres+j)-xi
2167             yj=c(2,nres+j)-yi
2168             zj=c(3,nres+j)-zi
2169             rij=xj*xj+yj*yj+zj*zj
2170 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2171             r0ij=r0(itypi,itypj)
2172             r0ijsq=r0ij*r0ij
2173 c            print *,i,j,r0ij,dsqrt(rij)
2174             if (rij.lt.r0ijsq) then
2175               evdwij=0.25d0*(rij-r0ijsq)**2
2176               fac=rij-r0ijsq
2177             else
2178               evdwij=0.0d0
2179               fac=0.0d0
2180             endif
2181             evdw=evdw+evdwij
2182 C
2183 C Calculate the components of the gradient in DC and X
2184 C
2185             gg(1)=xj*fac
2186             gg(2)=yj*fac
2187             gg(3)=zj*fac
2188             do k=1,3
2189               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2190               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2191               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2192               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2193             enddo
2194 cgrad            do k=i,j-1
2195 cgrad              do l=1,3
2196 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2197 cgrad              enddo
2198 cgrad            enddo
2199           enddo ! j
2200         enddo ! iint
2201       enddo ! i
2202       return
2203       end
2204 C--------------------------------------------------------------------------
2205       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2206      &              eello_turn4)
2207 C
2208 C Soft-sphere potential of p-p interaction
2209 C
2210       implicit real*8 (a-h,o-z)
2211       include 'DIMENSIONS'
2212       include 'COMMON.CONTROL'
2213       include 'COMMON.IOUNITS'
2214       include 'COMMON.GEO'
2215       include 'COMMON.VAR'
2216       include 'COMMON.LOCAL'
2217       include 'COMMON.CHAIN'
2218       include 'COMMON.DERIV'
2219       include 'COMMON.INTERACT'
2220       include 'COMMON.CONTACTS'
2221       include 'COMMON.TORSION'
2222       include 'COMMON.VECTORS'
2223       include 'COMMON.FFIELD'
2224       dimension ggg(3)
2225 cd      write(iout,*) 'In EELEC_soft_sphere'
2226       ees=0.0D0
2227       evdw1=0.0D0
2228       eel_loc=0.0d0
2229       eello_turn3=0.0d0
2230       eello_turn4=0.0d0
2231       ind=0
2232       do i=iatel_s,iatel_e
2233         dxi=dc(1,i)
2234         dyi=dc(2,i)
2235         dzi=dc(3,i)
2236         xmedi=c(1,i)+0.5d0*dxi
2237         ymedi=c(2,i)+0.5d0*dyi
2238         zmedi=c(3,i)+0.5d0*dzi
2239         num_conti=0
2240 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2241         do j=ielstart(i),ielend(i)
2242           ind=ind+1
2243           iteli=itel(i)
2244           itelj=itel(j)
2245           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2246           r0ij=rpp(iteli,itelj)
2247           r0ijsq=r0ij*r0ij
2248           dxj=dc(1,j)
2249           dyj=dc(2,j)
2250           dzj=dc(3,j)
2251           xj=c(1,j)+0.5D0*dxj-xmedi
2252           yj=c(2,j)+0.5D0*dyj-ymedi
2253           zj=c(3,j)+0.5D0*dzj-zmedi
2254           rij=xj*xj+yj*yj+zj*zj
2255           if (rij.lt.r0ijsq) then
2256             evdw1ij=0.25d0*(rij-r0ijsq)**2
2257             fac=rij-r0ijsq
2258           else
2259             evdw1ij=0.0d0
2260             fac=0.0d0
2261           endif
2262           evdw1=evdw1+evdw1ij
2263 C
2264 C Calculate contributions to the Cartesian gradient.
2265 C
2266           ggg(1)=fac*xj
2267           ggg(2)=fac*yj
2268           ggg(3)=fac*zj
2269           do k=1,3
2270             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2271             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2272           enddo
2273 *
2274 * Loop over residues i+1 thru j-1.
2275 *
2276 cgrad          do k=i+1,j-1
2277 cgrad            do l=1,3
2278 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2279 cgrad            enddo
2280 cgrad          enddo
2281         enddo ! j
2282       enddo   ! i
2283 cgrad      do i=nnt,nct-1
2284 cgrad        do k=1,3
2285 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2286 cgrad        enddo
2287 cgrad        do j=i+1,nct-1
2288 cgrad          do k=1,3
2289 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2290 cgrad          enddo
2291 cgrad        enddo
2292 cgrad      enddo
2293       return
2294       end
2295 c------------------------------------------------------------------------------
2296       subroutine vec_and_deriv
2297       implicit real*8 (a-h,o-z)
2298       include 'DIMENSIONS'
2299 #ifdef MPI
2300       include 'mpif.h'
2301 #endif
2302       include 'COMMON.IOUNITS'
2303       include 'COMMON.GEO'
2304       include 'COMMON.VAR'
2305       include 'COMMON.LOCAL'
2306       include 'COMMON.CHAIN'
2307       include 'COMMON.VECTORS'
2308       include 'COMMON.SETUP'
2309       include 'COMMON.TIME1'
2310       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2311 C Compute the local reference systems. For reference system (i), the
2312 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2313 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2314 #ifdef PARVEC
2315       do i=ivec_start,ivec_end
2316 #else
2317       do i=1,nres-1
2318 #endif
2319           if (i.eq.nres-1) then
2320 C Case of the last full residue
2321 C Compute the Z-axis
2322             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2323             costh=dcos(pi-theta(nres))
2324             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2325             do k=1,3
2326               uz(k,i)=fac*uz(k,i)
2327             enddo
2328 C Compute the derivatives of uz
2329             uzder(1,1,1)= 0.0d0
2330             uzder(2,1,1)=-dc_norm(3,i-1)
2331             uzder(3,1,1)= dc_norm(2,i-1)
2332             uzder(1,2,1)= dc_norm(3,i-1)
2333             uzder(2,2,1)= 0.0d0
2334             uzder(3,2,1)=-dc_norm(1,i-1)
2335             uzder(1,3,1)=-dc_norm(2,i-1)
2336             uzder(2,3,1)= dc_norm(1,i-1)
2337             uzder(3,3,1)= 0.0d0
2338             uzder(1,1,2)= 0.0d0
2339             uzder(2,1,2)= dc_norm(3,i)
2340             uzder(3,1,2)=-dc_norm(2,i)
2341             uzder(1,2,2)=-dc_norm(3,i)
2342             uzder(2,2,2)= 0.0d0
2343             uzder(3,2,2)= dc_norm(1,i)
2344             uzder(1,3,2)= dc_norm(2,i)
2345             uzder(2,3,2)=-dc_norm(1,i)
2346             uzder(3,3,2)= 0.0d0
2347 C Compute the Y-axis
2348             facy=fac
2349             do k=1,3
2350               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2351             enddo
2352 C Compute the derivatives of uy
2353             do j=1,3
2354               do k=1,3
2355                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2356      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2357                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2358               enddo
2359               uyder(j,j,1)=uyder(j,j,1)-costh
2360               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2361             enddo
2362             do j=1,2
2363               do k=1,3
2364                 do l=1,3
2365                   uygrad(l,k,j,i)=uyder(l,k,j)
2366                   uzgrad(l,k,j,i)=uzder(l,k,j)
2367                 enddo
2368               enddo
2369             enddo
2370             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2371             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2372             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2373             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2374           else
2375 C Other residues
2376 C Compute the Z-axis
2377             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2378             costh=dcos(pi-theta(i+2))
2379             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2380             do k=1,3
2381               uz(k,i)=fac*uz(k,i)
2382             enddo
2383 C Compute the derivatives of uz
2384             uzder(1,1,1)= 0.0d0
2385             uzder(2,1,1)=-dc_norm(3,i+1)
2386             uzder(3,1,1)= dc_norm(2,i+1)
2387             uzder(1,2,1)= dc_norm(3,i+1)
2388             uzder(2,2,1)= 0.0d0
2389             uzder(3,2,1)=-dc_norm(1,i+1)
2390             uzder(1,3,1)=-dc_norm(2,i+1)
2391             uzder(2,3,1)= dc_norm(1,i+1)
2392             uzder(3,3,1)= 0.0d0
2393             uzder(1,1,2)= 0.0d0
2394             uzder(2,1,2)= dc_norm(3,i)
2395             uzder(3,1,2)=-dc_norm(2,i)
2396             uzder(1,2,2)=-dc_norm(3,i)
2397             uzder(2,2,2)= 0.0d0
2398             uzder(3,2,2)= dc_norm(1,i)
2399             uzder(1,3,2)= dc_norm(2,i)
2400             uzder(2,3,2)=-dc_norm(1,i)
2401             uzder(3,3,2)= 0.0d0
2402 C Compute the Y-axis
2403             facy=fac
2404             do k=1,3
2405               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2406             enddo
2407 C Compute the derivatives of uy
2408             do j=1,3
2409               do k=1,3
2410                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2411      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2412                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2413               enddo
2414               uyder(j,j,1)=uyder(j,j,1)-costh
2415               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2416             enddo
2417             do j=1,2
2418               do k=1,3
2419                 do l=1,3
2420                   uygrad(l,k,j,i)=uyder(l,k,j)
2421                   uzgrad(l,k,j,i)=uzder(l,k,j)
2422                 enddo
2423               enddo
2424             enddo
2425             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2426             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2427             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2428             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2429           endif
2430       enddo
2431       do i=1,nres-1
2432         vbld_inv_temp(1)=vbld_inv(i+1)
2433         if (i.lt.nres-1) then
2434           vbld_inv_temp(2)=vbld_inv(i+2)
2435           else
2436           vbld_inv_temp(2)=vbld_inv(i)
2437           endif
2438         do j=1,2
2439           do k=1,3
2440             do l=1,3
2441               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2442               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2443             enddo
2444           enddo
2445         enddo
2446       enddo
2447 #if defined(PARVEC) && defined(MPI)
2448       if (nfgtasks1.gt.1) then
2449         time00=MPI_Wtime()
2450 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2451 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2452 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2453         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2454      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2455      &   FG_COMM1,IERR)
2456         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2457      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2458      &   FG_COMM1,IERR)
2459         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2460      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2461      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2462         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2463      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2464      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2465         time_gather=time_gather+MPI_Wtime()-time00
2466       endif
2467 c      if (fg_rank.eq.0) then
2468 c        write (iout,*) "Arrays UY and UZ"
2469 c        do i=1,nres-1
2470 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2471 c     &     (uz(k,i),k=1,3)
2472 c        enddo
2473 c      endif
2474 #endif
2475       return
2476       end
2477 C-----------------------------------------------------------------------------
2478       subroutine check_vecgrad
2479       implicit real*8 (a-h,o-z)
2480       include 'DIMENSIONS'
2481       include 'COMMON.IOUNITS'
2482       include 'COMMON.GEO'
2483       include 'COMMON.VAR'
2484       include 'COMMON.LOCAL'
2485       include 'COMMON.CHAIN'
2486       include 'COMMON.VECTORS'
2487       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2488       dimension uyt(3,maxres),uzt(3,maxres)
2489       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2490       double precision delta /1.0d-7/
2491       call vec_and_deriv
2492 cd      do i=1,nres
2493 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2494 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2495 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2496 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2497 cd     &     (dc_norm(if90,i),if90=1,3)
2498 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2499 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2500 cd          write(iout,'(a)')
2501 cd      enddo
2502       do i=1,nres
2503         do j=1,2
2504           do k=1,3
2505             do l=1,3
2506               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2507               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2508             enddo
2509           enddo
2510         enddo
2511       enddo
2512       call vec_and_deriv
2513       do i=1,nres
2514         do j=1,3
2515           uyt(j,i)=uy(j,i)
2516           uzt(j,i)=uz(j,i)
2517         enddo
2518       enddo
2519       do i=1,nres
2520 cd        write (iout,*) 'i=',i
2521         do k=1,3
2522           erij(k)=dc_norm(k,i)
2523         enddo
2524         do j=1,3
2525           do k=1,3
2526             dc_norm(k,i)=erij(k)
2527           enddo
2528           dc_norm(j,i)=dc_norm(j,i)+delta
2529 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2530 c          do k=1,3
2531 c            dc_norm(k,i)=dc_norm(k,i)/fac
2532 c          enddo
2533 c          write (iout,*) (dc_norm(k,i),k=1,3)
2534 c          write (iout,*) (erij(k),k=1,3)
2535           call vec_and_deriv
2536           do k=1,3
2537             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2538             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2539             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2540             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2541           enddo
2542 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2543 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2544 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2545         enddo
2546         do k=1,3
2547           dc_norm(k,i)=erij(k)
2548         enddo
2549 cd        do k=1,3
2550 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2551 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2552 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2553 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2554 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2555 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2556 cd          write (iout,'(a)')
2557 cd        enddo
2558       enddo
2559       return
2560       end
2561 C--------------------------------------------------------------------------
2562       subroutine set_matrices
2563       implicit real*8 (a-h,o-z)
2564       include 'DIMENSIONS'
2565 #ifdef MPI
2566       include "mpif.h"
2567       include "COMMON.SETUP"
2568       integer IERR
2569       integer status(MPI_STATUS_SIZE)
2570 #endif
2571       include 'COMMON.IOUNITS'
2572       include 'COMMON.GEO'
2573       include 'COMMON.VAR'
2574       include 'COMMON.LOCAL'
2575       include 'COMMON.CHAIN'
2576       include 'COMMON.DERIV'
2577       include 'COMMON.INTERACT'
2578       include 'COMMON.CONTACTS'
2579       include 'COMMON.TORSION'
2580       include 'COMMON.VECTORS'
2581       include 'COMMON.FFIELD'
2582       double precision auxvec(2),auxmat(2,2)
2583 C
2584 C Compute the virtual-bond-torsional-angle dependent quantities needed
2585 C to calculate the el-loc multibody terms of various order.
2586 C
2587 #ifdef PARMAT
2588       do i=ivec_start+2,ivec_end+2
2589 #else
2590       do i=3,nres+1
2591 #endif
2592         if (i .lt. nres+1) then
2593           sin1=dsin(phi(i))
2594           cos1=dcos(phi(i))
2595           sintab(i-2)=sin1
2596           costab(i-2)=cos1
2597           obrot(1,i-2)=cos1
2598           obrot(2,i-2)=sin1
2599           sin2=dsin(2*phi(i))
2600           cos2=dcos(2*phi(i))
2601           sintab2(i-2)=sin2
2602           costab2(i-2)=cos2
2603           obrot2(1,i-2)=cos2
2604           obrot2(2,i-2)=sin2
2605           Ug(1,1,i-2)=-cos1
2606           Ug(1,2,i-2)=-sin1
2607           Ug(2,1,i-2)=-sin1
2608           Ug(2,2,i-2)= cos1
2609           Ug2(1,1,i-2)=-cos2
2610           Ug2(1,2,i-2)=-sin2
2611           Ug2(2,1,i-2)=-sin2
2612           Ug2(2,2,i-2)= cos2
2613         else
2614           costab(i-2)=1.0d0
2615           sintab(i-2)=0.0d0
2616           obrot(1,i-2)=1.0d0
2617           obrot(2,i-2)=0.0d0
2618           obrot2(1,i-2)=0.0d0
2619           obrot2(2,i-2)=0.0d0
2620           Ug(1,1,i-2)=1.0d0
2621           Ug(1,2,i-2)=0.0d0
2622           Ug(2,1,i-2)=0.0d0
2623           Ug(2,2,i-2)=1.0d0
2624           Ug2(1,1,i-2)=0.0d0
2625           Ug2(1,2,i-2)=0.0d0
2626           Ug2(2,1,i-2)=0.0d0
2627           Ug2(2,2,i-2)=0.0d0
2628         endif
2629         if (i .gt. 3 .and. i .lt. nres+1) then
2630           obrot_der(1,i-2)=-sin1
2631           obrot_der(2,i-2)= cos1
2632           Ugder(1,1,i-2)= sin1
2633           Ugder(1,2,i-2)=-cos1
2634           Ugder(2,1,i-2)=-cos1
2635           Ugder(2,2,i-2)=-sin1
2636           dwacos2=cos2+cos2
2637           dwasin2=sin2+sin2
2638           obrot2_der(1,i-2)=-dwasin2
2639           obrot2_der(2,i-2)= dwacos2
2640           Ug2der(1,1,i-2)= dwasin2
2641           Ug2der(1,2,i-2)=-dwacos2
2642           Ug2der(2,1,i-2)=-dwacos2
2643           Ug2der(2,2,i-2)=-dwasin2
2644         else
2645           obrot_der(1,i-2)=0.0d0
2646           obrot_der(2,i-2)=0.0d0
2647           Ugder(1,1,i-2)=0.0d0
2648           Ugder(1,2,i-2)=0.0d0
2649           Ugder(2,1,i-2)=0.0d0
2650           Ugder(2,2,i-2)=0.0d0
2651           obrot2_der(1,i-2)=0.0d0
2652           obrot2_der(2,i-2)=0.0d0
2653           Ug2der(1,1,i-2)=0.0d0
2654           Ug2der(1,2,i-2)=0.0d0
2655           Ug2der(2,1,i-2)=0.0d0
2656           Ug2der(2,2,i-2)=0.0d0
2657         endif
2658 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2659         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2660           iti = itortyp(itype(i-2))
2661         else
2662           iti=ntortyp+1
2663         endif
2664 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2665         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2666           iti1 = itortyp(itype(i-1))
2667         else
2668           iti1=ntortyp+1
2669         endif
2670 cd        write (iout,*) '*******i',i,' iti1',iti
2671 cd        write (iout,*) 'b1',b1(:,iti)
2672 cd        write (iout,*) 'b2',b2(:,iti)
2673 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2674 c        if (i .gt. iatel_s+2) then
2675         if (i .gt. nnt+2) then
2676           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2677           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2678           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2679      &    then
2680           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2681           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2682           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2683           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2684           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2685           endif
2686         else
2687           do k=1,2
2688             Ub2(k,i-2)=0.0d0
2689             Ctobr(k,i-2)=0.0d0
2690             Dtobr2(k,i-2)=0.0d0
2691             do l=1,2
2692               EUg(l,k,i-2)=0.0d0
2693               CUg(l,k,i-2)=0.0d0
2694               DUg(l,k,i-2)=0.0d0
2695               DtUg2(l,k,i-2)=0.0d0
2696             enddo
2697           enddo
2698         endif
2699         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2700         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2701         do k=1,2
2702           muder(k,i-2)=Ub2der(k,i-2)
2703         enddo
2704 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2705         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2706           iti1 = itortyp(itype(i-1))
2707         else
2708           iti1=ntortyp+1
2709         endif
2710         do k=1,2
2711           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2712         enddo
2713 cd        write (iout,*) 'mu ',mu(:,i-2)
2714 cd        write (iout,*) 'mu1',mu1(:,i-2)
2715 cd        write (iout,*) 'mu2',mu2(:,i-2)
2716         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2717      &  then
2718         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2719         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2720         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2721         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2722         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2723 C Vectors and matrices dependent on a single virtual-bond dihedral.
2724         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2725         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2726         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2727         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2728         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2729         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2730         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2731         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2732         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2733         endif
2734       enddo
2735 C Matrices dependent on two consecutive virtual-bond dihedrals.
2736 C The order of matrices is from left to right.
2737       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2738      &then
2739 c      do i=max0(ivec_start,2),ivec_end
2740       do i=2,nres-1
2741         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2742         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2743         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2744         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2745         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2746         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2747         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2748         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2749       enddo
2750       endif
2751 #if defined(MPI) && defined(PARMAT)
2752 #ifdef DEBUG
2753 c      if (fg_rank.eq.0) then
2754         write (iout,*) "Arrays UG and UGDER before GATHER"
2755         do i=1,nres-1
2756           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2757      &     ((ug(l,k,i),l=1,2),k=1,2),
2758      &     ((ugder(l,k,i),l=1,2),k=1,2)
2759         enddo
2760         write (iout,*) "Arrays UG2 and UG2DER"
2761         do i=1,nres-1
2762           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2763      &     ((ug2(l,k,i),l=1,2),k=1,2),
2764      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2765         enddo
2766         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2767         do i=1,nres-1
2768           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2769      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2770      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2771         enddo
2772         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2773         do i=1,nres-1
2774           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2775      &     costab(i),sintab(i),costab2(i),sintab2(i)
2776         enddo
2777         write (iout,*) "Array MUDER"
2778         do i=1,nres-1
2779           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2780         enddo
2781 c      endif
2782 #endif
2783       if (nfgtasks.gt.1) then
2784         time00=MPI_Wtime()
2785 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2786 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2787 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2788 #ifdef MATGATHER
2789         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2790      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2791      &   FG_COMM1,IERR)
2792         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2793      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2794      &   FG_COMM1,IERR)
2795         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2796      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2797      &   FG_COMM1,IERR)
2798         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2799      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2800      &   FG_COMM1,IERR)
2801         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2802      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2803      &   FG_COMM1,IERR)
2804         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2805      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2806      &   FG_COMM1,IERR)
2807         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2808      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2809      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2810         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2811      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2812      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2813         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2814      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2815      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2816         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2817      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2818      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2819         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2820      &  then
2821         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2822      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2823      &   FG_COMM1,IERR)
2824         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2825      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2826      &   FG_COMM1,IERR)
2827         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2828      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2829      &   FG_COMM1,IERR)
2830        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2831      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2832      &   FG_COMM1,IERR)
2833         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2834      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2835      &   FG_COMM1,IERR)
2836         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2837      &   ivec_count(fg_rank1),
2838      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2839      &   FG_COMM1,IERR)
2840         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2841      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2842      &   FG_COMM1,IERR)
2843         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2844      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2845      &   FG_COMM1,IERR)
2846         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2847      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2848      &   FG_COMM1,IERR)
2849         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2850      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2851      &   FG_COMM1,IERR)
2852         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2853      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2854      &   FG_COMM1,IERR)
2855         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2856      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2857      &   FG_COMM1,IERR)
2858         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2859      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2860      &   FG_COMM1,IERR)
2861         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2862      &   ivec_count(fg_rank1),
2863      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2864      &   FG_COMM1,IERR)
2865         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2866      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2867      &   FG_COMM1,IERR)
2868        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2869      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2870      &   FG_COMM1,IERR)
2871         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2872      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2873      &   FG_COMM1,IERR)
2874        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2875      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2876      &   FG_COMM1,IERR)
2877         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2878      &   ivec_count(fg_rank1),
2879      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2880      &   FG_COMM1,IERR)
2881         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2882      &   ivec_count(fg_rank1),
2883      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2884      &   FG_COMM1,IERR)
2885         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2886      &   ivec_count(fg_rank1),
2887      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2888      &   MPI_MAT2,FG_COMM1,IERR)
2889         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2890      &   ivec_count(fg_rank1),
2891      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2892      &   MPI_MAT2,FG_COMM1,IERR)
2893         endif
2894 #else
2895 c Passes matrix info through the ring
2896       isend=fg_rank1
2897       irecv=fg_rank1-1
2898       if (irecv.lt.0) irecv=nfgtasks1-1
2899       iprev=irecv
2900       inext=fg_rank1+1
2901       if (inext.ge.nfgtasks1) inext=0
2902       do i=1,nfgtasks1-1
2903 c        write (iout,*) "isend",isend," irecv",irecv
2904 c        call flush(iout)
2905         lensend=lentyp(isend)
2906         lenrecv=lentyp(irecv)
2907 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2908 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2909 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2910 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2911 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2912 c        write (iout,*) "Gather ROTAT1"
2913 c        call flush(iout)
2914 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2915 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2916 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2917 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2918 c        write (iout,*) "Gather ROTAT2"
2919 c        call flush(iout)
2920         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2921      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2922      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2923      &   iprev,4400+irecv,FG_COMM,status,IERR)
2924 c        write (iout,*) "Gather ROTAT_OLD"
2925 c        call flush(iout)
2926         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2927      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2928      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2929      &   iprev,5500+irecv,FG_COMM,status,IERR)
2930 c        write (iout,*) "Gather PRECOMP11"
2931 c        call flush(iout)
2932         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2933      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2934      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2935      &   iprev,6600+irecv,FG_COMM,status,IERR)
2936 c        write (iout,*) "Gather PRECOMP12"
2937 c        call flush(iout)
2938         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2939      &  then
2940         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2941      &   MPI_ROTAT2(lensend),inext,7700+isend,
2942      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2943      &   iprev,7700+irecv,FG_COMM,status,IERR)
2944 c        write (iout,*) "Gather PRECOMP21"
2945 c        call flush(iout)
2946         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2947      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2948      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2949      &   iprev,8800+irecv,FG_COMM,status,IERR)
2950 c        write (iout,*) "Gather PRECOMP22"
2951 c        call flush(iout)
2952         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2953      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2954      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2955      &   MPI_PRECOMP23(lenrecv),
2956      &   iprev,9900+irecv,FG_COMM,status,IERR)
2957 c        write (iout,*) "Gather PRECOMP23"
2958 c        call flush(iout)
2959         endif
2960         isend=irecv
2961         irecv=irecv-1
2962         if (irecv.lt.0) irecv=nfgtasks1-1
2963       enddo
2964 #endif
2965         time_gather=time_gather+MPI_Wtime()-time00
2966       endif
2967 #ifdef DEBUG
2968 c      if (fg_rank.eq.0) then
2969         write (iout,*) "Arrays UG and UGDER"
2970         do i=1,nres-1
2971           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2972      &     ((ug(l,k,i),l=1,2),k=1,2),
2973      &     ((ugder(l,k,i),l=1,2),k=1,2)
2974         enddo
2975         write (iout,*) "Arrays UG2 and UG2DER"
2976         do i=1,nres-1
2977           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2978      &     ((ug2(l,k,i),l=1,2),k=1,2),
2979      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2980         enddo
2981         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2982         do i=1,nres-1
2983           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2984      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2985      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2986         enddo
2987         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2988         do i=1,nres-1
2989           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2990      &     costab(i),sintab(i),costab2(i),sintab2(i)
2991         enddo
2992         write (iout,*) "Array MUDER"
2993         do i=1,nres-1
2994           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2995         enddo
2996 c      endif
2997 #endif
2998 #endif
2999 cd      do i=1,nres
3000 cd        iti = itortyp(itype(i))
3001 cd        write (iout,*) i
3002 cd        do j=1,2
3003 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3004 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3005 cd        enddo
3006 cd      enddo
3007       return
3008       end
3009 C--------------------------------------------------------------------------
3010       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3011 C
3012 C This subroutine calculates the average interaction energy and its gradient
3013 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3014 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3015 C The potential depends both on the distance of peptide-group centers and on
3016 C the orientation of the CA-CA virtual bonds.
3017 C
3018       implicit real*8 (a-h,o-z)
3019 #ifdef MPI
3020       include 'mpif.h'
3021 #endif
3022       include 'DIMENSIONS'
3023       include 'COMMON.CONTROL'
3024       include 'COMMON.SETUP'
3025       include 'COMMON.IOUNITS'
3026       include 'COMMON.GEO'
3027       include 'COMMON.VAR'
3028       include 'COMMON.LOCAL'
3029       include 'COMMON.CHAIN'
3030       include 'COMMON.DERIV'
3031       include 'COMMON.INTERACT'
3032       include 'COMMON.CONTACTS'
3033       include 'COMMON.TORSION'
3034       include 'COMMON.VECTORS'
3035       include 'COMMON.FFIELD'
3036       include 'COMMON.TIME1'
3037       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3038      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3039       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3040      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3041       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3042      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3043      &    num_conti,j1,j2
3044 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3045 #ifdef MOMENT
3046       double precision scal_el /1.0d0/
3047 #else
3048       double precision scal_el /0.5d0/
3049 #endif
3050 C 12/13/98
3051 C 13-go grudnia roku pamietnego...
3052       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3053      &                   0.0d0,1.0d0,0.0d0,
3054      &                   0.0d0,0.0d0,1.0d0/
3055 cd      write(iout,*) 'In EELEC'
3056 cd      do i=1,nloctyp
3057 cd        write(iout,*) 'Type',i
3058 cd        write(iout,*) 'B1',B1(:,i)
3059 cd        write(iout,*) 'B2',B2(:,i)
3060 cd        write(iout,*) 'CC',CC(:,:,i)
3061 cd        write(iout,*) 'DD',DD(:,:,i)
3062 cd        write(iout,*) 'EE',EE(:,:,i)
3063 cd      enddo
3064 cd      call check_vecgrad
3065 cd      stop
3066       if (icheckgrad.eq.1) then
3067         do i=1,nres-1
3068           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3069           do k=1,3
3070             dc_norm(k,i)=dc(k,i)*fac
3071           enddo
3072 c          write (iout,*) 'i',i,' fac',fac
3073         enddo
3074       endif
3075       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3076      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3077      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3078 c        call vec_and_deriv
3079 #ifdef TIMING
3080         time01=MPI_Wtime()
3081 #endif
3082         call set_matrices
3083 #ifdef TIMING
3084         time_mat=time_mat+MPI_Wtime()-time01
3085 #endif
3086       endif
3087 cd      do i=1,nres-1
3088 cd        write (iout,*) 'i=',i
3089 cd        do k=1,3
3090 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3091 cd        enddo
3092 cd        do k=1,3
3093 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3094 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3095 cd        enddo
3096 cd      enddo
3097       t_eelecij=0.0d0
3098       ees=0.0D0
3099       evdw1=0.0D0
3100       eel_loc=0.0d0
3101       eello_turn3=0.0d0
3102       eello_turn4=0.0d0
3103       ind=0
3104       do i=1,nres
3105         num_cont_hb(i)=0
3106       enddo
3107 cd      print '(a)','Enter EELEC'
3108 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3109       do i=1,nres
3110         gel_loc_loc(i)=0.0d0
3111         gcorr_loc(i)=0.0d0
3112       enddo
3113 c
3114 c
3115 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3116 C
3117 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3118 C
3119       do i=iturn3_start,iturn3_end
3120         dxi=dc(1,i)
3121         dyi=dc(2,i)
3122         dzi=dc(3,i)
3123         dx_normi=dc_norm(1,i)
3124         dy_normi=dc_norm(2,i)
3125         dz_normi=dc_norm(3,i)
3126         xmedi=c(1,i)+0.5d0*dxi
3127         ymedi=c(2,i)+0.5d0*dyi
3128         zmedi=c(3,i)+0.5d0*dzi
3129         num_conti=0
3130         call eelecij(i,i+2,ees,evdw1,eel_loc)
3131         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3132         num_cont_hb(i)=num_conti
3133       enddo
3134       do i=iturn4_start,iturn4_end
3135         dxi=dc(1,i)
3136         dyi=dc(2,i)
3137         dzi=dc(3,i)
3138         dx_normi=dc_norm(1,i)
3139         dy_normi=dc_norm(2,i)
3140         dz_normi=dc_norm(3,i)
3141         xmedi=c(1,i)+0.5d0*dxi
3142         ymedi=c(2,i)+0.5d0*dyi
3143         zmedi=c(3,i)+0.5d0*dzi
3144         num_conti=num_cont_hb(i)
3145         call eelecij(i,i+3,ees,evdw1,eel_loc)
3146         if (wturn4.gt.0.0d0) call eturn4(i,eello_turn4)
3147         num_cont_hb(i)=num_conti
3148       enddo   ! i
3149 c
3150 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3151 c
3152       do i=iatel_s,iatel_e
3153         dxi=dc(1,i)
3154         dyi=dc(2,i)
3155         dzi=dc(3,i)
3156         dx_normi=dc_norm(1,i)
3157         dy_normi=dc_norm(2,i)
3158         dz_normi=dc_norm(3,i)
3159         xmedi=c(1,i)+0.5d0*dxi
3160         ymedi=c(2,i)+0.5d0*dyi
3161         zmedi=c(3,i)+0.5d0*dzi
3162 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3163         num_conti=num_cont_hb(i)
3164         do j=ielstart(i),ielend(i)
3165           call eelecij(i,j,ees,evdw1,eel_loc)
3166         enddo ! j
3167         num_cont_hb(i)=num_conti
3168       enddo   ! i
3169 c      write (iout,*) "Number of loop steps in EELEC:",ind
3170 cd      do i=1,nres
3171 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3172 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3173 cd      enddo
3174 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3175 ccc      eel_loc=eel_loc+eello_turn3
3176 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3177       return
3178       end
3179 C-------------------------------------------------------------------------------
3180       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3181       implicit real*8 (a-h,o-z)
3182       include 'DIMENSIONS'
3183 #ifdef MPI
3184       include "mpif.h"
3185 #endif
3186       include 'COMMON.CONTROL'
3187       include 'COMMON.IOUNITS'
3188       include 'COMMON.GEO'
3189       include 'COMMON.VAR'
3190       include 'COMMON.LOCAL'
3191       include 'COMMON.CHAIN'
3192       include 'COMMON.DERIV'
3193       include 'COMMON.INTERACT'
3194       include 'COMMON.CONTACTS'
3195       include 'COMMON.TORSION'
3196       include 'COMMON.VECTORS'
3197       include 'COMMON.FFIELD'
3198       include 'COMMON.TIME1'
3199       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3200      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3201       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3202      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3203       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3204      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3205      &    num_conti,j1,j2
3206 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3207 #ifdef MOMENT
3208       double precision scal_el /1.0d0/
3209 #else
3210       double precision scal_el /0.5d0/
3211 #endif
3212 C 12/13/98
3213 C 13-go grudnia roku pamietnego...
3214       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3215      &                   0.0d0,1.0d0,0.0d0,
3216      &                   0.0d0,0.0d0,1.0d0/
3217 c          time00=MPI_Wtime()
3218 cd      write (iout,*) "eelecij",i,j
3219 c          ind=ind+1
3220           iteli=itel(i)
3221           itelj=itel(j)
3222           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3223           aaa=app(iteli,itelj)
3224           bbb=bpp(iteli,itelj)
3225           ael6i=ael6(iteli,itelj)
3226           ael3i=ael3(iteli,itelj)
3227           dxj=dc(1,j)
3228           dyj=dc(2,j)
3229           dzj=dc(3,j)
3230           dx_normj=dc_norm(1,j)
3231           dy_normj=dc_norm(2,j)
3232           dz_normj=dc_norm(3,j)
3233           xj=c(1,j)+0.5D0*dxj-xmedi
3234           yj=c(2,j)+0.5D0*dyj-ymedi
3235           zj=c(3,j)+0.5D0*dzj-zmedi
3236           rij=xj*xj+yj*yj+zj*zj
3237           rrmij=1.0D0/rij
3238           rij=dsqrt(rij)
3239           rmij=1.0D0/rij
3240           r3ij=rrmij*rmij
3241           r6ij=r3ij*r3ij
3242           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3243           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3244           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3245           fac=cosa-3.0D0*cosb*cosg
3246           ev1=aaa*r6ij*r6ij
3247 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3248           if (j.eq.i+2) ev1=scal_el*ev1
3249           ev2=bbb*r6ij
3250           fac3=ael6i*r6ij
3251           fac4=ael3i*r3ij
3252           evdwij=ev1+ev2
3253           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3254           el2=fac4*fac
3255           eesij=el1+el2
3256 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3257           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3258           ees=ees+eesij
3259           evdw1=evdw1+evdwij
3260 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3261 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3262 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3263 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3264
3265           if (energy_dec) then
3266               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3267               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3268           endif
3269
3270 C
3271 C Calculate contributions to the Cartesian gradient.
3272 C
3273 #ifdef SPLITELE
3274           facvdw=-6*rrmij*(ev1+evdwij)
3275           facel=-3*rrmij*(el1+eesij)
3276           fac1=fac
3277           erij(1)=xj*rmij
3278           erij(2)=yj*rmij
3279           erij(3)=zj*rmij
3280 *
3281 * Radial derivatives. First process both termini of the fragment (i,j)
3282 *
3283           ggg(1)=facel*xj
3284           ggg(2)=facel*yj
3285           ggg(3)=facel*zj
3286 c          do k=1,3
3287 c            ghalf=0.5D0*ggg(k)
3288 c            gelc(k,i)=gelc(k,i)+ghalf
3289 c            gelc(k,j)=gelc(k,j)+ghalf
3290 c          enddo
3291 c 9/28/08 AL Gradient compotents will be summed only at the end
3292           do k=1,3
3293             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3294             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3295           enddo
3296 *
3297 * Loop over residues i+1 thru j-1.
3298 *
3299 cgrad          do k=i+1,j-1
3300 cgrad            do l=1,3
3301 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3302 cgrad            enddo
3303 cgrad          enddo
3304           ggg(1)=facvdw*xj
3305           ggg(2)=facvdw*yj
3306           ggg(3)=facvdw*zj
3307 c          do k=1,3
3308 c            ghalf=0.5D0*ggg(k)
3309 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3310 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3311 c          enddo
3312 c 9/28/08 AL Gradient compotents will be summed only at the end
3313           do k=1,3
3314             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3315             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3316           enddo
3317 *
3318 * Loop over residues i+1 thru j-1.
3319 *
3320 cgrad          do k=i+1,j-1
3321 cgrad            do l=1,3
3322 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3323 cgrad            enddo
3324 cgrad          enddo
3325 #else
3326           facvdw=ev1+evdwij
3327           facel=el1+eesij
3328           fac1=fac
3329           fac=-3*rrmij*(facvdw+facvdw+facel)
3330           erij(1)=xj*rmij
3331           erij(2)=yj*rmij
3332           erij(3)=zj*rmij
3333 *
3334 * Radial derivatives. First process both termini of the fragment (i,j)
3335 *
3336           ggg(1)=fac*xj
3337           ggg(2)=fac*yj
3338           ggg(3)=fac*zj
3339 c          do k=1,3
3340 c            ghalf=0.5D0*ggg(k)
3341 c            gelc(k,i)=gelc(k,i)+ghalf
3342 c            gelc(k,j)=gelc(k,j)+ghalf
3343 c          enddo
3344 c 9/28/08 AL Gradient compotents will be summed only at the end
3345           do k=1,3
3346             gelc_long(k,j)=gelc(k,j)+ggg(k)
3347             gelc_long(k,i)=gelc(k,i)-ggg(k)
3348           enddo
3349 *
3350 * Loop over residues i+1 thru j-1.
3351 *
3352 cgrad          do k=i+1,j-1
3353 cgrad            do l=1,3
3354 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3355 cgrad            enddo
3356 cgrad          enddo
3357 c 9/28/08 AL Gradient compotents will be summed only at the end
3358           ggg(1)=facvdw*xj
3359           ggg(2)=facvdw*yj
3360           ggg(3)=facvdw*zj
3361           do k=1,3
3362             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3363             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3364           enddo
3365 #endif
3366 *
3367 * Angular part
3368 *
3369           ecosa=2.0D0*fac3*fac1+fac4
3370           fac4=-3.0D0*fac4
3371           fac3=-6.0D0*fac3
3372           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3373           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3374           do k=1,3
3375             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3376             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3377           enddo
3378 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3379 cd   &          (dcosg(k),k=1,3)
3380           do k=1,3
3381             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3382           enddo
3383 c          do k=1,3
3384 c            ghalf=0.5D0*ggg(k)
3385 c            gelc(k,i)=gelc(k,i)+ghalf
3386 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3387 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3388 c            gelc(k,j)=gelc(k,j)+ghalf
3389 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3390 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3391 c          enddo
3392 cgrad          do k=i+1,j-1
3393 cgrad            do l=1,3
3394 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3395 cgrad            enddo
3396 cgrad          enddo
3397           do k=1,3
3398             gelc(k,i)=gelc(k,i)
3399      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3400      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3401             gelc(k,j)=gelc(k,j)
3402      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3403      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3404             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3405             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3406           enddo
3407           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3408      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3409      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3410 C
3411 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3412 C   energy of a peptide unit is assumed in the form of a second-order
3413 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3414 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3415 C   are computed for EVERY pair of non-contiguous peptide groups.
3416 C
3417           if (j.lt.nres-1) then
3418             j1=j+1
3419             j2=j-1
3420           else
3421             j1=j-1
3422             j2=j-2
3423           endif
3424           kkk=0
3425           do k=1,2
3426             do l=1,2
3427               kkk=kkk+1
3428               muij(kkk)=mu(k,i)*mu(l,j)
3429             enddo
3430           enddo
3431 cd         write (iout,*) 'EELEC: i',i,' j',j
3432 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3433 cd          write(iout,*) 'muij',muij
3434           ury=scalar(uy(1,i),erij)
3435           urz=scalar(uz(1,i),erij)
3436           vry=scalar(uy(1,j),erij)
3437           vrz=scalar(uz(1,j),erij)
3438           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3439           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3440           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3441           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3442           fac=dsqrt(-ael6i)*r3ij
3443           a22=a22*fac
3444           a23=a23*fac
3445           a32=a32*fac
3446           a33=a33*fac
3447 cd          write (iout,'(4i5,4f10.5)')
3448 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3449 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3450 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3451 cd     &      uy(:,j),uz(:,j)
3452 cd          write (iout,'(4f10.5)')
3453 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3454 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3455 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3456 cd           write (iout,'(9f10.5/)')
3457 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3458 C Derivatives of the elements of A in virtual-bond vectors
3459           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3460           do k=1,3
3461             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3462             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3463             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3464             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3465             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3466             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3467             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3468             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3469             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3470             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3471             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3472             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3473           enddo
3474 C Compute radial contributions to the gradient
3475           facr=-3.0d0*rrmij
3476           a22der=a22*facr
3477           a23der=a23*facr
3478           a32der=a32*facr
3479           a33der=a33*facr
3480           agg(1,1)=a22der*xj
3481           agg(2,1)=a22der*yj
3482           agg(3,1)=a22der*zj
3483           agg(1,2)=a23der*xj
3484           agg(2,2)=a23der*yj
3485           agg(3,2)=a23der*zj
3486           agg(1,3)=a32der*xj
3487           agg(2,3)=a32der*yj
3488           agg(3,3)=a32der*zj
3489           agg(1,4)=a33der*xj
3490           agg(2,4)=a33der*yj
3491           agg(3,4)=a33der*zj
3492 C Add the contributions coming from er
3493           fac3=-3.0d0*fac
3494           do k=1,3
3495             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3496             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3497             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3498             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3499           enddo
3500           do k=1,3
3501 C Derivatives in DC(i)
3502 cgrad            ghalf1=0.5d0*agg(k,1)
3503 cgrad            ghalf2=0.5d0*agg(k,2)
3504 cgrad            ghalf3=0.5d0*agg(k,3)
3505 cgrad            ghalf4=0.5d0*agg(k,4)
3506             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3507      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3508             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3509      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3510             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3511      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3512             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3513      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3514 C Derivatives in DC(i+1)
3515             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3516      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3517             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3518      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3519             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3520      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3521             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3522      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3523 C Derivatives in DC(j)
3524             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3525      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3526             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3527      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3528             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3529      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3530             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3531      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3532 C Derivatives in DC(j+1) or DC(nres-1)
3533             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3534      &      -3.0d0*vryg(k,3)*ury)
3535             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3536      &      -3.0d0*vrzg(k,3)*ury)
3537             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3538      &      -3.0d0*vryg(k,3)*urz)
3539             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3540      &      -3.0d0*vrzg(k,3)*urz)
3541 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3542 cgrad              do l=1,4
3543 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3544 cgrad              enddo
3545 cgrad            endif
3546           enddo
3547           acipa(1,1)=a22
3548           acipa(1,2)=a23
3549           acipa(2,1)=a32
3550           acipa(2,2)=a33
3551           a22=-a22
3552           a23=-a23
3553           do l=1,2
3554             do k=1,3
3555               agg(k,l)=-agg(k,l)
3556               aggi(k,l)=-aggi(k,l)
3557               aggi1(k,l)=-aggi1(k,l)
3558               aggj(k,l)=-aggj(k,l)
3559               aggj1(k,l)=-aggj1(k,l)
3560             enddo
3561           enddo
3562           if (j.lt.nres-1) then
3563             a22=-a22
3564             a32=-a32
3565             do l=1,3,2
3566               do k=1,3
3567                 agg(k,l)=-agg(k,l)
3568                 aggi(k,l)=-aggi(k,l)
3569                 aggi1(k,l)=-aggi1(k,l)
3570                 aggj(k,l)=-aggj(k,l)
3571                 aggj1(k,l)=-aggj1(k,l)
3572               enddo
3573             enddo
3574           else
3575             a22=-a22
3576             a23=-a23
3577             a32=-a32
3578             a33=-a33
3579             do l=1,4
3580               do k=1,3
3581                 agg(k,l)=-agg(k,l)
3582                 aggi(k,l)=-aggi(k,l)
3583                 aggi1(k,l)=-aggi1(k,l)
3584                 aggj(k,l)=-aggj(k,l)
3585                 aggj1(k,l)=-aggj1(k,l)
3586               enddo
3587             enddo
3588           endif
3589           ENDIF ! WCORR
3590           IF (wel_loc.gt.0.0d0) THEN
3591 C Contribution to the local-electrostatic energy coming from the i-j pair
3592           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3593      &     +a33*muij(4)
3594 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3595
3596           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3597      &            'eelloc',i,j,eel_loc_ij
3598
3599           eel_loc=eel_loc+eel_loc_ij
3600 C Partial derivatives in virtual-bond dihedral angles gamma
3601           if (i.gt.1)
3602      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3603      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3604      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3605           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3606      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3607      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3608 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3609           do l=1,3
3610             ggg(l)=agg(l,1)*muij(1)+
3611      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3612             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3613             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3614 cgrad            ghalf=0.5d0*ggg(l)
3615 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3616 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3617           enddo
3618 cgrad          do k=i+1,j2
3619 cgrad            do l=1,3
3620 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3621 cgrad            enddo
3622 cgrad          enddo
3623 C Remaining derivatives of eello
3624           do l=1,3
3625             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3626      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3627             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3628      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3629             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3630      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3631             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3632      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3633           enddo
3634           ENDIF
3635 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3636 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3637           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3638      &       .and. num_conti.le.maxconts) then
3639 c            write (iout,*) i,j," entered corr"
3640 C
3641 C Calculate the contact function. The ith column of the array JCONT will
3642 C contain the numbers of atoms that make contacts with the atom I (of numbers
3643 C greater than I). The arrays FACONT and GACONT will contain the values of
3644 C the contact function and its derivative.
3645 c           r0ij=1.02D0*rpp(iteli,itelj)
3646 c           r0ij=1.11D0*rpp(iteli,itelj)
3647             r0ij=2.20D0*rpp(iteli,itelj)
3648 c           r0ij=1.55D0*rpp(iteli,itelj)
3649             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3650             if (fcont.gt.0.0D0) then
3651               num_conti=num_conti+1
3652               if (num_conti.gt.maxconts) then
3653                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3654      &                         ' will skip next contacts for this conf.'
3655               else
3656                 jcont_hb(num_conti,i)=j
3657 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3658 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3659                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3660      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3661 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3662 C  terms.
3663                 d_cont(num_conti,i)=rij
3664 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3665 C     --- Electrostatic-interaction matrix ---
3666                 a_chuj(1,1,num_conti,i)=a22
3667                 a_chuj(1,2,num_conti,i)=a23
3668                 a_chuj(2,1,num_conti,i)=a32
3669                 a_chuj(2,2,num_conti,i)=a33
3670 C     --- Gradient of rij
3671                 do kkk=1,3
3672                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3673                 enddo
3674                 kkll=0
3675                 do k=1,2
3676                   do l=1,2
3677                     kkll=kkll+1
3678                     do m=1,3
3679                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3680                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3681                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3682                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3683                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3684                     enddo
3685                   enddo
3686                 enddo
3687                 ENDIF
3688                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3689 C Calculate contact energies
3690                 cosa4=4.0D0*cosa
3691                 wij=cosa-3.0D0*cosb*cosg
3692                 cosbg1=cosb+cosg
3693                 cosbg2=cosb-cosg
3694 c               fac3=dsqrt(-ael6i)/r0ij**3
3695                 fac3=dsqrt(-ael6i)*r3ij
3696 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3697                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3698                 if (ees0tmp.gt.0) then
3699                   ees0pij=dsqrt(ees0tmp)
3700                 else
3701                   ees0pij=0
3702                 endif
3703 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3704                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3705                 if (ees0tmp.gt.0) then
3706                   ees0mij=dsqrt(ees0tmp)
3707                 else
3708                   ees0mij=0
3709                 endif
3710 c               ees0mij=0.0D0
3711                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3712                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3713 C Diagnostics. Comment out or remove after debugging!
3714 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3715 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3716 c               ees0m(num_conti,i)=0.0D0
3717 C End diagnostics.
3718 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3719 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3720 C Angular derivatives of the contact function
3721                 ees0pij1=fac3/ees0pij
3722                 ees0mij1=fac3/ees0mij
3723                 fac3p=-3.0D0*fac3*rrmij
3724                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3725                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3726 c               ees0mij1=0.0D0
3727                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3728                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3729                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3730                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3731                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3732                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3733                 ecosap=ecosa1+ecosa2
3734                 ecosbp=ecosb1+ecosb2
3735                 ecosgp=ecosg1+ecosg2
3736                 ecosam=ecosa1-ecosa2
3737                 ecosbm=ecosb1-ecosb2
3738                 ecosgm=ecosg1-ecosg2
3739 C Diagnostics
3740 c               ecosap=ecosa1
3741 c               ecosbp=ecosb1
3742 c               ecosgp=ecosg1
3743 c               ecosam=0.0D0
3744 c               ecosbm=0.0D0
3745 c               ecosgm=0.0D0
3746 C End diagnostics
3747                 facont_hb(num_conti,i)=fcont
3748                 fprimcont=fprimcont/rij
3749 cd              facont_hb(num_conti,i)=1.0D0
3750 C Following line is for diagnostics.
3751 cd              fprimcont=0.0D0
3752                 do k=1,3
3753                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3754                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3755                 enddo
3756                 do k=1,3
3757                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3758                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3759                 enddo
3760                 gggp(1)=gggp(1)+ees0pijp*xj
3761                 gggp(2)=gggp(2)+ees0pijp*yj
3762                 gggp(3)=gggp(3)+ees0pijp*zj
3763                 gggm(1)=gggm(1)+ees0mijp*xj
3764                 gggm(2)=gggm(2)+ees0mijp*yj
3765                 gggm(3)=gggm(3)+ees0mijp*zj
3766 C Derivatives due to the contact function
3767                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3768                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3769                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3770                 do k=1,3
3771 c
3772 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3773 c          following the change of gradient-summation algorithm.
3774 c
3775 cgrad                  ghalfp=0.5D0*gggp(k)
3776 cgrad                  ghalfm=0.5D0*gggm(k)
3777                   gacontp_hb1(k,num_conti,i)=!ghalfp
3778      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3779      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3780                   gacontp_hb2(k,num_conti,i)=!ghalfp
3781      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3782      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3783                   gacontp_hb3(k,num_conti,i)=gggp(k)
3784                   gacontm_hb1(k,num_conti,i)=!ghalfm
3785      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3786      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3787                   gacontm_hb2(k,num_conti,i)=!ghalfm
3788      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3789      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3790                   gacontm_hb3(k,num_conti,i)=gggm(k)
3791                 enddo
3792 C Diagnostics. Comment out or remove after debugging!
3793 cdiag           do k=1,3
3794 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3795 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3796 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3797 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3798 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3799 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3800 cdiag           enddo
3801               ENDIF ! wcorr
3802               endif  ! num_conti.le.maxconts
3803             endif  ! fcont.gt.0
3804           endif    ! j.gt.i+1
3805           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3806             do k=1,4
3807               do l=1,3
3808                 ghalf=0.5d0*agg(l,k)
3809                 aggi(l,k)=aggi(l,k)+ghalf
3810                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3811                 aggj(l,k)=aggj(l,k)+ghalf
3812               enddo
3813             enddo
3814             if (j.eq.nres-1 .and. i.lt.j-2) then
3815               do k=1,4
3816                 do l=1,3
3817                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3818                 enddo
3819               enddo
3820             endif
3821           endif
3822 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3823       return
3824       end
3825 C-----------------------------------------------------------------------------
3826       subroutine eturn3(i,eello_turn3)
3827 C Third- and fourth-order contributions from turns
3828       implicit real*8 (a-h,o-z)
3829       include 'DIMENSIONS'
3830       include 'COMMON.IOUNITS'
3831       include 'COMMON.GEO'
3832       include 'COMMON.VAR'
3833       include 'COMMON.LOCAL'
3834       include 'COMMON.CHAIN'
3835       include 'COMMON.DERIV'
3836       include 'COMMON.INTERACT'
3837       include 'COMMON.CONTACTS'
3838       include 'COMMON.TORSION'
3839       include 'COMMON.VECTORS'
3840       include 'COMMON.FFIELD'
3841       include 'COMMON.CONTROL'
3842       dimension ggg(3)
3843       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3844      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3845      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3846       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3847      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3848       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3849      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3850      &    num_conti,j1,j2
3851       j=i+2
3852 c      write (iout,*) "eturn3",i,j,j1,j2
3853       a_temp(1,1)=a22
3854       a_temp(1,2)=a23
3855       a_temp(2,1)=a32
3856       a_temp(2,2)=a33
3857 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3858 C
3859 C               Third-order contributions
3860 C
3861 C                 (i+2)o----(i+3)
3862 C                      | |
3863 C                      | |
3864 C                 (i+1)o----i
3865 C
3866 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3867 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3868         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3869         call transpose2(auxmat(1,1),auxmat1(1,1))
3870         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3871         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3872         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3873      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3874 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3875 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3876 cd     &    ' eello_turn3_num',4*eello_turn3_num
3877 C Derivatives in gamma(i)
3878         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3879         call transpose2(auxmat2(1,1),auxmat3(1,1))
3880         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3881         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3882 C Derivatives in gamma(i+1)
3883         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3884         call transpose2(auxmat2(1,1),auxmat3(1,1))
3885         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3886         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3887      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3888 C Cartesian derivatives
3889         do l=1,3
3890 c            ghalf1=0.5d0*agg(l,1)
3891 c            ghalf2=0.5d0*agg(l,2)
3892 c            ghalf3=0.5d0*agg(l,3)
3893 c            ghalf4=0.5d0*agg(l,4)
3894           a_temp(1,1)=aggi(l,1)!+ghalf1
3895           a_temp(1,2)=aggi(l,2)!+ghalf2
3896           a_temp(2,1)=aggi(l,3)!+ghalf3
3897           a_temp(2,2)=aggi(l,4)!+ghalf4
3898           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3899           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3900      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3901           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3902           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3903           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3904           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3905           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3906           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3907      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3908           a_temp(1,1)=aggj(l,1)!+ghalf1
3909           a_temp(1,2)=aggj(l,2)!+ghalf2
3910           a_temp(2,1)=aggj(l,3)!+ghalf3
3911           a_temp(2,2)=aggj(l,4)!+ghalf4
3912           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3913           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3914      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3915           a_temp(1,1)=aggj1(l,1)
3916           a_temp(1,2)=aggj1(l,2)
3917           a_temp(2,1)=aggj1(l,3)
3918           a_temp(2,2)=aggj1(l,4)
3919           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3920           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3921      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3922         enddo
3923       return
3924       end
3925 C-------------------------------------------------------------------------------
3926       subroutine eturn4(i,eello_turn4)
3927 C Third- and fourth-order contributions from turns
3928       implicit real*8 (a-h,o-z)
3929       include 'DIMENSIONS'
3930       include 'COMMON.IOUNITS'
3931       include 'COMMON.GEO'
3932       include 'COMMON.VAR'
3933       include 'COMMON.LOCAL'
3934       include 'COMMON.CHAIN'
3935       include 'COMMON.DERIV'
3936       include 'COMMON.INTERACT'
3937       include 'COMMON.CONTACTS'
3938       include 'COMMON.TORSION'
3939       include 'COMMON.VECTORS'
3940       include 'COMMON.FFIELD'
3941       include 'COMMON.CONTROL'
3942       dimension ggg(3)
3943       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3944      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3945      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3946       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3947      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3948       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3949      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3950      &    num_conti,j1,j2
3951       j=i+3
3952 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3953 C
3954 C               Fourth-order contributions
3955 C
3956 C                 (i+3)o----(i+4)
3957 C                     /  |
3958 C               (i+2)o   |
3959 C                     \  |
3960 C                 (i+1)o----i
3961 C
3962 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3963 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3964 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3965         a_temp(1,1)=a22
3966         a_temp(1,2)=a23
3967         a_temp(2,1)=a32
3968         a_temp(2,2)=a33
3969         iti1=itortyp(itype(i+1))
3970         iti2=itortyp(itype(i+2))
3971         iti3=itortyp(itype(i+3))
3972 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3973         call transpose2(EUg(1,1,i+1),e1t(1,1))
3974         call transpose2(Eug(1,1,i+2),e2t(1,1))
3975         call transpose2(Eug(1,1,i+3),e3t(1,1))
3976         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3977         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3978         s1=scalar2(b1(1,iti2),auxvec(1))
3979         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3980         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3981         s2=scalar2(b1(1,iti1),auxvec(1))
3982         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3983         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3984         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3985         eello_turn4=eello_turn4-(s1+s2+s3)
3986         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3987      &      'eturn4',i,j,-(s1+s2+s3)
3988 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3989 cd     &    ' eello_turn4_num',8*eello_turn4_num
3990 C Derivatives in gamma(i)
3991         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3992         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3993         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3994         s1=scalar2(b1(1,iti2),auxvec(1))
3995         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3996         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3997         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3998 C Derivatives in gamma(i+1)
3999         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4000         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4001         s2=scalar2(b1(1,iti1),auxvec(1))
4002         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4003         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4004         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4005         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
4006 C Derivatives in gamma(i+2)
4007         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4008         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4009         s1=scalar2(b1(1,iti2),auxvec(1))
4010         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4011         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4012         s2=scalar2(b1(1,iti1),auxvec(1))
4013         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
4014         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
4015         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4016         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
4017 C Cartesian derivatives
4018 C Derivatives of this turn contributions in DC(i+2)
4019         if (j.lt.nres-1) then
4020           do l=1,3
4021             a_temp(1,1)=agg(l,1)
4022             a_temp(1,2)=agg(l,2)
4023             a_temp(2,1)=agg(l,3)
4024             a_temp(2,2)=agg(l,4)
4025             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4026             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4027             s1=scalar2(b1(1,iti2),auxvec(1))
4028             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4029             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4030             s2=scalar2(b1(1,iti1),auxvec(1))
4031             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4032             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4033             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4034             ggg(l)=-(s1+s2+s3)
4035             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
4036           enddo
4037         endif
4038 C Remaining derivatives of this turn contribution
4039         do l=1,3
4040           a_temp(1,1)=aggi(l,1)
4041           a_temp(1,2)=aggi(l,2)
4042           a_temp(2,1)=aggi(l,3)
4043           a_temp(2,2)=aggi(l,4)
4044           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4045           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4046           s1=scalar2(b1(1,iti2),auxvec(1))
4047           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4048           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4049           s2=scalar2(b1(1,iti1),auxvec(1))
4050           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4051           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4052           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4053           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
4054           a_temp(1,1)=aggi1(l,1)
4055           a_temp(1,2)=aggi1(l,2)
4056           a_temp(2,1)=aggi1(l,3)
4057           a_temp(2,2)=aggi1(l,4)
4058           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4059           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4060           s1=scalar2(b1(1,iti2),auxvec(1))
4061           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4062           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4063           s2=scalar2(b1(1,iti1),auxvec(1))
4064           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4065           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4066           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4067           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
4068           a_temp(1,1)=aggj(l,1)
4069           a_temp(1,2)=aggj(l,2)
4070           a_temp(2,1)=aggj(l,3)
4071           a_temp(2,2)=aggj(l,4)
4072           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4073           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4074           s1=scalar2(b1(1,iti2),auxvec(1))
4075           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4076           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4077           s2=scalar2(b1(1,iti1),auxvec(1))
4078           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4079           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4080           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4081           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
4082           a_temp(1,1)=aggj1(l,1)
4083           a_temp(1,2)=aggj1(l,2)
4084           a_temp(2,1)=aggj1(l,3)
4085           a_temp(2,2)=aggj1(l,4)
4086           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4087           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4088           s1=scalar2(b1(1,iti2),auxvec(1))
4089           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4090           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4091           s2=scalar2(b1(1,iti1),auxvec(1))
4092           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4093           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4094           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4095 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4096           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4097         enddo
4098       return
4099       end
4100 C-----------------------------------------------------------------------------
4101       subroutine vecpr(u,v,w)
4102       implicit real*8(a-h,o-z)
4103       dimension u(3),v(3),w(3)
4104       w(1)=u(2)*v(3)-u(3)*v(2)
4105       w(2)=-u(1)*v(3)+u(3)*v(1)
4106       w(3)=u(1)*v(2)-u(2)*v(1)
4107       return
4108       end
4109 C-----------------------------------------------------------------------------
4110       subroutine unormderiv(u,ugrad,unorm,ungrad)
4111 C This subroutine computes the derivatives of a normalized vector u, given
4112 C the derivatives computed without normalization conditions, ugrad. Returns
4113 C ungrad.
4114       implicit none
4115       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4116       double precision vec(3)
4117       double precision scalar
4118       integer i,j
4119 c      write (2,*) 'ugrad',ugrad
4120 c      write (2,*) 'u',u
4121       do i=1,3
4122         vec(i)=scalar(ugrad(1,i),u(1))
4123       enddo
4124 c      write (2,*) 'vec',vec
4125       do i=1,3
4126         do j=1,3
4127           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4128         enddo
4129       enddo
4130 c      write (2,*) 'ungrad',ungrad
4131       return
4132       end
4133 C-----------------------------------------------------------------------------
4134       subroutine escp_soft_sphere(evdw2,evdw2_14)
4135 C
4136 C This subroutine calculates the excluded-volume interaction energy between
4137 C peptide-group centers and side chains and its gradient in virtual-bond and
4138 C side-chain vectors.
4139 C
4140       implicit real*8 (a-h,o-z)
4141       include 'DIMENSIONS'
4142       include 'COMMON.GEO'
4143       include 'COMMON.VAR'
4144       include 'COMMON.LOCAL'
4145       include 'COMMON.CHAIN'
4146       include 'COMMON.DERIV'
4147       include 'COMMON.INTERACT'
4148       include 'COMMON.FFIELD'
4149       include 'COMMON.IOUNITS'
4150       include 'COMMON.CONTROL'
4151       dimension ggg(3)
4152       evdw2=0.0D0
4153       evdw2_14=0.0d0
4154       r0_scp=4.5d0
4155 cd    print '(a)','Enter ESCP'
4156 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4157       do i=iatscp_s,iatscp_e
4158         iteli=itel(i)
4159         xi=0.5D0*(c(1,i)+c(1,i+1))
4160         yi=0.5D0*(c(2,i)+c(2,i+1))
4161         zi=0.5D0*(c(3,i)+c(3,i+1))
4162
4163         do iint=1,nscp_gr(i)
4164
4165         do j=iscpstart(i,iint),iscpend(i,iint)
4166           itypj=itype(j)
4167 C Uncomment following three lines for SC-p interactions
4168 c         xj=c(1,nres+j)-xi
4169 c         yj=c(2,nres+j)-yi
4170 c         zj=c(3,nres+j)-zi
4171 C Uncomment following three lines for Ca-p interactions
4172           xj=c(1,j)-xi
4173           yj=c(2,j)-yi
4174           zj=c(3,j)-zi
4175           rij=xj*xj+yj*yj+zj*zj
4176           r0ij=r0_scp
4177           r0ijsq=r0ij*r0ij
4178           if (rij.lt.r0ijsq) then
4179             evdwij=0.25d0*(rij-r0ijsq)**2
4180             fac=rij-r0ijsq
4181           else
4182             evdwij=0.0d0
4183             fac=0.0d0
4184           endif
4185           evdw2=evdw2+evdwij
4186 C
4187 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4188 C
4189           ggg(1)=xj*fac
4190           ggg(2)=yj*fac
4191           ggg(3)=zj*fac
4192 cgrad          if (j.lt.i) then
4193 cd          write (iout,*) 'j<i'
4194 C Uncomment following three lines for SC-p interactions
4195 c           do k=1,3
4196 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4197 c           enddo
4198 cgrad          else
4199 cd          write (iout,*) 'j>i'
4200 cgrad            do k=1,3
4201 cgrad              ggg(k)=-ggg(k)
4202 C Uncomment following line for SC-p interactions
4203 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4204 cgrad            enddo
4205 cgrad          endif
4206 cgrad          do k=1,3
4207 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4208 cgrad          enddo
4209 cgrad          kstart=min0(i+1,j)
4210 cgrad          kend=max0(i-1,j-1)
4211 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4212 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4213 cgrad          do k=kstart,kend
4214 cgrad            do l=1,3
4215 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4216 cgrad            enddo
4217 cgrad          enddo
4218           do k=1,3
4219             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4220             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4221           enddo
4222         enddo
4223
4224         enddo ! iint
4225       enddo ! i
4226       return
4227       end
4228 C-----------------------------------------------------------------------------
4229       subroutine escp(evdw2,evdw2_14)
4230 C
4231 C This subroutine calculates the excluded-volume interaction energy between
4232 C peptide-group centers and side chains and its gradient in virtual-bond and
4233 C side-chain vectors.
4234 C
4235       implicit real*8 (a-h,o-z)
4236       include 'DIMENSIONS'
4237       include 'COMMON.GEO'
4238       include 'COMMON.VAR'
4239       include 'COMMON.LOCAL'
4240       include 'COMMON.CHAIN'
4241       include 'COMMON.DERIV'
4242       include 'COMMON.INTERACT'
4243       include 'COMMON.FFIELD'
4244       include 'COMMON.IOUNITS'
4245       include 'COMMON.CONTROL'
4246       dimension ggg(3)
4247       evdw2=0.0D0
4248       evdw2_14=0.0d0
4249 cd    print '(a)','Enter ESCP'
4250 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4251       do i=iatscp_s,iatscp_e
4252         iteli=itel(i)
4253         xi=0.5D0*(c(1,i)+c(1,i+1))
4254         yi=0.5D0*(c(2,i)+c(2,i+1))
4255         zi=0.5D0*(c(3,i)+c(3,i+1))
4256
4257         do iint=1,nscp_gr(i)
4258
4259         do j=iscpstart(i,iint),iscpend(i,iint)
4260           itypj=itype(j)
4261 C Uncomment following three lines for SC-p interactions
4262 c         xj=c(1,nres+j)-xi
4263 c         yj=c(2,nres+j)-yi
4264 c         zj=c(3,nres+j)-zi
4265 C Uncomment following three lines for Ca-p interactions
4266           xj=c(1,j)-xi
4267           yj=c(2,j)-yi
4268           zj=c(3,j)-zi
4269           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4270           fac=rrij**expon2
4271           e1=fac*fac*aad(itypj,iteli)
4272           e2=fac*bad(itypj,iteli)
4273           if (iabs(j-i) .le. 2) then
4274             e1=scal14*e1
4275             e2=scal14*e2
4276             evdw2_14=evdw2_14+e1+e2
4277           endif
4278           evdwij=e1+e2
4279           evdw2=evdw2+evdwij
4280           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4281      &        'evdw2',i,j,evdwij
4282 C
4283 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4284 C
4285           fac=-(evdwij+e1)*rrij
4286           ggg(1)=xj*fac
4287           ggg(2)=yj*fac
4288           ggg(3)=zj*fac
4289 cgrad          if (j.lt.i) then
4290 cd          write (iout,*) 'j<i'
4291 C Uncomment following three lines for SC-p interactions
4292 c           do k=1,3
4293 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4294 c           enddo
4295 cgrad          else
4296 cd          write (iout,*) 'j>i'
4297 cgrad            do k=1,3
4298 cgrad              ggg(k)=-ggg(k)
4299 C Uncomment following line for SC-p interactions
4300 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4301 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4302 cgrad            enddo
4303 cgrad          endif
4304 cgrad          do k=1,3
4305 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4306 cgrad          enddo
4307 cgrad          kstart=min0(i+1,j)
4308 cgrad          kend=max0(i-1,j-1)
4309 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4310 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4311 cgrad          do k=kstart,kend
4312 cgrad            do l=1,3
4313 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4314 cgrad            enddo
4315 cgrad          enddo
4316           do k=1,3
4317             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4318             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4319           enddo
4320         enddo
4321
4322         enddo ! iint
4323       enddo ! i
4324       do i=1,nct
4325         do j=1,3
4326           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4327           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4328           gradx_scp(j,i)=expon*gradx_scp(j,i)
4329         enddo
4330       enddo
4331 C******************************************************************************
4332 C
4333 C                              N O T E !!!
4334 C
4335 C To save time the factor EXPON has been extracted from ALL components
4336 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4337 C use!
4338 C
4339 C******************************************************************************
4340       return
4341       end
4342 C--------------------------------------------------------------------------
4343       subroutine edis(ehpb)
4344 C
4345 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4346 C
4347       implicit real*8 (a-h,o-z)
4348       include 'DIMENSIONS'
4349       include 'COMMON.SBRIDGE'
4350       include 'COMMON.CHAIN'
4351       include 'COMMON.DERIV'
4352       include 'COMMON.VAR'
4353       include 'COMMON.INTERACT'
4354       include 'COMMON.IOUNITS'
4355       dimension ggg(3)
4356       ehpb=0.0D0
4357 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4358 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4359       if (link_end.eq.0) return
4360       do i=link_start,link_end
4361 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4362 C CA-CA distance used in regularization of structure.
4363         ii=ihpb(i)
4364         jj=jhpb(i)
4365 C iii and jjj point to the residues for which the distance is assigned.
4366         if (ii.gt.nres) then
4367           iii=ii-nres
4368           jjj=jj-nres
4369         else
4370           iii=ii
4371           jjj=jj
4372         endif
4373 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4374 c     &    dhpb(i),dhpb1(i),forcon(i)
4375 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4376 C    distance and angle dependent SS bond potential.
4377 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4378 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4379         if (.not.dyn_ss .and. i.le.nss) then
4380 C 15/02/13 CC dynamic SSbond - additional check
4381          if (ii.gt.nres
4382      &       .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4383           call ssbond_ene(iii,jjj,eij)
4384           ehpb=ehpb+2*eij
4385          endif
4386 cd          write (iout,*) "eij",eij
4387         else if (ii.gt.nres .and. jj.gt.nres) then
4388 c Restraints from contact prediction
4389           dd=dist(ii,jj)
4390           if (dhpb1(i).gt.0.0d0) then
4391             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4392             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4393 c            write (iout,*) "beta nmr",
4394 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4395           else
4396             dd=dist(ii,jj)
4397             rdis=dd-dhpb(i)
4398 C Get the force constant corresponding to this distance.
4399             waga=forcon(i)
4400 C Calculate the contribution to energy.
4401             ehpb=ehpb+waga*rdis*rdis
4402 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
4403 C
4404 C Evaluate gradient.
4405 C
4406             fac=waga*rdis/dd
4407           endif
4408           do j=1,3
4409             ggg(j)=fac*(c(j,jj)-c(j,ii))
4410           enddo
4411           do j=1,3
4412             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4413             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4414           enddo
4415           do k=1,3
4416             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4417             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4418           enddo
4419         else
4420 C Calculate the distance between the two points and its difference from the
4421 C target distance.
4422           dd=dist(ii,jj)
4423           if (dhpb1(i).gt.0.0d0) then
4424             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4425             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4426 c            write (iout,*) "alph nmr",
4427 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4428           else
4429             rdis=dd-dhpb(i)
4430 C Get the force constant corresponding to this distance.
4431             waga=forcon(i)
4432 C Calculate the contribution to energy.
4433             ehpb=ehpb+waga*rdis*rdis
4434 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
4435 C
4436 C Evaluate gradient.
4437 C
4438             fac=waga*rdis/dd
4439           endif
4440 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4441 cd   &   ' waga=',waga,' fac=',fac
4442             do j=1,3
4443               ggg(j)=fac*(c(j,jj)-c(j,ii))
4444             enddo
4445 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4446 C If this is a SC-SC distance, we need to calculate the contributions to the
4447 C Cartesian gradient in the SC vectors (ghpbx).
4448           if (iii.lt.ii) then
4449           do j=1,3
4450             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4451             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4452           enddo
4453           endif
4454 cgrad        do j=iii,jjj-1
4455 cgrad          do k=1,3
4456 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4457 cgrad          enddo
4458 cgrad        enddo
4459           do k=1,3
4460             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4461             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4462           enddo
4463         endif
4464       enddo
4465       ehpb=0.5D0*ehpb
4466       return
4467       end
4468 C--------------------------------------------------------------------------
4469       subroutine ssbond_ene(i,j,eij)
4470 C
4471 C Calculate the distance and angle dependent SS-bond potential energy
4472 C using a free-energy function derived based on RHF/6-31G** ab initio
4473 C calculations of diethyl disulfide.
4474 C
4475 C A. Liwo and U. Kozlowska, 11/24/03
4476 C
4477       implicit real*8 (a-h,o-z)
4478       include 'DIMENSIONS'
4479       include 'COMMON.SBRIDGE'
4480       include 'COMMON.CHAIN'
4481       include 'COMMON.DERIV'
4482       include 'COMMON.LOCAL'
4483       include 'COMMON.INTERACT'
4484       include 'COMMON.VAR'
4485       include 'COMMON.IOUNITS'
4486       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4487       itypi=itype(i)
4488       xi=c(1,nres+i)
4489       yi=c(2,nres+i)
4490       zi=c(3,nres+i)
4491       dxi=dc_norm(1,nres+i)
4492       dyi=dc_norm(2,nres+i)
4493       dzi=dc_norm(3,nres+i)
4494 c      dsci_inv=dsc_inv(itypi)
4495       dsci_inv=vbld_inv(nres+i)
4496       itypj=itype(j)
4497 c      dscj_inv=dsc_inv(itypj)
4498       dscj_inv=vbld_inv(nres+j)
4499       xj=c(1,nres+j)-xi
4500       yj=c(2,nres+j)-yi
4501       zj=c(3,nres+j)-zi
4502       dxj=dc_norm(1,nres+j)
4503       dyj=dc_norm(2,nres+j)
4504       dzj=dc_norm(3,nres+j)
4505       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4506       rij=dsqrt(rrij)
4507       erij(1)=xj*rij
4508       erij(2)=yj*rij
4509       erij(3)=zj*rij
4510       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4511       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4512       om12=dxi*dxj+dyi*dyj+dzi*dzj
4513       do k=1,3
4514         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4515         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4516       enddo
4517       rij=1.0d0/rij
4518       deltad=rij-d0cm
4519       deltat1=1.0d0-om1
4520       deltat2=1.0d0+om2
4521       deltat12=om2-om1+2.0d0
4522       cosphi=om12-om1*om2
4523       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4524      &  +akct*deltad*deltat12+ebr
4525      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4526 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4527 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4528 c     &  " deltat12",deltat12," eij",eij
4529       ed=2*akcm*deltad+akct*deltat12
4530       pom1=akct*deltad
4531       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4532       eom1=-2*akth*deltat1-pom1-om2*pom2
4533       eom2= 2*akth*deltat2+pom1-om1*pom2
4534       eom12=pom2
4535       do k=1,3
4536         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4537         ghpbx(k,i)=ghpbx(k,i)-ggk
4538      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4539      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4540         ghpbx(k,j)=ghpbx(k,j)+ggk
4541      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4542      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4543         ghpbc(k,i)=ghpbc(k,i)-ggk
4544         ghpbc(k,j)=ghpbc(k,j)+ggk
4545       enddo
4546 C
4547 C Calculate the components of the gradient in DC and X
4548 C
4549 cgrad      do k=i,j-1
4550 cgrad        do l=1,3
4551 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4552 cgrad        enddo
4553 cgrad      enddo
4554       return
4555       end
4556 C--------------------------------------------------------------------------
4557       subroutine ebond(estr)
4558 c
4559 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4560 c
4561       implicit real*8 (a-h,o-z)
4562       include 'DIMENSIONS'
4563       include 'COMMON.LOCAL'
4564       include 'COMMON.GEO'
4565       include 'COMMON.INTERACT'
4566       include 'COMMON.DERIV'
4567       include 'COMMON.VAR'
4568       include 'COMMON.CHAIN'
4569       include 'COMMON.IOUNITS'
4570       include 'COMMON.NAMES'
4571       include 'COMMON.FFIELD'
4572       include 'COMMON.CONTROL'
4573       include 'COMMON.SETUP'
4574       double precision u(3),ud(3)
4575       estr=0.0d0
4576       do i=ibondp_start,ibondp_end
4577         diff = vbld(i)-vbldp0
4578 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4579         estr=estr+diff*diff
4580         do j=1,3
4581           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4582         enddo
4583 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4584       enddo
4585       estr=0.5d0*AKP*estr
4586 c
4587 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4588 c
4589       do i=ibond_start,ibond_end
4590         iti=itype(i)
4591         if (iti.ne.10) then
4592           nbi=nbondterm(iti)
4593           if (nbi.eq.1) then
4594             diff=vbld(i+nres)-vbldsc0(1,iti)
4595 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4596 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4597             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4598             do j=1,3
4599               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4600             enddo
4601           else
4602             do j=1,nbi
4603               diff=vbld(i+nres)-vbldsc0(j,iti)
4604               ud(j)=aksc(j,iti)*diff
4605               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4606             enddo
4607             uprod=u(1)
4608             do j=2,nbi
4609               uprod=uprod*u(j)
4610             enddo
4611             usum=0.0d0
4612             usumsqder=0.0d0
4613             do j=1,nbi
4614               uprod1=1.0d0
4615               uprod2=1.0d0
4616               do k=1,nbi
4617                 if (k.ne.j) then
4618                   uprod1=uprod1*u(k)
4619                   uprod2=uprod2*u(k)*u(k)
4620                 endif
4621               enddo
4622               usum=usum+uprod1
4623               usumsqder=usumsqder+ud(j)*uprod2
4624             enddo
4625             estr=estr+uprod/usum
4626             do j=1,3
4627              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4628             enddo
4629           endif
4630         endif
4631       enddo
4632       return
4633       end
4634 #ifdef CRYST_THETA
4635 C--------------------------------------------------------------------------
4636       subroutine ebend(etheta)
4637 C
4638 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4639 C angles gamma and its derivatives in consecutive thetas and gammas.
4640 C
4641       implicit real*8 (a-h,o-z)
4642       include 'DIMENSIONS'
4643       include 'COMMON.LOCAL'
4644       include 'COMMON.GEO'
4645       include 'COMMON.INTERACT'
4646       include 'COMMON.DERIV'
4647       include 'COMMON.VAR'
4648       include 'COMMON.CHAIN'
4649       include 'COMMON.IOUNITS'
4650       include 'COMMON.NAMES'
4651       include 'COMMON.FFIELD'
4652       include 'COMMON.CONTROL'
4653       common /calcthet/ term1,term2,termm,diffak,ratak,
4654      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4655      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4656       double precision y(2),z(2)
4657       delta=0.02d0*pi
4658 c      time11=dexp(-2*time)
4659 c      time12=1.0d0
4660       etheta=0.0D0
4661 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4662       do i=ithet_start,ithet_end
4663 C Zero the energy function and its derivative at 0 or pi.
4664         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4665         it=itype(i-1)
4666         if (i.gt.3) then
4667 #ifdef OSF
4668           phii=phi(i)
4669           if (phii.ne.phii) phii=150.0
4670 #else
4671           phii=phi(i)
4672 #endif
4673           y(1)=dcos(phii)
4674           y(2)=dsin(phii)
4675         else
4676           y(1)=0.0D0
4677           y(2)=0.0D0
4678         endif
4679         if (i.lt.nres) then
4680 #ifdef OSF
4681           phii1=phi(i+1)
4682           if (phii1.ne.phii1) phii1=150.0
4683           phii1=pinorm(phii1)
4684           z(1)=cos(phii1)
4685 #else
4686           phii1=phi(i+1)
4687           z(1)=dcos(phii1)
4688 #endif
4689           z(2)=dsin(phii1)
4690         else
4691           z(1)=0.0D0
4692           z(2)=0.0D0
4693         endif
4694 C Calculate the "mean" value of theta from the part of the distribution
4695 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4696 C In following comments this theta will be referred to as t_c.
4697         thet_pred_mean=0.0d0
4698         do k=1,2
4699           athetk=athet(k,it)
4700           bthetk=bthet(k,it)
4701           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4702         enddo
4703         dthett=thet_pred_mean*ssd
4704         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4705 C Derivatives of the "mean" values in gamma1 and gamma2.
4706         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
4707         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
4708         if (theta(i).gt.pi-delta) then
4709           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4710      &         E_tc0)
4711           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4712           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4713           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4714      &        E_theta)
4715           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4716      &        E_tc)
4717         else if (theta(i).lt.delta) then
4718           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4719           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4720           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4721      &        E_theta)
4722           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4723           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4724      &        E_tc)
4725         else
4726           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4727      &        E_theta,E_tc)
4728         endif
4729         etheta=etheta+ethetai
4730         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4731      &      'ebend',i,ethetai
4732         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4733         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4734         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
4735       enddo
4736 C Ufff.... We've done all this!!!
4737       return
4738       end
4739 C---------------------------------------------------------------------------
4740       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4741      &     E_tc)
4742       implicit real*8 (a-h,o-z)
4743       include 'DIMENSIONS'
4744       include 'COMMON.LOCAL'
4745       include 'COMMON.IOUNITS'
4746       common /calcthet/ term1,term2,termm,diffak,ratak,
4747      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4748      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4749 C Calculate the contributions to both Gaussian lobes.
4750 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4751 C The "polynomial part" of the "standard deviation" of this part of
4752 C the distribution.
4753         sig=polthet(3,it)
4754         do j=2,0,-1
4755           sig=sig*thet_pred_mean+polthet(j,it)
4756         enddo
4757 C Derivative of the "interior part" of the "standard deviation of the"
4758 C gamma-dependent Gaussian lobe in t_c.
4759         sigtc=3*polthet(3,it)
4760         do j=2,1,-1
4761           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4762         enddo
4763         sigtc=sig*sigtc
4764 C Set the parameters of both Gaussian lobes of the distribution.
4765 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4766         fac=sig*sig+sigc0(it)
4767         sigcsq=fac+fac
4768         sigc=1.0D0/sigcsq
4769 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4770         sigsqtc=-4.0D0*sigcsq*sigtc
4771 c       print *,i,sig,sigtc,sigsqtc
4772 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4773         sigtc=-sigtc/(fac*fac)
4774 C Following variable is sigma(t_c)**(-2)
4775         sigcsq=sigcsq*sigcsq
4776         sig0i=sig0(it)
4777         sig0inv=1.0D0/sig0i**2
4778         delthec=thetai-thet_pred_mean
4779         delthe0=thetai-theta0i
4780         term1=-0.5D0*sigcsq*delthec*delthec
4781         term2=-0.5D0*sig0inv*delthe0*delthe0
4782 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4783 C NaNs in taking the logarithm. We extract the largest exponent which is added
4784 C to the energy (this being the log of the distribution) at the end of energy
4785 C term evaluation for this virtual-bond angle.
4786         if (term1.gt.term2) then
4787           termm=term1
4788           term2=dexp(term2-termm)
4789           term1=1.0d0
4790         else
4791           termm=term2
4792           term1=dexp(term1-termm)
4793           term2=1.0d0
4794         endif
4795 C The ratio between the gamma-independent and gamma-dependent lobes of
4796 C the distribution is a Gaussian function of thet_pred_mean too.
4797         diffak=gthet(2,it)-thet_pred_mean
4798         ratak=diffak/gthet(3,it)**2
4799         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4800 C Let's differentiate it in thet_pred_mean NOW.
4801         aktc=ak*ratak
4802 C Now put together the distribution terms to make complete distribution.
4803         termexp=term1+ak*term2
4804         termpre=sigc+ak*sig0i
4805 C Contribution of the bending energy from this theta is just the -log of
4806 C the sum of the contributions from the two lobes and the pre-exponential
4807 C factor. Simple enough, isn't it?
4808         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4809 C NOW the derivatives!!!
4810 C 6/6/97 Take into account the deformation.
4811         E_theta=(delthec*sigcsq*term1
4812      &       +ak*delthe0*sig0inv*term2)/termexp
4813         E_tc=((sigtc+aktc*sig0i)/termpre
4814      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4815      &       aktc*term2)/termexp)
4816       return
4817       end
4818 c-----------------------------------------------------------------------------
4819       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4820       implicit real*8 (a-h,o-z)
4821       include 'DIMENSIONS'
4822       include 'COMMON.LOCAL'
4823       include 'COMMON.IOUNITS'
4824       common /calcthet/ term1,term2,termm,diffak,ratak,
4825      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4826      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4827       delthec=thetai-thet_pred_mean
4828       delthe0=thetai-theta0i
4829 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4830       t3 = thetai-thet_pred_mean
4831       t6 = t3**2
4832       t9 = term1
4833       t12 = t3*sigcsq
4834       t14 = t12+t6*sigsqtc
4835       t16 = 1.0d0
4836       t21 = thetai-theta0i
4837       t23 = t21**2
4838       t26 = term2
4839       t27 = t21*t26
4840       t32 = termexp
4841       t40 = t32**2
4842       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4843      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4844      & *(-t12*t9-ak*sig0inv*t27)
4845       return
4846       end
4847 #else
4848 C--------------------------------------------------------------------------
4849       subroutine ebend(etheta)
4850 C
4851 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4852 C angles gamma and its derivatives in consecutive thetas and gammas.
4853 C ab initio-derived potentials from
4854 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4855 C
4856       implicit real*8 (a-h,o-z)
4857       include 'DIMENSIONS'
4858       include 'COMMON.LOCAL'
4859       include 'COMMON.GEO'
4860       include 'COMMON.INTERACT'
4861       include 'COMMON.DERIV'
4862       include 'COMMON.VAR'
4863       include 'COMMON.CHAIN'
4864       include 'COMMON.IOUNITS'
4865       include 'COMMON.NAMES'
4866       include 'COMMON.FFIELD'
4867       include 'COMMON.CONTROL'
4868       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4869      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4870      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4871      & sinph1ph2(maxdouble,maxdouble)
4872       logical lprn /.false./, lprn1 /.false./
4873       etheta=0.0D0
4874 c      write (iout,*) "EBEND ithet_start",ithet_start,
4875 c     &     " ithet_end",ithet_end
4876       do i=ithet_start,ithet_end
4877         if ((itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
4878      &(itype(i).eq.ntyp1)) cycle
4879         dethetai=0.0d0
4880         dephii=0.0d0
4881         dephii1=0.0d0
4882         theti2=0.5d0*theta(i)
4883         ityp2=ithetyp(itype(i-1))
4884         do k=1,nntheterm
4885           coskt(k)=dcos(k*theti2)
4886           sinkt(k)=dsin(k*theti2)
4887         enddo
4888 C        if (i.gt.3) then
4889          if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4890 #ifdef OSF
4891           phii=phi(i)
4892           if (phii.ne.phii) phii=150.0
4893 #else
4894           phii=phi(i)
4895 #endif
4896           ityp1=ithetyp(itype(i-2))
4897           do k=1,nsingle
4898             cosph1(k)=dcos(k*phii)
4899             sinph1(k)=dsin(k*phii)
4900           enddo
4901         else
4902           phii=0.0d0
4903           ityp1=ithetyp(itype(i-2))
4904           do k=1,nsingle
4905             cosph1(k)=0.0d0
4906             sinph1(k)=0.0d0
4907           enddo
4908         endif
4909         if ((i.lt.nres).and. itype(i+1).ne.ntyp1) then
4910 #ifdef OSF
4911           phii1=phi(i+1)
4912           if (phii1.ne.phii1) phii1=150.0
4913           phii1=pinorm(phii1)
4914 #else
4915           phii1=phi(i+1)
4916 #endif
4917           ityp3=ithetyp(itype(i))
4918           do k=1,nsingle
4919             cosph2(k)=dcos(k*phii1)
4920             sinph2(k)=dsin(k*phii1)
4921           enddo
4922         else
4923           phii1=0.0d0
4924           ityp3=ithetyp(itype(i))
4925           do k=1,nsingle
4926             cosph2(k)=0.0d0
4927             sinph2(k)=0.0d0
4928           enddo
4929         endif
4930         ethetai=aa0thet(ityp1,ityp2,ityp3)
4931         do k=1,ndouble
4932           do l=1,k-1
4933             ccl=cosph1(l)*cosph2(k-l)
4934             ssl=sinph1(l)*sinph2(k-l)
4935             scl=sinph1(l)*cosph2(k-l)
4936             csl=cosph1(l)*sinph2(k-l)
4937             cosph1ph2(l,k)=ccl-ssl
4938             cosph1ph2(k,l)=ccl+ssl
4939             sinph1ph2(l,k)=scl+csl
4940             sinph1ph2(k,l)=scl-csl
4941           enddo
4942         enddo
4943         if (lprn) then
4944         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4945      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4946         write (iout,*) "coskt and sinkt"
4947         do k=1,nntheterm
4948           write (iout,*) k,coskt(k),sinkt(k)
4949         enddo
4950         endif
4951         do k=1,ntheterm
4952           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4953           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4954      &      *coskt(k)
4955           if (lprn)
4956      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4957      &     " ethetai",ethetai
4958         enddo
4959         if (lprn) then
4960         write (iout,*) "cosph and sinph"
4961         do k=1,nsingle
4962           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4963         enddo
4964         write (iout,*) "cosph1ph2 and sinph2ph2"
4965         do k=2,ndouble
4966           do l=1,k-1
4967             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4968      &         sinph1ph2(l,k),sinph1ph2(k,l)
4969           enddo
4970         enddo
4971         write(iout,*) "ethetai",ethetai
4972         endif
4973         do m=1,ntheterm2
4974           do k=1,nsingle
4975             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4976      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4977      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4978      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4979             ethetai=ethetai+sinkt(m)*aux
4980             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4981             dephii=dephii+k*sinkt(m)*(
4982      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4983      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4984             dephii1=dephii1+k*sinkt(m)*(
4985      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4986      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4987             if (lprn)
4988      &      write (iout,*) "m",m," k",k," bbthet",
4989      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4990      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4991      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4992      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4993           enddo
4994         enddo
4995         if (lprn)
4996      &  write(iout,*) "ethetai",ethetai
4997         do m=1,ntheterm3
4998           do k=2,ndouble
4999             do l=1,k-1
5000               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
5001      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
5002      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
5003      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
5004               ethetai=ethetai+sinkt(m)*aux
5005               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5006               dephii=dephii+l*sinkt(m)*(
5007      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
5008      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
5009      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
5010      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
5011               dephii1=dephii1+(k-l)*sinkt(m)*(
5012      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
5013      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
5014      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
5015      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
5016               if (lprn) then
5017               write (iout,*) "m",m," k",k," l",l," ffthet",
5018      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
5019      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
5020      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
5021      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
5022               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5023      &            cosph1ph2(k,l)*sinkt(m),
5024      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5025               endif
5026             enddo
5027           enddo
5028         enddo
5029 10      continue
5030 c        lprn1=.true.
5031         if (lprn1) write (iout,'(a4,i2,3f8.1,9h ethetai ,f10.5)')
5032      &  'ebe', i,theta(i)*rad2deg,phii*rad2deg,
5033      &   phii1*rad2deg,ethetai
5034 c        lprn1=.false.
5035         etheta=etheta+ethetai
5036         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5037         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5038         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
5039       enddo
5040       return
5041       end
5042 #endif
5043 #ifdef CRYST_SC
5044 c-----------------------------------------------------------------------------
5045       subroutine esc(escloc)
5046 C Calculate the local energy of a side chain and its derivatives in the
5047 C corresponding virtual-bond valence angles THETA and the spherical angles
5048 C ALPHA and OMEGA.
5049       implicit real*8 (a-h,o-z)
5050       include 'DIMENSIONS'
5051       include 'COMMON.GEO'
5052       include 'COMMON.LOCAL'
5053       include 'COMMON.VAR'
5054       include 'COMMON.INTERACT'
5055       include 'COMMON.DERIV'
5056       include 'COMMON.CHAIN'
5057       include 'COMMON.IOUNITS'
5058       include 'COMMON.NAMES'
5059       include 'COMMON.FFIELD'
5060       include 'COMMON.CONTROL'
5061       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5062      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5063       common /sccalc/ time11,time12,time112,theti,it,nlobit
5064       delta=0.02d0*pi
5065       escloc=0.0D0
5066 c     write (iout,'(a)') 'ESC'
5067       do i=loc_start,loc_end
5068         it=itype(i)
5069         if (it.eq.10) goto 1
5070         nlobit=nlob(it)
5071 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5072 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5073         theti=theta(i+1)-pipol
5074         x(1)=dtan(theti)
5075         x(2)=alph(i)
5076         x(3)=omeg(i)
5077
5078         if (x(2).gt.pi-delta) then
5079           xtemp(1)=x(1)
5080           xtemp(2)=pi-delta
5081           xtemp(3)=x(3)
5082           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5083           xtemp(2)=pi
5084           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5085           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5086      &        escloci,dersc(2))
5087           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5088      &        ddersc0(1),dersc(1))
5089           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5090      &        ddersc0(3),dersc(3))
5091           xtemp(2)=pi-delta
5092           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5093           xtemp(2)=pi
5094           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5095           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5096      &            dersc0(2),esclocbi,dersc02)
5097           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5098      &            dersc12,dersc01)
5099           call splinthet(x(2),0.5d0*delta,ss,ssd)
5100           dersc0(1)=dersc01
5101           dersc0(2)=dersc02
5102           dersc0(3)=0.0d0
5103           do k=1,3
5104             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5105           enddo
5106           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5107 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5108 c    &             esclocbi,ss,ssd
5109           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5110 c         escloci=esclocbi
5111 c         write (iout,*) escloci
5112         else if (x(2).lt.delta) then
5113           xtemp(1)=x(1)
5114           xtemp(2)=delta
5115           xtemp(3)=x(3)
5116           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5117           xtemp(2)=0.0d0
5118           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5119           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5120      &        escloci,dersc(2))
5121           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5122      &        ddersc0(1),dersc(1))
5123           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5124      &        ddersc0(3),dersc(3))
5125           xtemp(2)=delta
5126           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5127           xtemp(2)=0.0d0
5128           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5129           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5130      &            dersc0(2),esclocbi,dersc02)
5131           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5132      &            dersc12,dersc01)
5133           dersc0(1)=dersc01
5134           dersc0(2)=dersc02
5135           dersc0(3)=0.0d0
5136           call splinthet(x(2),0.5d0*delta,ss,ssd)
5137           do k=1,3
5138             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5139           enddo
5140           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5141 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5142 c    &             esclocbi,ss,ssd
5143           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5144 c         write (iout,*) escloci
5145         else
5146           call enesc(x,escloci,dersc,ddummy,.false.)
5147         endif
5148
5149         escloc=escloc+escloci
5150         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5151      &     'escloc',i,escloci
5152 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5153
5154         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5155      &   wscloc*dersc(1)
5156         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5157         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5158     1   continue
5159       enddo
5160       return
5161       end
5162 C---------------------------------------------------------------------------
5163       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5164       implicit real*8 (a-h,o-z)
5165       include 'DIMENSIONS'
5166       include 'COMMON.GEO'
5167       include 'COMMON.LOCAL'
5168       include 'COMMON.IOUNITS'
5169       common /sccalc/ time11,time12,time112,theti,it,nlobit
5170       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5171       double precision contr(maxlob,-1:1)
5172       logical mixed
5173 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5174         escloc_i=0.0D0
5175         do j=1,3
5176           dersc(j)=0.0D0
5177           if (mixed) ddersc(j)=0.0d0
5178         enddo
5179         x3=x(3)
5180
5181 C Because of periodicity of the dependence of the SC energy in omega we have
5182 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5183 C To avoid underflows, first compute & store the exponents.
5184
5185         do iii=-1,1
5186
5187           x(3)=x3+iii*dwapi
5188
5189           do j=1,nlobit
5190             do k=1,3
5191               z(k)=x(k)-censc(k,j,it)
5192             enddo
5193             do k=1,3
5194               Axk=0.0D0
5195               do l=1,3
5196                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5197               enddo
5198               Ax(k,j,iii)=Axk
5199             enddo
5200             expfac=0.0D0
5201             do k=1,3
5202               expfac=expfac+Ax(k,j,iii)*z(k)
5203             enddo
5204             contr(j,iii)=expfac
5205           enddo ! j
5206
5207         enddo ! iii
5208
5209         x(3)=x3
5210 C As in the case of ebend, we want to avoid underflows in exponentiation and
5211 C subsequent NaNs and INFs in energy calculation.
5212 C Find the largest exponent
5213         emin=contr(1,-1)
5214         do iii=-1,1
5215           do j=1,nlobit
5216             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5217           enddo
5218         enddo
5219         emin=0.5D0*emin
5220 cd      print *,'it=',it,' emin=',emin
5221
5222 C Compute the contribution to SC energy and derivatives
5223         do iii=-1,1
5224
5225           do j=1,nlobit
5226 #ifdef OSF
5227             adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin
5228             if(adexp.ne.adexp) adexp=1.0
5229             expfac=dexp(adexp)
5230 #else
5231             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
5232 #endif
5233 cd          print *,'j=',j,' expfac=',expfac
5234             escloc_i=escloc_i+expfac
5235             do k=1,3
5236               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5237             enddo
5238             if (mixed) then
5239               do k=1,3,2
5240                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5241      &            +gaussc(k,2,j,it))*expfac
5242               enddo
5243             endif
5244           enddo
5245
5246         enddo ! iii
5247
5248         dersc(1)=dersc(1)/cos(theti)**2
5249         ddersc(1)=ddersc(1)/cos(theti)**2
5250         ddersc(3)=ddersc(3)
5251
5252         escloci=-(dlog(escloc_i)-emin)
5253         do j=1,3
5254           dersc(j)=dersc(j)/escloc_i
5255         enddo
5256         if (mixed) then
5257           do j=1,3,2
5258             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5259           enddo
5260         endif
5261       return
5262       end
5263 C------------------------------------------------------------------------------
5264       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5265       implicit real*8 (a-h,o-z)
5266       include 'DIMENSIONS'
5267       include 'COMMON.GEO'
5268       include 'COMMON.LOCAL'
5269       include 'COMMON.IOUNITS'
5270       common /sccalc/ time11,time12,time112,theti,it,nlobit
5271       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5272       double precision contr(maxlob)
5273       logical mixed
5274
5275       escloc_i=0.0D0
5276
5277       do j=1,3
5278         dersc(j)=0.0D0
5279       enddo
5280
5281       do j=1,nlobit
5282         do k=1,2
5283           z(k)=x(k)-censc(k,j,it)
5284         enddo
5285         z(3)=dwapi
5286         do k=1,3
5287           Axk=0.0D0
5288           do l=1,3
5289             Axk=Axk+gaussc(l,k,j,it)*z(l)
5290           enddo
5291           Ax(k,j)=Axk
5292         enddo
5293         expfac=0.0D0
5294         do k=1,3
5295           expfac=expfac+Ax(k,j)*z(k)
5296         enddo
5297         contr(j)=expfac
5298       enddo ! j
5299
5300 C As in the case of ebend, we want to avoid underflows in exponentiation and
5301 C subsequent NaNs and INFs in energy calculation.
5302 C Find the largest exponent
5303       emin=contr(1)
5304       do j=1,nlobit
5305         if (emin.gt.contr(j)) emin=contr(j)
5306       enddo
5307       emin=0.5D0*emin
5308
5309 C Compute the contribution to SC energy and derivatives
5310
5311       dersc12=0.0d0
5312       do j=1,nlobit
5313         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
5314         escloc_i=escloc_i+expfac
5315         do k=1,2
5316           dersc(k)=dersc(k)+Ax(k,j)*expfac
5317         enddo
5318         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5319      &            +gaussc(1,2,j,it))*expfac
5320         dersc(3)=0.0d0
5321       enddo
5322
5323       dersc(1)=dersc(1)/cos(theti)**2
5324       dersc12=dersc12/cos(theti)**2
5325       escloci=-(dlog(escloc_i)-emin)
5326       do j=1,2
5327         dersc(j)=dersc(j)/escloc_i
5328       enddo
5329       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5330       return
5331       end
5332 #else
5333 c----------------------------------------------------------------------------------
5334       subroutine esc(escloc)
5335 C Calculate the local energy of a side chain and its derivatives in the
5336 C corresponding virtual-bond valence angles THETA and the spherical angles
5337 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5338 C added by Urszula Kozlowska. 07/11/2007
5339 C
5340       implicit real*8 (a-h,o-z)
5341       include 'DIMENSIONS'
5342       include 'COMMON.GEO'
5343       include 'COMMON.LOCAL'
5344       include 'COMMON.VAR'
5345       include 'COMMON.SCROT'
5346       include 'COMMON.INTERACT'
5347       include 'COMMON.DERIV'
5348       include 'COMMON.CHAIN'
5349       include 'COMMON.IOUNITS'
5350       include 'COMMON.NAMES'
5351       include 'COMMON.FFIELD'
5352       include 'COMMON.CONTROL'
5353       include 'COMMON.VECTORS'
5354       double precision x_prime(3),y_prime(3),z_prime(3)
5355      &    , sumene,dsc_i,dp2_i,x(65),
5356      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5357      &    de_dxx,de_dyy,de_dzz,de_dt
5358       double precision s1_t,s1_6_t,s2_t,s2_6_t
5359       double precision
5360      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5361      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5362      & dt_dCi(3),dt_dCi1(3)
5363       common /sccalc/ time11,time12,time112,theti,it,nlobit
5364       delta=0.02d0*pi
5365       escloc=0.0D0
5366 c      write(iout,*) "ESC: loc_start",loc_start," loc_end",loc_end
5367       do i=loc_start,loc_end
5368         costtab(i+1) =dcos(theta(i+1))
5369         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5370         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5371         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5372         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5373         cosfac=dsqrt(cosfac2)
5374         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5375         sinfac=dsqrt(sinfac2)
5376         it=itype(i)
5377         if (it.eq.10) goto 1
5378 c
5379 C  Compute the axes of tghe local cartesian coordinates system; store in
5380 c   x_prime, y_prime and z_prime
5381 c
5382         do j=1,3
5383           x_prime(j) = 0.00
5384           y_prime(j) = 0.00
5385           z_prime(j) = 0.00
5386         enddo
5387 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5388 C     &   dc_norm(3,i+nres)
5389         do j = 1,3
5390           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5391           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5392         enddo
5393         do j = 1,3
5394           z_prime(j) = -uz(j,i-1)
5395         enddo
5396 c       write (2,*) "i",i
5397 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5398 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5399 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5400 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5401 c      & " xy",scalar(x_prime(1),y_prime(1)),
5402 c      & " xz",scalar(x_prime(1),z_prime(1)),
5403 c      & " yy",scalar(y_prime(1),y_prime(1)),
5404 c      & " yz",scalar(y_prime(1),z_prime(1)),
5405 c      & " zz",scalar(z_prime(1),z_prime(1))
5406 c
5407 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5408 C to local coordinate system. Store in xx, yy, zz.
5409 c
5410         xx=0.0d0
5411         yy=0.0d0
5412         zz=0.0d0
5413         do j = 1,3
5414           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5415           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5416           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5417         enddo
5418
5419         xxtab(i)=xx
5420         yytab(i)=yy
5421         zztab(i)=zz
5422 C
5423 C Compute the energy of the ith side cbain
5424 C
5425 c        write (2,*) "xx",xx," yy",yy," zz",zz
5426         it=itype(i)
5427         do j = 1,65
5428           x(j) = sc_parmin(j,it)
5429         enddo
5430 #ifdef CHECK_COORD
5431 Cc diagnostics - remove later
5432         xx1 = dcos(alph(2))
5433         yy1 = dsin(alph(2))*dcos(omeg(2))
5434         zz1 = -dsin(alph(2))*dsin(omeg(2))
5435         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5436      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5437      &    xx1,yy1,zz1
5438 C,"  --- ", xx_w,yy_w,zz_w
5439 c end diagnostics
5440 #endif
5441         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5442      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5443      &   + x(10)*yy*zz
5444         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5445      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5446      & + x(20)*yy*zz
5447         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5448      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5449      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5450      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5451      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5452      &  +x(40)*xx*yy*zz
5453         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5454      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5455      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5456      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5457      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5458      &  +x(60)*xx*yy*zz
5459         dsc_i   = 0.743d0+x(61)
5460         dp2_i   = 1.9d0+x(62)
5461         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5462      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5463         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5464      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5465         s1=(1+x(63))/(0.1d0 + dscp1)
5466         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5467         s2=(1+x(65))/(0.1d0 + dscp2)
5468         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5469         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5470      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5471 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5472 c     &   sumene4,
5473 c     &   dscp1,dscp2,sumene
5474 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5475         escloc = escloc + sumene
5476 c        write (2,*) "i",i," escloc",sumene,escloc
5477 #ifdef DEBUG
5478 C
5479 C This section to check the numerical derivatives of the energy of ith side
5480 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5481 C #define DEBUG in the code to turn it on.
5482 C
5483         write (2,*) "sumene               =",sumene
5484         aincr=1.0d-7
5485         xxsave=xx
5486         xx=xx+aincr
5487         write (2,*) xx,yy,zz
5488         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5489         de_dxx_num=(sumenep-sumene)/aincr
5490         xx=xxsave
5491         write (2,*) "xx+ sumene from enesc=",sumenep
5492         yysave=yy
5493         yy=yy+aincr
5494         write (2,*) xx,yy,zz
5495         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5496         de_dyy_num=(sumenep-sumene)/aincr
5497         yy=yysave
5498         write (2,*) "yy+ sumene from enesc=",sumenep
5499         zzsave=zz
5500         zz=zz+aincr
5501         write (2,*) xx,yy,zz
5502         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5503         de_dzz_num=(sumenep-sumene)/aincr
5504         zz=zzsave
5505         write (2,*) "zz+ sumene from enesc=",sumenep
5506         costsave=cost2tab(i+1)
5507         sintsave=sint2tab(i+1)
5508         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5509         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5510         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5511         de_dt_num=(sumenep-sumene)/aincr
5512         write (2,*) " t+ sumene from enesc=",sumenep
5513         cost2tab(i+1)=costsave
5514         sint2tab(i+1)=sintsave
5515 C End of diagnostics section.
5516 #endif
5517 C
5518 C Compute the gradient of esc
5519 C
5520         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5521         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5522         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5523         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5524         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5525         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5526         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5527         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5528         pom1=(sumene3*sint2tab(i+1)+sumene1)
5529      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5530         pom2=(sumene4*cost2tab(i+1)+sumene2)
5531      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5532         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5533         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5534      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5535      &  +x(40)*yy*zz
5536         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5537         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5538      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5539      &  +x(60)*yy*zz
5540         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5541      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5542      &        +(pom1+pom2)*pom_dx
5543 #ifdef DEBUG
5544         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5545 #endif
5546 C
5547         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5548         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5549      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5550      &  +x(40)*xx*zz
5551         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5552         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5553      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5554      &  +x(59)*zz**2 +x(60)*xx*zz
5555         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5556      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5557      &        +(pom1-pom2)*pom_dy
5558 #ifdef DEBUG
5559         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5560 #endif
5561 C
5562         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5563      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5564      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5565      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5566      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5567      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5568      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5569      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5570 #ifdef DEBUG
5571         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5572 #endif
5573 C
5574         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5575      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5576      &  +pom1*pom_dt1+pom2*pom_dt2
5577 #ifdef DEBUG
5578         write(2,*), "de_dt = ", de_dt,de_dt_num
5579 #endif
5580 c
5581 C
5582        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5583        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5584        cosfac2xx=cosfac2*xx
5585        sinfac2yy=sinfac2*yy
5586        do k = 1,3
5587          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5588      &      vbld_inv(i+1)
5589          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5590      &      vbld_inv(i)
5591          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5592          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5593 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5594 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5595 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5596 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5597          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5598          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5599          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5600          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5601          dZZ_Ci1(k)=0.0d0
5602          dZZ_Ci(k)=0.0d0
5603          do j=1,3
5604            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5605            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5606          enddo
5607
5608          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5609          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5610          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5611 c
5612          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5613          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5614        enddo
5615
5616        do k=1,3
5617          dXX_Ctab(k,i)=dXX_Ci(k)
5618          dXX_C1tab(k,i)=dXX_Ci1(k)
5619          dYY_Ctab(k,i)=dYY_Ci(k)
5620          dYY_C1tab(k,i)=dYY_Ci1(k)
5621          dZZ_Ctab(k,i)=dZZ_Ci(k)
5622          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5623          dXX_XYZtab(k,i)=dXX_XYZ(k)
5624          dYY_XYZtab(k,i)=dYY_XYZ(k)
5625          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5626        enddo
5627
5628        do k = 1,3
5629 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5630 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5631 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5632 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5633 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5634 c     &    dt_dci(k)
5635 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5636 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5637          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5638      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5639          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5640      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5641          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5642      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5643        enddo
5644 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5645 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5646
5647 C to check gradient call subroutine check_grad
5648
5649     1 continue
5650       enddo
5651       return
5652       end
5653 c------------------------------------------------------------------------------
5654       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5655       implicit none
5656       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5657      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5658       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5659      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5660      &   + x(10)*yy*zz
5661       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5662      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5663      & + x(20)*yy*zz
5664       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5665      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5666      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5667      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5668      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5669      &  +x(40)*xx*yy*zz
5670       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5671      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5672      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5673      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5674      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5675      &  +x(60)*xx*yy*zz
5676       dsc_i   = 0.743d0+x(61)
5677       dp2_i   = 1.9d0+x(62)
5678       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5679      &          *(xx*cost2+yy*sint2))
5680       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5681      &          *(xx*cost2-yy*sint2))
5682       s1=(1+x(63))/(0.1d0 + dscp1)
5683       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5684       s2=(1+x(65))/(0.1d0 + dscp2)
5685       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5686       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5687      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5688       enesc=sumene
5689       return
5690       end
5691 #endif
5692 c------------------------------------------------------------------------------
5693       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5694 C
5695 C This procedure calculates two-body contact function g(rij) and its derivative:
5696 C
5697 C           eps0ij                                     !       x < -1
5698 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5699 C            0                                         !       x > 1
5700 C
5701 C where x=(rij-r0ij)/delta
5702 C
5703 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5704 C
5705       implicit none
5706       double precision rij,r0ij,eps0ij,fcont,fprimcont
5707       double precision x,x2,x4,delta
5708 c     delta=0.02D0*r0ij
5709 c      delta=0.2D0*r0ij
5710       x=(rij-r0ij)/delta
5711       if (x.lt.-1.0D0) then
5712         fcont=eps0ij
5713         fprimcont=0.0D0
5714       else if (x.le.1.0D0) then
5715         x2=x*x
5716         x4=x2*x2
5717         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5718         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5719       else
5720         fcont=0.0D0
5721         fprimcont=0.0D0
5722       endif
5723       return
5724       end
5725 c------------------------------------------------------------------------------
5726       subroutine splinthet(theti,delta,ss,ssder)
5727       implicit real*8 (a-h,o-z)
5728       include 'DIMENSIONS'
5729       include 'COMMON.VAR'
5730       include 'COMMON.GEO'
5731       thetup=pi-delta
5732       thetlow=delta
5733       if (theti.gt.pipol) then
5734         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5735       else
5736         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5737         ssder=-ssder
5738       endif
5739       return
5740       end
5741 c------------------------------------------------------------------------------
5742       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5743       implicit none
5744       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5745       double precision ksi,ksi2,ksi3,a1,a2,a3
5746       a1=fprim0*delta/(f1-f0)
5747       a2=3.0d0-2.0d0*a1
5748       a3=a1-2.0d0
5749       ksi=(x-x0)/delta
5750       ksi2=ksi*ksi
5751       ksi3=ksi2*ksi
5752       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5753       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5754       return
5755       end
5756 c------------------------------------------------------------------------------
5757       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5758       implicit none
5759       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5760       double precision ksi,ksi2,ksi3,a1,a2,a3
5761       ksi=(x-x0)/delta
5762       ksi2=ksi*ksi
5763       ksi3=ksi2*ksi
5764       a1=fprim0x*delta
5765       a2=3*(f1x-f0x)-2*fprim0x*delta
5766       a3=fprim0x*delta-2*(f1x-f0x)
5767       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5768       return
5769       end
5770 C-----------------------------------------------------------------------------
5771 #ifdef CRYST_TOR
5772 C-----------------------------------------------------------------------------
5773       subroutine etor(etors,edihcnstr)
5774       implicit real*8 (a-h,o-z)
5775       include 'DIMENSIONS'
5776       include 'COMMON.VAR'
5777       include 'COMMON.GEO'
5778       include 'COMMON.LOCAL'
5779       include 'COMMON.TORSION'
5780       include 'COMMON.INTERACT'
5781       include 'COMMON.DERIV'
5782       include 'COMMON.CHAIN'
5783       include 'COMMON.NAMES'
5784       include 'COMMON.IOUNITS'
5785       include 'COMMON.FFIELD'
5786       include 'COMMON.TORCNSTR'
5787       include 'COMMON.CONTROL'
5788       logical lprn
5789 C Set lprn=.true. for debugging
5790       lprn=.false.
5791 c      lprn=.true.
5792       etors=0.0D0
5793       do i=iphi_start,iphi_end
5794       etors_ii=0.0D0
5795         itori=itortyp(itype(i-2))
5796         itori1=itortyp(itype(i-1))
5797         phii=phi(i)
5798         gloci=0.0D0
5799 C Proline-Proline pair is a special case...
5800         if (itori.eq.3 .and. itori1.eq.3) then
5801           if (phii.gt.-dwapi3) then
5802             cosphi=dcos(3*phii)
5803             fac=1.0D0/(1.0D0-cosphi)
5804             etorsi=v1(1,3,3)*fac
5805             etorsi=etorsi+etorsi
5806             etors=etors+etorsi-v1(1,3,3)
5807             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5808             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5809           endif
5810           do j=1,3
5811             v1ij=v1(j+1,itori,itori1)
5812             v2ij=v2(j+1,itori,itori1)
5813             cosphi=dcos(j*phii)
5814             sinphi=dsin(j*phii)
5815             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5816             if (energy_dec) etors_ii=etors_ii+
5817      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5818             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5819           enddo
5820         else
5821           do j=1,nterm_old
5822             v1ij=v1(j,itori,itori1)
5823             v2ij=v2(j,itori,itori1)
5824             cosphi=dcos(j*phii)
5825             sinphi=dsin(j*phii)
5826             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5827             if (energy_dec) etors_ii=etors_ii+
5828      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5829             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5830           enddo
5831         endif
5832         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5833      &        'etor',i,etors_ii
5834         if (lprn)
5835      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5836      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5837      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5838         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5839         write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5840       enddo
5841 ! 6/20/98 - dihedral angle constraints
5842       edihcnstr=0.0d0
5843       do i=1,ndih_constr
5844         itori=idih_constr(i)
5845         phii=phi(itori)
5846         difi=phii-phi0(i)
5847         if (difi.gt.drange(i)) then
5848           difi=difi-drange(i)
5849           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5850           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5851         else if (difi.lt.-drange(i)) then
5852           difi=difi+drange(i)
5853           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5854           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5855         endif
5856 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5857 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5858       enddo
5859 !      write (iout,*) 'edihcnstr',edihcnstr
5860       return
5861       end
5862 c------------------------------------------------------------------------------
5863 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
5864       subroutine e_modeller(ehomology_constr)
5865       ehomology_constr=0.0d0
5866       write (iout,*) "!!!!!UWAGA, JESTEM W DZIWNEJ PETLI, TEST!!!!!"
5867       return
5868       end
5869 C !!!!!!!! NIE CZYTANE !!!!!!!!!!!
5870
5871 c------------------------------------------------------------------------------
5872       subroutine etor_d(etors_d)
5873       etors_d=0.0d0
5874       return
5875       end
5876 c----------------------------------------------------------------------------
5877 #else
5878       subroutine etor(etors,edihcnstr)
5879       implicit real*8 (a-h,o-z)
5880       include 'DIMENSIONS'
5881       include 'COMMON.VAR'
5882       include 'COMMON.GEO'
5883       include 'COMMON.LOCAL'
5884       include 'COMMON.TORSION'
5885       include 'COMMON.INTERACT'
5886       include 'COMMON.DERIV'
5887       include 'COMMON.CHAIN'
5888       include 'COMMON.NAMES'
5889       include 'COMMON.IOUNITS'
5890       include 'COMMON.FFIELD'
5891       include 'COMMON.TORCNSTR'
5892       include 'COMMON.CONTROL'
5893       logical lprn
5894 C Set lprn=.true. for debugging
5895       lprn=.false.
5896 c     lprn=.true.
5897       etors=0.0D0
5898       do i=iphi_start,iphi_end
5899       etors_ii=0.0D0
5900         itori=itortyp(itype(i-2))
5901         itori1=itortyp(itype(i-1))
5902         phii=phi(i)
5903         gloci=0.0D0
5904 C Regular cosine and sine terms
5905         do j=1,nterm(itori,itori1)
5906           v1ij=v1(j,itori,itori1)
5907           v2ij=v2(j,itori,itori1)
5908           cosphi=dcos(j*phii)
5909           sinphi=dsin(j*phii)
5910           etors=etors+v1ij*cosphi+v2ij*sinphi
5911           if (energy_dec) etors_ii=etors_ii+
5912      &                v1ij*cosphi+v2ij*sinphi
5913           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5914         enddo
5915 C Lorentz terms
5916 C                         v1
5917 C  E = SUM ----------------------------------- - v1
5918 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5919 C
5920         cosphi=dcos(0.5d0*phii)
5921         sinphi=dsin(0.5d0*phii)
5922         do j=1,nlor(itori,itori1)
5923           vl1ij=vlor1(j,itori,itori1)
5924           vl2ij=vlor2(j,itori,itori1)
5925           vl3ij=vlor3(j,itori,itori1)
5926           pom=vl2ij*cosphi+vl3ij*sinphi
5927           pom1=1.0d0/(pom*pom+1.0d0)
5928           etors=etors+vl1ij*pom1
5929           if (energy_dec) etors_ii=etors_ii+
5930      &                vl1ij*pom1
5931           pom=-pom*pom1*pom1
5932           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5933         enddo
5934 C Subtract the constant term
5935         etors=etors-v0(itori,itori1)
5936           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5937      &         'etor',i,etors_ii-v0(itori,itori1)
5938         if (lprn)
5939      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5940      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5941      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5942         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5943 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5944       enddo
5945 ! 6/20/98 - dihedral angle constraints
5946       edihcnstr=0.0d0
5947 c      do i=1,ndih_constr
5948       do i=idihconstr_start,idihconstr_end
5949         itori=idih_constr(i)
5950         phii=phi(itori)
5951         difi=pinorm(phii-phi0(i))
5952         if (difi.gt.drange(i)) then
5953           difi=difi-drange(i)
5954           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5955           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5956         else if (difi.lt.-drange(i)) then
5957           difi=difi+drange(i)
5958           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5959           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5960         else
5961           difi=0.0
5962         endif
5963 c        write (iout,*) "gloci", gloc(i-3,icg)
5964 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5965 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5966 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5967       enddo
5968 cd       write (iout,*) 'edihcnstr',edihcnstr
5969       return
5970       end
5971 c----------------------------------------------------------------------------
5972 c MODELLER restraint function
5973       subroutine e_modeller(ehomology_constr)
5974       implicit real*8 (a-h,o-z)
5975       include 'DIMENSIONS'
5976
5977       integer nnn, i, j, k, ki, irec, l
5978       integer katy, odleglosci, test7
5979       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
5980       real*8 Eval,Erot
5981       real*8 distance(max_template),distancek(max_template),
5982      &    min_odl,godl(max_template),dih_diff(max_template)
5983
5984 c
5985 c     FP - 30/10/2014 Temporary specifications for homology restraints
5986 c
5987       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
5988      &                 sgtheta
5989       double precision, dimension (maxres) :: guscdiff,usc_diff
5990       double precision, dimension (max_template) ::
5991      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
5992      &           theta_diff
5993 c
5994
5995       include 'COMMON.SBRIDGE'
5996       include 'COMMON.CHAIN'
5997       include 'COMMON.GEO'
5998       include 'COMMON.DERIV'
5999       include 'COMMON.LOCAL'
6000       include 'COMMON.INTERACT'
6001       include 'COMMON.VAR'
6002       include 'COMMON.IOUNITS'
6003       include 'COMMON.MD'
6004       include 'COMMON.CONTROL'
6005 c
6006 c     From subroutine Econstr_back
6007 c
6008       include 'COMMON.NAMES'
6009       include 'COMMON.TIME1'
6010 c
6011
6012
6013       do i=1,19
6014         distancek(i)=9999999.9
6015       enddo
6016
6017
6018       odleg=0.0d0
6019
6020 c Pseudo-energy and gradient from homology restraints (MODELLER-like
6021 c function)
6022 C AL 5/2/14 - Introduce list of restraints
6023 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
6024 #ifdef DEBUG
6025       write(iout,*) "------- dist restrs start -------"
6026 #endif
6027       do ii = link_start_homo,link_end_homo
6028          i = ires_homo(ii)
6029          j = jres_homo(ii)
6030          dij=dist(i,j)
6031 c        write (iout,*) "dij(",i,j,") =",dij
6032          do k=1,constr_homology
6033            distance(k)=odl(k,ii)-dij
6034 c          write (iout,*) "distance(",k,") =",distance(k)
6035 c
6036 c          For Gaussian-type Urestr
6037 c
6038            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
6039 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
6040 c          write (iout,*) "distancek(",k,") =",distancek(k)
6041 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
6042 c
6043 c          For Lorentzian-type Urestr
6044 c
6045            if (waga_dist.lt.0.0d0) then
6046               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
6047               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
6048      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
6049            endif
6050          enddo
6051
6052          min_odl=minval(distancek)
6053 c        write (iout,* )"min_odl",min_odl
6054 #ifdef DEBUG
6055          write (iout,*) "ij dij",i,j,dij
6056          write (iout,*) "distance",(distance(k),k=1,constr_homology)
6057          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
6058          write (iout,* )"min_odl",min_odl
6059 #endif
6060          odleg2=0.0d0
6061          do k=1,constr_homology
6062 c Nie wiem po co to liczycie jeszcze raz!
6063 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
6064 c     &              (2*(sigma_odl(i,j,k))**2))
6065            if (waga_dist.ge.0.0d0) then
6066 c
6067 c          For Gaussian-type Urestr
6068 c
6069             godl(k)=dexp(-distancek(k)+min_odl)
6070             odleg2=odleg2+godl(k)
6071 c
6072 c          For Lorentzian-type Urestr
6073 c
6074            else
6075             odleg2=odleg2+distancek(k)
6076            endif
6077
6078 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
6079 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
6080 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
6081 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
6082
6083          enddo
6084 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
6085 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
6086 #ifdef DEBUG
6087          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
6088          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
6089 #endif
6090            if (waga_dist.ge.0.0d0) then
6091 c
6092 c          For Gaussian-type Urestr
6093 c
6094               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
6095 c
6096 c          For Lorentzian-type Urestr
6097 c
6098            else
6099               odleg=odleg+odleg2/constr_homology
6100            endif
6101 c
6102 c        write (iout,*) "odleg",odleg ! sum of -ln-s
6103 c Gradient
6104 c
6105 c          For Gaussian-type Urestr
6106 c
6107          if (waga_dist.ge.0.0d0) sum_godl=odleg2
6108          sum_sgodl=0.0d0
6109          do k=1,constr_homology
6110 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
6111 c     &           *waga_dist)+min_odl
6112 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
6113 c
6114          if (waga_dist.ge.0.0d0) then
6115 c          For Gaussian-type Urestr
6116 c
6117            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
6118 c
6119 c          For Lorentzian-type Urestr
6120 c
6121          else
6122            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
6123      &           sigma_odlir(k,ii)**2)**2)
6124          endif
6125            sum_sgodl=sum_sgodl+sgodl
6126
6127 c            sgodl2=sgodl2+sgodl
6128 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
6129 c      write(iout,*) "constr_homology=",constr_homology
6130 c      write(iout,*) i, j, k, "TEST K"
6131          enddo
6132          if (waga_dist.ge.0.0d0) then
6133 c
6134 c          For Gaussian-type Urestr
6135 c
6136             grad_odl3=waga_homology(iset)*waga_dist
6137      &                *sum_sgodl/(sum_godl*dij)
6138 c
6139 c          For Lorentzian-type Urestr
6140 c
6141          else
6142 c Original grad expr modified by analogy w Gaussian-type Urestr grad
6143 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
6144             grad_odl3=-waga_homology(iset)*waga_dist*
6145      &                sum_sgodl/(constr_homology*dij)
6146          endif
6147 c
6148 c        grad_odl3=sum_sgodl/(sum_godl*dij)
6149
6150
6151 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
6152 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
6153 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
6154
6155 ccc      write(iout,*) godl, sgodl, grad_odl3
6156
6157 c          grad_odl=grad_odl+grad_odl3
6158
6159          do jik=1,3
6160             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
6161 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
6162 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
6163 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
6164             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
6165             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
6166 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
6167 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
6168 c         if (i.eq.25.and.j.eq.27) then
6169 c         write(iout,*) "jik",jik,"i",i,"j",j
6170 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
6171 c         write(iout,*) "grad_odl3",grad_odl3
6172 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
6173 c         write(iout,*) "ggodl",ggodl
6174 c         write(iout,*) "ghpbc(",jik,i,")",
6175 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
6176 c     &                 ghpbc(jik,j)
6177 c         endif
6178          enddo
6179 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
6180 ccc     & dLOG(odleg2),"-odleg=", -odleg
6181
6182       enddo ! ii-loop for dist
6183 #ifdef DEBUG
6184       write(iout,*) "------- dist restrs end -------"
6185 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
6186 c    &     waga_d.eq.1.0d0) call sum_gradient
6187 #endif
6188 c Pseudo-energy and gradient from dihedral-angle restraints from
6189 c homology templates
6190 c      write (iout,*) "End of distance loop"
6191 c      call flush(iout)
6192       kat=0.0d0
6193 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
6194 #ifdef DEBUG
6195       write(iout,*) "------- dih restrs start -------"
6196       do i=idihconstr_start_homo,idihconstr_end_homo
6197         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
6198       enddo
6199 #endif
6200       do i=idihconstr_start_homo,idihconstr_end_homo
6201         kat2=0.0d0
6202 c        betai=beta(i,i+1,i+2,i+3)
6203         betai = phi(i+3)
6204 c       write (iout,*) "betai =",betai
6205         do k=1,constr_homology
6206           dih_diff(k)=pinorm(dih(k,i)-betai)
6207 c         write (iout,*) "dih_diff(",k,") =",dih_diff(k)
6208 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
6209 c     &                                   -(6.28318-dih_diff(i,k))
6210 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
6211 c     &                                   6.28318+dih_diff(i,k)
6212
6213           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
6214 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
6215           gdih(k)=dexp(kat3)
6216           kat2=kat2+gdih(k)
6217 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
6218 c          write(*,*)""
6219         enddo
6220 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
6221 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
6222 #ifdef DEBUG
6223         write (iout,*) "i",i," betai",betai," kat2",kat2
6224         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
6225 #endif
6226         if (kat2.le.1.0d-14) cycle
6227         kat=kat-dLOG(kat2/constr_homology)
6228 c       write (iout,*) "kat",kat ! sum of -ln-s
6229
6230 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
6231 ccc     & dLOG(kat2), "-kat=", -kat
6232
6233 c ----------------------------------------------------------------------
6234 c Gradient
6235 c ----------------------------------------------------------------------
6236
6237         sum_gdih=kat2
6238         sum_sgdih=0.0d0
6239         do k=1,constr_homology
6240           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
6241 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
6242           sum_sgdih=sum_sgdih+sgdih
6243         enddo
6244 c       grad_dih3=sum_sgdih/sum_gdih
6245         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
6246
6247 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
6248 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
6249 ccc     & gloc(nphi+i-3,icg)
6250         gloc(i,icg)=gloc(i,icg)+grad_dih3
6251 c        if (i.eq.25) then
6252 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
6253 c        endif
6254 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
6255 ccc     & gloc(nphi+i-3,icg)
6256
6257       enddo ! i-loop for dih
6258 #ifdef DEBUG
6259       write(iout,*) "------- dih restrs end -------"
6260 #endif
6261
6262 c Pseudo-energy and gradient for theta angle restraints from
6263 c homology templates
6264 c FP 01/15 - inserted from econstr_local_test.F, loop structure
6265 c adapted
6266
6267 c
6268 c     For constr_homology reference structures (FP)
6269 c
6270 c     Uconst_back_tot=0.0d0
6271       Eval=0.0d0
6272       Erot=0.0d0
6273 c     Econstr_back legacy
6274       do i=1,nres
6275 c     do i=ithet_start,ithet_end
6276        dutheta(i)=0.0d0
6277 c     enddo
6278 c     do i=loc_start,loc_end
6279         do j=1,3
6280           duscdiff(j,i)=0.0d0
6281           duscdiffx(j,i)=0.0d0
6282         enddo
6283       enddo
6284 c
6285 c     do iref=1,nref
6286 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
6287 c     write (iout,*) "waga_theta",waga_theta
6288       if (waga_theta.gt.0.0d0) then
6289 #ifdef DEBUG
6290       write (iout,*) "usampl",usampl
6291       write(iout,*) "------- theta restrs start -------"
6292 c     do i=ithet_start,ithet_end
6293 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
6294 c     enddo
6295 #endif
6296 c     write (iout,*) "maxres",maxres,"nres",nres
6297
6298       do i=ithet_start,ithet_end
6299 c
6300 c     do i=1,nfrag_back
6301 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
6302 c
6303 c Deviation of theta angles wrt constr_homology ref structures
6304 c
6305         utheta_i=0.0d0 ! argument of Gaussian for single k
6306         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
6307 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
6308 c       over residues in a fragment
6309 c       write (iout,*) "theta(",i,")=",theta(i)
6310         do k=1,constr_homology
6311 c
6312 c         dtheta_i=theta(j)-thetaref(j,iref)
6313 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
6314           theta_diff(k)=thetatpl(k,i)-theta(i)
6315 c
6316           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
6317 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
6318           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
6319           gutheta_i=gutheta_i+dexp(utheta_i)   ! Sum of Gaussians (pk)
6320 c         Gradient for single Gaussian restraint in subr Econstr_back
6321 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
6322 c
6323         enddo
6324 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
6325 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
6326
6327 c
6328 c         Gradient for multiple Gaussian restraint
6329         sum_gtheta=gutheta_i
6330         sum_sgtheta=0.0d0
6331         do k=1,constr_homology
6332 c        New generalized expr for multiple Gaussian from Econstr_back
6333          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
6334 c
6335 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
6336           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
6337         enddo
6338 c       grad_theta3=sum_sgtheta/sum_gtheta 1/*theta(i)? s. line below
6339 c       grad_theta3=sum_sgtheta/sum_gtheta
6340 c
6341 c       Final value of gradient using same var as in Econstr_back
6342         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)
6343      &      +sum_sgtheta/sum_gtheta*waga_theta
6344      &               *waga_homology(iset)
6345 c        dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
6346 c     &               *waga_homology(iset)
6347 c       dutheta(i)=sum_sgtheta/sum_gtheta
6348 c
6349 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
6350         Eval=Eval-dLOG(gutheta_i/constr_homology)
6351 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
6352 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
6353 c       Uconst_back=Uconst_back+utheta(i)
6354       enddo ! (i-loop for theta)
6355 #ifdef DEBUG
6356       write(iout,*) "------- theta restrs end -------"
6357 #endif
6358       endif
6359 c
6360 c Deviation of local SC geometry
6361 c
6362 c Separation of two i-loops (instructed by AL - 11/3/2014)
6363 c
6364 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
6365 c     write (iout,*) "waga_d",waga_d
6366
6367 #ifdef DEBUG
6368       write(iout,*) "------- SC restrs start -------"
6369       write (iout,*) "Initial duscdiff,duscdiffx"
6370       do i=loc_start,loc_end
6371         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
6372      &                 (duscdiffx(jik,i),jik=1,3)
6373       enddo
6374 #endif
6375       do i=loc_start,loc_end
6376         usc_diff_i=0.0d0 ! argument of Gaussian for single k
6377         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
6378 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
6379 c       write(iout,*) "xxtab, yytab, zztab"
6380 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
6381         do k=1,constr_homology
6382 c
6383           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
6384 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
6385           dyy=-yytpl(k,i)+yytab(i) ! ibid y
6386           dzz=-zztpl(k,i)+zztab(i) ! ibid z
6387 c         write(iout,*) "dxx, dyy, dzz"
6388 c         write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
6389 c
6390           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
6391 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
6392 c         uscdiffk(k)=usc_diff(i)
6393           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
6394           guscdiff(i)=guscdiff(i)+dexp(usc_diff_i)   !Sum of Gaussians (pk)
6395 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
6396 c     &      xxref(j),yyref(j),zzref(j)
6397         enddo
6398 c
6399 c       Gradient
6400 c
6401 c       Generalized expression for multiple Gaussian acc to that for a single
6402 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
6403 c
6404 c       Original implementation
6405 c       sum_guscdiff=guscdiff(i)
6406 c
6407 c       sum_sguscdiff=0.0d0
6408 c       do k=1,constr_homology
6409 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
6410 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
6411 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
6412 c       enddo
6413 c
6414 c       Implementation of new expressions for gradient (Jan. 2015)
6415 c
6416 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
6417         do k=1,constr_homology
6418 c
6419 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
6420 c       before. Now the drivatives should be correct
6421 c
6422           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
6423 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
6424           dyy=-yytpl(k,i)+yytab(i) ! ibid y
6425           dzz=-zztpl(k,i)+zztab(i) ! ibid z
6426 c
6427 c         New implementation
6428 c
6429           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
6430      &                 sigma_d(k,i) ! for the grad wrt r'
6431 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
6432 c
6433 c
6434 c        New implementation
6435          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
6436          do jik=1,3
6437             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
6438      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
6439      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
6440             duscdiff(jik,i)=duscdiff(jik,i)+
6441      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
6442      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
6443             duscdiffx(jik,i)=duscdiffx(jik,i)+
6444      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
6445      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
6446 c
6447 #ifdef DEBUG
6448              write(iout,*) "jik",jik,"i",i
6449              write(iout,*) "dxx, dyy, dzz"
6450              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
6451              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
6452 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
6453 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
6454 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
6455 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
6456 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
6457 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
6458 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
6459 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
6460 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
6461 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
6462 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
6463 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
6464 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
6465 c            endif
6466 #endif
6467          enddo
6468         enddo
6469 c
6470 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
6471 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
6472 c
6473 c        write (iout,*) i," uscdiff",uscdiff(i)
6474 c
6475 c Put together deviations from local geometry
6476
6477 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
6478 c      &            wfrag_back(3,i,iset)*uscdiff(i)
6479         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
6480 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
6481 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
6482 c       Uconst_back=Uconst_back+usc_diff(i)
6483 c
6484 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
6485 c
6486 c     New implment: multiplied by sum_sguscdiff
6487 c
6488
6489       enddo ! (i-loop for dscdiff)
6490
6491 c      endif
6492
6493 #ifdef DEBUG
6494       write(iout,*) "------- SC restrs end -------"
6495         write (iout,*) "------ After SC loop in e_modeller ------"
6496         do i=loc_start,loc_end
6497          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
6498          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
6499         enddo
6500       if (waga_theta.eq.1.0d0) then
6501       write (iout,*) "in e_modeller after SC restr end: dutheta"
6502       do i=ithet_start,ithet_end
6503         write (iout,*) i,dutheta(i)
6504       enddo
6505       endif
6506       if (waga_d.eq.1.0d0) then
6507       write (iout,*) "e_modeller after SC loop: duscdiff/x"
6508       do i=1,nres
6509         write (iout,*) i,(duscdiff(j,i),j=1,3)
6510         write (iout,*) i,(duscdiffx(j,i),j=1,3)
6511       enddo
6512       endif
6513 #endif
6514
6515 c Total energy from homology restraints
6516 #ifdef DEBUG
6517       write (iout,*) "odleg",odleg," kat",kat
6518 #endif
6519 c
6520 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
6521 c
6522 c     ehomology_constr=odleg+kat
6523 c
6524 c     For Lorentzian-type Urestr
6525 c
6526
6527       if (waga_dist.ge.0.0d0) then
6528 c
6529 c          For Gaussian-type Urestr
6530 c
6531         ehomology_constr=(waga_dist*odleg+waga_angle*kat+
6532      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
6533 c     write (iout,*) "ehomology_constr=",ehomology_constr
6534       else
6535 c
6536 c          For Lorentzian-type Urestr
6537 c
6538         ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
6539      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
6540 c     write (iout,*) "ehomology_constr=",ehomology_constr
6541       endif
6542 #ifdef DEBUG
6543       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
6544      & "Eval",waga_theta,eval,
6545      &   "Erot",waga_d,Erot
6546       write (iout,*) "ehomology_constr",ehomology_constr
6547 #endif
6548       return
6549 c
6550 c FP 01/15 end
6551 c
6552   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
6553   747 format(a12,i4,i4,i4,f8.3,f8.3)
6554   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
6555   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
6556   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
6557      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
6558       end
6559
6560 c------------------------------------------------------------------------------
6561       subroutine etor_d(etors_d)
6562 C 6/23/01 Compute double torsional energy
6563       implicit real*8 (a-h,o-z)
6564       include 'DIMENSIONS'
6565       include 'COMMON.VAR'
6566       include 'COMMON.GEO'
6567       include 'COMMON.LOCAL'
6568       include 'COMMON.TORSION'
6569       include 'COMMON.INTERACT'
6570       include 'COMMON.DERIV'
6571       include 'COMMON.CHAIN'
6572       include 'COMMON.NAMES'
6573       include 'COMMON.IOUNITS'
6574       include 'COMMON.FFIELD'
6575       include 'COMMON.TORCNSTR'
6576       logical lprn
6577 C Set lprn=.true. for debugging
6578       lprn=.false.
6579 c     lprn=.true.
6580       etors_d=0.0D0
6581       do i=iphid_start,iphid_end
6582         itori=itortyp(itype(i-2))
6583         itori1=itortyp(itype(i-1))
6584         itori2=itortyp(itype(i))
6585         phii=phi(i)
6586         phii1=phi(i+1)
6587         gloci1=0.0D0
6588         gloci2=0.0D0
6589         do j=1,ntermd_1(itori,itori1,itori2)
6590           v1cij=v1c(1,j,itori,itori1,itori2)
6591           v1sij=v1s(1,j,itori,itori1,itori2)
6592           v2cij=v1c(2,j,itori,itori1,itori2)
6593           v2sij=v1s(2,j,itori,itori1,itori2)
6594           cosphi1=dcos(j*phii)
6595           sinphi1=dsin(j*phii)
6596           cosphi2=dcos(j*phii1)
6597           sinphi2=dsin(j*phii1)
6598           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
6599      &     v2cij*cosphi2+v2sij*sinphi2
6600           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6601           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6602         enddo
6603         do k=2,ntermd_2(itori,itori1,itori2)
6604           do l=1,k-1
6605             v1cdij = v2c(k,l,itori,itori1,itori2)
6606             v2cdij = v2c(l,k,itori,itori1,itori2)
6607             v1sdij = v2s(k,l,itori,itori1,itori2)
6608             v2sdij = v2s(l,k,itori,itori1,itori2)
6609             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6610             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6611             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6612             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6613             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6614      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6615             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
6616      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6617             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
6618      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6619           enddo
6620         enddo
6621         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
6622         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
6623 c        write (iout,*) "gloci", gloc(i-3,icg)
6624       enddo
6625       return
6626       end
6627 #endif
6628 c------------------------------------------------------------------------------
6629       subroutine eback_sc_corr(esccor)
6630 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6631 c        conformational states; temporarily implemented as differences
6632 c        between UNRES torsional potentials (dependent on three types of
6633 c        residues) and the torsional potentials dependent on all 20 types
6634 c        of residues computed from AM1  energy surfaces of terminally-blocked
6635 c        amino-acid residues.
6636       implicit real*8 (a-h,o-z)
6637       include 'DIMENSIONS'
6638       include 'COMMON.VAR'
6639       include 'COMMON.GEO'
6640       include 'COMMON.LOCAL'
6641       include 'COMMON.TORSION'
6642       include 'COMMON.SCCOR'
6643       include 'COMMON.INTERACT'
6644       include 'COMMON.DERIV'
6645       include 'COMMON.CHAIN'
6646       include 'COMMON.NAMES'
6647       include 'COMMON.IOUNITS'
6648       include 'COMMON.FFIELD'
6649       include 'COMMON.CONTROL'
6650       logical lprn
6651 C Set lprn=.true. for debugging
6652       lprn=.false.
6653 c      lprn=.true.
6654 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
6655       esccor=0.0D0
6656       do i=itau_start,itau_end
6657         esccor_ii=0.0D0
6658         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6659         isccori=isccortyp(itype(i-2))
6660         isccori1=isccortyp(itype(i-1))
6661         phii=phi(i)
6662 cccc  Added 9 May 2012
6663 cc Tauangle is torsional engle depending on the value of first digit
6664 c(see comment below)
6665 cc Omicron is flat angle depending on the value of first digit
6666 c(see comment below)
6667
6668
6669         do intertyp=1,3 !intertyp
6670 cc Added 09 May 2012 (Adasko)
6671 cc  Intertyp means interaction type of backbone mainchain correlation:
6672 c   1 = SC...Ca...Ca...Ca
6673 c   2 = Ca...Ca...Ca...SC
6674 c   3 = SC...Ca...Ca...SCi
6675         gloci=0.0D0
6676         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6677      &      (itype(i-1).eq.10).or.(itype(i-2).eq.21).or.
6678      &      (itype(i-1).eq.21)))
6679      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6680      &     .or.(itype(i-2).eq.21)))
6681      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6682      &      (itype(i-1).eq.21)))) cycle
6683         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle
6684         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21))
6685      & cycle
6686         do j=1,nterm_sccor(isccori,isccori1)
6687           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6688           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6689           cosphi=dcos(j*tauangle(intertyp,i))
6690           sinphi=dsin(j*tauangle(intertyp,i))
6691           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6692           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6693         enddo
6694         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6695 c        write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
6696 c     &gloc_sc(intertyp,i-3,icg)
6697         if (lprn)
6698      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6699      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6700      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
6701      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
6702         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6703        enddo !intertyp
6704       enddo
6705 c        do i=1,nres
6706 c        write (iout,*) "W@T@F",  gloc_sc(1,i,icg),gloc(i,icg)
6707 c        enddo
6708       return
6709       end
6710 c----------------------------------------------------------------------------
6711       subroutine multibody(ecorr)
6712 C This subroutine calculates multi-body contributions to energy following
6713 C the idea of Skolnick et al. If side chains I and J make a contact and
6714 C at the same time side chains I+1 and J+1 make a contact, an extra
6715 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6716       implicit real*8 (a-h,o-z)
6717       include 'DIMENSIONS'
6718       include 'COMMON.IOUNITS'
6719       include 'COMMON.DERIV'
6720       include 'COMMON.INTERACT'
6721       include 'COMMON.CONTACTS'
6722       double precision gx(3),gx1(3)
6723       logical lprn
6724
6725 C Set lprn=.true. for debugging
6726       lprn=.false.
6727
6728       if (lprn) then
6729         write (iout,'(a)') 'Contact function values:'
6730         do i=nnt,nct-2
6731           write (iout,'(i2,20(1x,i2,f10.5))')
6732      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6733         enddo
6734       endif
6735       ecorr=0.0D0
6736       do i=nnt,nct
6737         do j=1,3
6738           gradcorr(j,i)=0.0D0
6739           gradxorr(j,i)=0.0D0
6740         enddo
6741       enddo
6742       do i=nnt,nct-2
6743
6744         DO ISHIFT = 3,4
6745
6746         i1=i+ishift
6747         num_conti=num_cont(i)
6748         num_conti1=num_cont(i1)
6749         do jj=1,num_conti
6750           j=jcont(jj,i)
6751           do kk=1,num_conti1
6752             j1=jcont(kk,i1)
6753             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6754 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6755 cd   &                   ' ishift=',ishift
6756 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6757 C The system gains extra energy.
6758               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6759             endif   ! j1==j+-ishift
6760           enddo     ! kk
6761         enddo       ! jj
6762
6763         ENDDO ! ISHIFT
6764
6765       enddo         ! i
6766       return
6767       end
6768 c------------------------------------------------------------------------------
6769       double precision function esccorr(i,j,k,l,jj,kk)
6770       implicit real*8 (a-h,o-z)
6771       include 'DIMENSIONS'
6772       include 'COMMON.IOUNITS'
6773       include 'COMMON.DERIV'
6774       include 'COMMON.INTERACT'
6775       include 'COMMON.CONTACTS'
6776       double precision gx(3),gx1(3)
6777       logical lprn
6778       lprn=.false.
6779       eij=facont(jj,i)
6780       ekl=facont(kk,k)
6781 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6782 C Calculate the multi-body contribution to energy.
6783 C Calculate multi-body contributions to the gradient.
6784 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6785 cd   & k,l,(gacont(m,kk,k),m=1,3)
6786       do m=1,3
6787         gx(m) =ekl*gacont(m,jj,i)
6788         gx1(m)=eij*gacont(m,kk,k)
6789         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6790         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6791         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6792         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6793       enddo
6794       do m=i,j-1
6795         do ll=1,3
6796           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6797         enddo
6798       enddo
6799       do m=k,l-1
6800         do ll=1,3
6801           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6802         enddo
6803       enddo
6804       esccorr=-eij*ekl
6805       return
6806       end
6807 c------------------------------------------------------------------------------
6808       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6809 C This subroutine calculates multi-body contributions to hydrogen-bonding
6810       implicit real*8 (a-h,o-z)
6811       include 'DIMENSIONS'
6812       include 'COMMON.IOUNITS'
6813 #ifdef MPI
6814       include "mpif.h"
6815       parameter (max_cont=maxconts)
6816       parameter (max_dim=26)
6817       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6818       double precision zapas(max_dim,maxconts,max_fg_procs),
6819      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6820       common /przechowalnia/ zapas
6821       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6822      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6823 #endif
6824       include 'COMMON.SETUP'
6825       include 'COMMON.FFIELD'
6826       include 'COMMON.DERIV'
6827       include 'COMMON.INTERACT'
6828       include 'COMMON.CONTACTS'
6829       include 'COMMON.CONTROL'
6830       include 'COMMON.LOCAL'
6831       double precision gx(3),gx1(3),time00
6832       logical lprn,ldone
6833
6834 C Set lprn=.true. for debugging
6835       lprn=.false.
6836 #ifdef MPI
6837       n_corr=0
6838       n_corr1=0
6839       if (nfgtasks.le.1) goto 30
6840       if (lprn) then
6841         write (iout,'(a)') 'Contact function values before RECEIVE:'
6842         do i=nnt,nct-2
6843           write (iout,'(2i3,50(1x,i2,f5.2))')
6844      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6845      &    j=1,num_cont_hb(i))
6846         enddo
6847       endif
6848       call flush(iout)
6849       do i=1,ntask_cont_from
6850         ncont_recv(i)=0
6851       enddo
6852       do i=1,ntask_cont_to
6853         ncont_sent(i)=0
6854       enddo
6855 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6856 c     & ntask_cont_to
6857 C Make the list of contacts to send to send to other procesors
6858 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6859 c      call flush(iout)
6860       do i=iturn3_start,iturn3_end
6861 c        write (iout,*) "make contact list turn3",i," num_cont",
6862 c     &    num_cont_hb(i)
6863         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6864       enddo
6865       do i=iturn4_start,iturn4_end
6866 c        write (iout,*) "make contact list turn4",i," num_cont",
6867 c     &   num_cont_hb(i)
6868         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6869       enddo
6870       do ii=1,nat_sent
6871         i=iat_sent(ii)
6872 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6873 c     &    num_cont_hb(i)
6874         do j=1,num_cont_hb(i)
6875         do k=1,4
6876           jjc=jcont_hb(j,i)
6877           iproc=iint_sent_local(k,jjc,ii)
6878 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6879           if (iproc.gt.0) then
6880             ncont_sent(iproc)=ncont_sent(iproc)+1
6881             nn=ncont_sent(iproc)
6882             zapas(1,nn,iproc)=i
6883             zapas(2,nn,iproc)=jjc
6884             zapas(3,nn,iproc)=facont_hb(j,i)
6885             zapas(4,nn,iproc)=ees0p(j,i)
6886             zapas(5,nn,iproc)=ees0m(j,i)
6887             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6888             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6889             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6890             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6891             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6892             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6893             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6894             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6895             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6896             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6897             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6898             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6899             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6900             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6901             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6902             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6903             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6904             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6905             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6906             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6907             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6908           endif
6909         enddo
6910         enddo
6911       enddo
6912       if (lprn) then
6913       write (iout,*)
6914      &  "Numbers of contacts to be sent to other processors",
6915      &  (ncont_sent(i),i=1,ntask_cont_to)
6916       write (iout,*) "Contacts sent"
6917       do ii=1,ntask_cont_to
6918         nn=ncont_sent(ii)
6919         iproc=itask_cont_to(ii)
6920         write (iout,*) nn," contacts to processor",iproc,
6921      &   " of CONT_TO_COMM group"
6922         do i=1,nn
6923           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6924         enddo
6925       enddo
6926       call flush(iout)
6927       endif
6928       CorrelType=477
6929       CorrelID=fg_rank+1
6930       CorrelType1=478
6931       CorrelID1=nfgtasks+fg_rank+1
6932       ireq=0
6933 C Receive the numbers of needed contacts from other processors
6934       do ii=1,ntask_cont_from
6935         iproc=itask_cont_from(ii)
6936         ireq=ireq+1
6937         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6938      &    FG_COMM,req(ireq),IERR)
6939       enddo
6940 c      write (iout,*) "IRECV ended"
6941 c      call flush(iout)
6942 C Send the number of contacts needed by other processors
6943       do ii=1,ntask_cont_to
6944         iproc=itask_cont_to(ii)
6945         ireq=ireq+1
6946         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6947      &    FG_COMM,req(ireq),IERR)
6948       enddo
6949 c      write (iout,*) "ISEND ended"
6950 c      write (iout,*) "number of requests (nn)",ireq
6951       call flush(iout)
6952       if (ireq.gt.0)
6953      &  call MPI_Waitall(ireq,req,status_array,ierr)
6954 c      write (iout,*)
6955 c     &  "Numbers of contacts to be received from other processors",
6956 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6957 c      call flush(iout)
6958 C Receive contacts
6959       ireq=0
6960       do ii=1,ntask_cont_from
6961         iproc=itask_cont_from(ii)
6962         nn=ncont_recv(ii)
6963 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6964 c     &   " of CONT_TO_COMM group"
6965         call flush(iout)
6966         if (nn.gt.0) then
6967           ireq=ireq+1
6968           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6969      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6970 c          write (iout,*) "ireq,req",ireq,req(ireq)
6971         endif
6972       enddo
6973 C Send the contacts to processors that need them
6974       do ii=1,ntask_cont_to
6975         iproc=itask_cont_to(ii)
6976         nn=ncont_sent(ii)
6977 c        write (iout,*) nn," contacts to processor",iproc,
6978 c     &   " of CONT_TO_COMM group"
6979         if (nn.gt.0) then
6980           ireq=ireq+1
6981           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6982      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6983 c          write (iout,*) "ireq,req",ireq,req(ireq)
6984 c          do i=1,nn
6985 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6986 c          enddo
6987         endif
6988       enddo
6989 c      write (iout,*) "number of requests (contacts)",ireq
6990 c      write (iout,*) "req",(req(i),i=1,4)
6991 c      call flush(iout)
6992       if (ireq.gt.0)
6993      & call MPI_Waitall(ireq,req,status_array,ierr)
6994       do iii=1,ntask_cont_from
6995         iproc=itask_cont_from(iii)
6996         nn=ncont_recv(iii)
6997         if (lprn) then
6998         write (iout,*) "Received",nn," contacts from processor",iproc,
6999      &   " of CONT_FROM_COMM group"
7000         call flush(iout)
7001         do i=1,nn
7002           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
7003         enddo
7004         call flush(iout)
7005         endif
7006         do i=1,nn
7007           ii=zapas_recv(1,i,iii)
7008 c Flag the received contacts to prevent double-counting
7009           jj=-zapas_recv(2,i,iii)
7010 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7011 c          call flush(iout)
7012           nnn=num_cont_hb(ii)+1
7013           num_cont_hb(ii)=nnn
7014           jcont_hb(nnn,ii)=jj
7015           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
7016           ees0p(nnn,ii)=zapas_recv(4,i,iii)
7017           ees0m(nnn,ii)=zapas_recv(5,i,iii)
7018           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
7019           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
7020           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
7021           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
7022           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
7023           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
7024           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
7025           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
7026           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
7027           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
7028           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
7029           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
7030           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
7031           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
7032           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
7033           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
7034           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
7035           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
7036           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
7037           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
7038           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
7039         enddo
7040       enddo
7041       call flush(iout)
7042       if (lprn) then
7043         write (iout,'(a)') 'Contact function values after receive:'
7044         do i=nnt,nct-2
7045           write (iout,'(2i3,50(1x,i3,f5.2))')
7046      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7047      &    j=1,num_cont_hb(i))
7048         enddo
7049         call flush(iout)
7050       endif
7051    30 continue
7052 #endif
7053       if (lprn) then
7054         write (iout,'(a)') 'Contact function values:'
7055         do i=nnt,nct-2
7056           write (iout,'(2i3,50(1x,i3,f5.2))')
7057      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7058      &    j=1,num_cont_hb(i))
7059         enddo
7060       endif
7061       ecorr=0.0D0
7062 C Remove the loop below after debugging !!!
7063       do i=nnt,nct
7064         do j=1,3
7065           gradcorr(j,i)=0.0D0
7066           gradxorr(j,i)=0.0D0
7067         enddo
7068       enddo
7069 C Calculate the local-electrostatic correlation terms
7070       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
7071         i1=i+1
7072         num_conti=num_cont_hb(i)
7073         num_conti1=num_cont_hb(i+1)
7074         do jj=1,num_conti
7075           j=jcont_hb(jj,i)
7076           jp=iabs(j)
7077           do kk=1,num_conti1
7078             j1=jcont_hb(kk,i1)
7079             jp1=iabs(j1)
7080 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7081 c     &         ' jj=',jj,' kk=',kk
7082             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7083      &          .or. j.lt.0 .and. j1.gt.0) .and.
7084      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7085 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7086 C The system gains extra energy.
7087               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7088               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
7089      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
7090               n_corr=n_corr+1
7091             else if (j1.eq.j) then
7092 C Contacts I-J and I-(J+1) occur simultaneously.
7093 C The system loses extra energy.
7094 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7095             endif
7096           enddo ! kk
7097           do kk=1,num_conti
7098             j1=jcont_hb(kk,i)
7099 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7100 c    &         ' jj=',jj,' kk=',kk
7101             if (j1.eq.j+1) then
7102 C Contacts I-J and (I+1)-J occur simultaneously.
7103 C The system loses extra energy.
7104 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7105             endif ! j1==j+1
7106           enddo ! kk
7107         enddo ! jj
7108       enddo ! i
7109       return
7110       end
7111 c------------------------------------------------------------------------------
7112       subroutine add_hb_contact(ii,jj,itask)
7113       implicit real*8 (a-h,o-z)
7114       include "DIMENSIONS"
7115       include "COMMON.IOUNITS"
7116       integer max_cont
7117       integer max_dim
7118       parameter (max_cont=maxconts)
7119       parameter (max_dim=26)
7120       include "COMMON.CONTACTS"
7121       double precision zapas(max_dim,maxconts,max_fg_procs),
7122      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7123       common /przechowalnia/ zapas
7124       integer i,j,ii,jj,iproc,itask(4),nn
7125 c      write (iout,*) "itask",itask
7126       do i=1,2
7127         iproc=itask(i)
7128         if (iproc.gt.0) then
7129           do j=1,num_cont_hb(ii)
7130             jjc=jcont_hb(j,ii)
7131 c            write (iout,*) "i",ii," j",jj," jjc",jjc
7132             if (jjc.eq.jj) then
7133               ncont_sent(iproc)=ncont_sent(iproc)+1
7134               nn=ncont_sent(iproc)
7135               zapas(1,nn,iproc)=ii
7136               zapas(2,nn,iproc)=jjc
7137               zapas(3,nn,iproc)=facont_hb(j,ii)
7138               zapas(4,nn,iproc)=ees0p(j,ii)
7139               zapas(5,nn,iproc)=ees0m(j,ii)
7140               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
7141               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
7142               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
7143               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
7144               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
7145               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
7146               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
7147               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
7148               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
7149               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
7150               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
7151               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
7152               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
7153               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
7154               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
7155               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
7156               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
7157               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
7158               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
7159               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
7160               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
7161               exit
7162             endif
7163           enddo
7164         endif
7165       enddo
7166       return
7167       end
7168 c------------------------------------------------------------------------------
7169       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
7170      &  n_corr1)
7171 C This subroutine calculates multi-body contributions to hydrogen-bonding
7172       implicit real*8 (a-h,o-z)
7173       include 'DIMENSIONS'
7174       include 'COMMON.IOUNITS'
7175 #ifdef MPI
7176       include "mpif.h"
7177       parameter (max_cont=maxconts)
7178       parameter (max_dim=70)
7179       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7180       double precision zapas(max_dim,maxconts,max_fg_procs),
7181      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7182       common /przechowalnia/ zapas
7183       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7184      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7185 #endif
7186       include 'COMMON.SETUP'
7187       include 'COMMON.FFIELD'
7188       include 'COMMON.DERIV'
7189       include 'COMMON.LOCAL'
7190       include 'COMMON.INTERACT'
7191       include 'COMMON.CONTACTS'
7192       include 'COMMON.CHAIN'
7193       include 'COMMON.CONTROL'
7194       double precision gx(3),gx1(3)
7195       integer num_cont_hb_old(maxres)
7196       logical lprn,ldone
7197       double precision eello4,eello5,eelo6,eello_turn6
7198       external eello4,eello5,eello6,eello_turn6
7199 C Set lprn=.true. for debugging
7200       lprn=.false.
7201       eturn6=0.0d0
7202 #ifdef MPI
7203       do i=1,nres
7204         num_cont_hb_old(i)=num_cont_hb(i)
7205       enddo
7206       n_corr=0
7207       n_corr1=0
7208       if (nfgtasks.le.1) goto 30
7209       if (lprn) then
7210         write (iout,'(a)') 'Contact function values before RECEIVE:'
7211         do i=nnt,nct-2
7212           write (iout,'(2i3,50(1x,i2,f5.2))')
7213      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7214      &    j=1,num_cont_hb(i))
7215         enddo
7216       endif
7217       call flush(iout)
7218       do i=1,ntask_cont_from
7219         ncont_recv(i)=0
7220       enddo
7221       do i=1,ntask_cont_to
7222         ncont_sent(i)=0
7223       enddo
7224 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7225 c     & ntask_cont_to
7226 C Make the list of contacts to send to send to other procesors
7227       do i=iturn3_start,iturn3_end
7228 c        write (iout,*) "make contact list turn3",i," num_cont",
7229 c     &    num_cont_hb(i)
7230         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
7231       enddo
7232       do i=iturn4_start,iturn4_end
7233 c        write (iout,*) "make contact list turn4",i," num_cont",
7234 c     &   num_cont_hb(i)
7235         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
7236       enddo
7237       do ii=1,nat_sent
7238         i=iat_sent(ii)
7239 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7240 c     &    num_cont_hb(i)
7241         do j=1,num_cont_hb(i)
7242         do k=1,4
7243           jjc=jcont_hb(j,i)
7244           iproc=iint_sent_local(k,jjc,ii)
7245 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7246           if (iproc.ne.0) then
7247             ncont_sent(iproc)=ncont_sent(iproc)+1
7248             nn=ncont_sent(iproc)
7249             zapas(1,nn,iproc)=i
7250             zapas(2,nn,iproc)=jjc
7251             zapas(3,nn,iproc)=d_cont(j,i)
7252             ind=3
7253             do kk=1,3
7254               ind=ind+1
7255               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
7256             enddo
7257             do kk=1,2
7258               do ll=1,2
7259                 ind=ind+1
7260                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
7261               enddo
7262             enddo
7263             do jj=1,5
7264               do kk=1,3
7265                 do ll=1,2
7266                   do mm=1,2
7267                     ind=ind+1
7268                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
7269                   enddo
7270                 enddo
7271               enddo
7272             enddo
7273           endif
7274         enddo
7275         enddo
7276       enddo
7277       if (lprn) then
7278       write (iout,*)
7279      &  "Numbers of contacts to be sent to other processors",
7280      &  (ncont_sent(i),i=1,ntask_cont_to)
7281       write (iout,*) "Contacts sent"
7282       do ii=1,ntask_cont_to
7283         nn=ncont_sent(ii)
7284         iproc=itask_cont_to(ii)
7285         write (iout,*) nn," contacts to processor",iproc,
7286      &   " of CONT_TO_COMM group"
7287         do i=1,nn
7288           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
7289         enddo
7290       enddo
7291       call flush(iout)
7292       endif
7293       CorrelType=477
7294       CorrelID=fg_rank+1
7295       CorrelType1=478
7296       CorrelID1=nfgtasks+fg_rank+1
7297       ireq=0
7298 C Receive the numbers of needed contacts from other processors
7299       do ii=1,ntask_cont_from
7300         iproc=itask_cont_from(ii)
7301         ireq=ireq+1
7302         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7303      &    FG_COMM,req(ireq),IERR)
7304       enddo
7305 c      write (iout,*) "IRECV ended"
7306 c      call flush(iout)
7307 C Send the number of contacts needed by other processors
7308       do ii=1,ntask_cont_to
7309         iproc=itask_cont_to(ii)
7310         ireq=ireq+1
7311         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7312      &    FG_COMM,req(ireq),IERR)
7313       enddo
7314 c      write (iout,*) "ISEND ended"
7315 c      write (iout,*) "number of requests (nn)",ireq
7316       call flush(iout)
7317       if (ireq.gt.0)
7318      &  call MPI_Waitall(ireq,req,status_array,ierr)
7319 c      write (iout,*)
7320 c     &  "Numbers of contacts to be received from other processors",
7321 c     &  (ncont_recv(i),i=1,ntask_cont_from)
7322 c      call flush(iout)
7323 C Receive contacts
7324       ireq=0
7325       do ii=1,ntask_cont_from
7326         iproc=itask_cont_from(ii)
7327         nn=ncont_recv(ii)
7328 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7329 c     &   " of CONT_TO_COMM group"
7330         call flush(iout)
7331         if (nn.gt.0) then
7332           ireq=ireq+1
7333           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
7334      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7335 c          write (iout,*) "ireq,req",ireq,req(ireq)
7336         endif
7337       enddo
7338 C Send the contacts to processors that need them
7339       do ii=1,ntask_cont_to
7340         iproc=itask_cont_to(ii)
7341         nn=ncont_sent(ii)
7342 c        write (iout,*) nn," contacts to processor",iproc,
7343 c     &   " of CONT_TO_COMM group"
7344         if (nn.gt.0) then
7345           ireq=ireq+1
7346           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
7347      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7348 c          write (iout,*) "ireq,req",ireq,req(ireq)
7349 c          do i=1,nn
7350 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7351 c          enddo
7352         endif
7353       enddo
7354 c      write (iout,*) "number of requests (contacts)",ireq
7355 c      write (iout,*) "req",(req(i),i=1,4)
7356 c      call flush(iout)
7357       if (ireq.gt.0)
7358      & call MPI_Waitall(ireq,req,status_array,ierr)
7359       do iii=1,ntask_cont_from
7360         iproc=itask_cont_from(iii)
7361         nn=ncont_recv(iii)
7362         if (lprn) then
7363         write (iout,*) "Received",nn," contacts from processor",iproc,
7364      &   " of CONT_FROM_COMM group"
7365         call flush(iout)
7366         do i=1,nn
7367           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
7368         enddo
7369         call flush(iout)
7370         endif
7371         do i=1,nn
7372           ii=zapas_recv(1,i,iii)
7373 c Flag the received contacts to prevent double-counting
7374           jj=-zapas_recv(2,i,iii)
7375 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7376 c          call flush(iout)
7377           nnn=num_cont_hb(ii)+1
7378           num_cont_hb(ii)=nnn
7379           jcont_hb(nnn,ii)=jj
7380           d_cont(nnn,ii)=zapas_recv(3,i,iii)
7381           ind=3
7382           do kk=1,3
7383             ind=ind+1
7384             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
7385           enddo
7386           do kk=1,2
7387             do ll=1,2
7388               ind=ind+1
7389               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
7390             enddo
7391           enddo
7392           do jj=1,5
7393             do kk=1,3
7394               do ll=1,2
7395                 do mm=1,2
7396                   ind=ind+1
7397                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
7398                 enddo
7399               enddo
7400             enddo
7401           enddo
7402         enddo
7403       enddo
7404       call flush(iout)
7405       if (lprn) then
7406         write (iout,'(a)') 'Contact function values after receive:'
7407         do i=nnt,nct-2
7408           write (iout,'(2i3,50(1x,i3,5f6.3))')
7409      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7410      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7411         enddo
7412         call flush(iout)
7413       endif
7414    30 continue
7415 #endif
7416       if (lprn) then
7417         write (iout,'(a)') 'Contact function values:'
7418         do i=nnt,nct-2
7419           write (iout,'(2i3,50(1x,i2,5f6.3))')
7420      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7421      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7422         enddo
7423       endif
7424       ecorr=0.0D0
7425       ecorr5=0.0d0
7426       ecorr6=0.0d0
7427 C Remove the loop below after debugging !!!
7428       do i=nnt,nct
7429         do j=1,3
7430           gradcorr(j,i)=0.0D0
7431           gradxorr(j,i)=0.0D0
7432         enddo
7433       enddo
7434 C Calculate the dipole-dipole interaction energies
7435       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7436       do i=iatel_s,iatel_e+1
7437         num_conti=num_cont_hb(i)
7438         do jj=1,num_conti
7439           j=jcont_hb(jj,i)
7440 #ifdef MOMENT
7441           call dipole(i,j,jj)
7442 #endif
7443         enddo
7444       enddo
7445       endif
7446 C Calculate the local-electrostatic correlation terms
7447 c                write (iout,*) "gradcorr5 in eello5 before loop"
7448 c                do iii=1,nres
7449 c                  write (iout,'(i5,3f10.5)')
7450 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7451 c                enddo
7452       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7453 c        write (iout,*) "corr loop i",i
7454         i1=i+1
7455         num_conti=num_cont_hb(i)
7456         num_conti1=num_cont_hb(i+1)
7457         do jj=1,num_conti
7458           j=jcont_hb(jj,i)
7459           jp=iabs(j)
7460           do kk=1,num_conti1
7461             j1=jcont_hb(kk,i1)
7462             jp1=iabs(j1)
7463 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7464 c     &         ' jj=',jj,' kk=',kk
7465 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
7466             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7467      &          .or. j.lt.0 .and. j1.gt.0) .and.
7468      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7469 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7470 C The system gains extra energy.
7471               n_corr=n_corr+1
7472               sqd1=dsqrt(d_cont(jj,i))
7473               sqd2=dsqrt(d_cont(kk,i1))
7474               sred_geom = sqd1*sqd2
7475               IF (sred_geom.lt.cutoff_corr) THEN
7476                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
7477      &            ekont,fprimcont)
7478 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7479 cd     &         ' jj=',jj,' kk=',kk
7480                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7481                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7482                 do l=1,3
7483                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7484                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7485                 enddo
7486                 n_corr1=n_corr1+1
7487 cd               write (iout,*) 'sred_geom=',sred_geom,
7488 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
7489 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7490 cd               write (iout,*) "g_contij",g_contij
7491 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7492 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7493                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7494                 if (wcorr4.gt.0.0d0)
7495      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7496                   if (energy_dec.and.wcorr4.gt.0.0d0)
7497      1                 write (iout,'(a6,4i5,0pf7.3)')
7498      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7499 c                write (iout,*) "gradcorr5 before eello5"
7500 c                do iii=1,nres
7501 c                  write (iout,'(i5,3f10.5)')
7502 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7503 c                enddo
7504                 if (wcorr5.gt.0.0d0)
7505      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7506 c                write (iout,*) "gradcorr5 after eello5"
7507 c                do iii=1,nres
7508 c                  write (iout,'(i5,3f10.5)')
7509 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7510 c                enddo
7511                   if (energy_dec.and.wcorr5.gt.0.0d0)
7512      1                 write (iout,'(a6,4i5,0pf7.3)')
7513      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7514 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7515 cd                write(2,*)'ijkl',i,jp,i+1,jp1
7516                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
7517      &               .or. wturn6.eq.0.0d0))then
7518 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7519                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7520                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7521      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7522 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7523 cd     &            'ecorr6=',ecorr6
7524 cd                write (iout,'(4e15.5)') sred_geom,
7525 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7526 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7527 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7528                 else if (wturn6.gt.0.0d0
7529      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7530 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7531                   eturn6=eturn6+eello_turn6(i,jj,kk)
7532                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7533      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7534 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
7535                 endif
7536               ENDIF
7537 1111          continue
7538             endif
7539           enddo ! kk
7540         enddo ! jj
7541       enddo ! i
7542       do i=1,nres
7543         num_cont_hb(i)=num_cont_hb_old(i)
7544       enddo
7545 c                write (iout,*) "gradcorr5 in eello5"
7546 c                do iii=1,nres
7547 c                  write (iout,'(i5,3f10.5)')
7548 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7549 c                enddo
7550       return
7551       end
7552 c------------------------------------------------------------------------------
7553       subroutine add_hb_contact_eello(ii,jj,itask)
7554       implicit real*8 (a-h,o-z)
7555       include "DIMENSIONS"
7556       include "COMMON.IOUNITS"
7557       integer max_cont
7558       integer max_dim
7559       parameter (max_cont=maxconts)
7560       parameter (max_dim=70)
7561       include "COMMON.CONTACTS"
7562       double precision zapas(max_dim,maxconts,max_fg_procs),
7563      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7564       common /przechowalnia/ zapas
7565       integer i,j,ii,jj,iproc,itask(4),nn
7566 c      write (iout,*) "itask",itask
7567       do i=1,2
7568         iproc=itask(i)
7569         if (iproc.gt.0) then
7570           do j=1,num_cont_hb(ii)
7571             jjc=jcont_hb(j,ii)
7572 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
7573             if (jjc.eq.jj) then
7574               ncont_sent(iproc)=ncont_sent(iproc)+1
7575               nn=ncont_sent(iproc)
7576               zapas(1,nn,iproc)=ii
7577               zapas(2,nn,iproc)=jjc
7578               zapas(3,nn,iproc)=d_cont(j,ii)
7579               ind=3
7580               do kk=1,3
7581                 ind=ind+1
7582                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
7583               enddo
7584               do kk=1,2
7585                 do ll=1,2
7586                   ind=ind+1
7587                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
7588                 enddo
7589               enddo
7590               do jj=1,5
7591                 do kk=1,3
7592                   do ll=1,2
7593                     do mm=1,2
7594                       ind=ind+1
7595                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
7596                     enddo
7597                   enddo
7598                 enddo
7599               enddo
7600               exit
7601             endif
7602           enddo
7603         endif
7604       enddo
7605       return
7606       end
7607 c------------------------------------------------------------------------------
7608       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7609       implicit real*8 (a-h,o-z)
7610       include 'DIMENSIONS'
7611       include 'COMMON.IOUNITS'
7612       include 'COMMON.DERIV'
7613       include 'COMMON.INTERACT'
7614       include 'COMMON.CONTACTS'
7615       double precision gx(3),gx1(3)
7616       logical lprn
7617       lprn=.false.
7618       eij=facont_hb(jj,i)
7619       ekl=facont_hb(kk,k)
7620       ees0pij=ees0p(jj,i)
7621       ees0pkl=ees0p(kk,k)
7622       ees0mij=ees0m(jj,i)
7623       ees0mkl=ees0m(kk,k)
7624       ekont=eij*ekl
7625       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7626 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7627 C Following 4 lines for diagnostics.
7628 cd    ees0pkl=0.0D0
7629 cd    ees0pij=1.0D0
7630 cd    ees0mkl=0.0D0
7631 cd    ees0mij=1.0D0
7632 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7633 c     & 'Contacts ',i,j,
7634 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7635 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7636 c     & 'gradcorr_long'
7637 C Calculate the multi-body contribution to energy.
7638 c      ecorr=ecorr+ekont*ees
7639 C Calculate multi-body contributions to the gradient.
7640       coeffpees0pij=coeffp*ees0pij
7641       coeffmees0mij=coeffm*ees0mij
7642       coeffpees0pkl=coeffp*ees0pkl
7643       coeffmees0mkl=coeffm*ees0mkl
7644       do ll=1,3
7645 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7646         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
7647      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
7648      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
7649         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
7650      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
7651      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
7652 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7653         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
7654      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
7655      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
7656         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
7657      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
7658      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
7659         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
7660      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
7661      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
7662         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7663         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7664         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
7665      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
7666      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
7667         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7668         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7669 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7670       enddo
7671 c      write (iout,*)
7672 cgrad      do m=i+1,j-1
7673 cgrad        do ll=1,3
7674 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7675 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7676 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7677 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7678 cgrad        enddo
7679 cgrad      enddo
7680 cgrad      do m=k+1,l-1
7681 cgrad        do ll=1,3
7682 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7683 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7684 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7685 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7686 cgrad        enddo
7687 cgrad      enddo
7688 c      write (iout,*) "ehbcorr",ekont*ees
7689       ehbcorr=ekont*ees
7690       return
7691       end
7692 #ifdef MOMENT
7693 C---------------------------------------------------------------------------
7694       subroutine dipole(i,j,jj)
7695       implicit real*8 (a-h,o-z)
7696       include 'DIMENSIONS'
7697       include 'COMMON.IOUNITS'
7698       include 'COMMON.CHAIN'
7699       include 'COMMON.FFIELD'
7700       include 'COMMON.DERIV'
7701       include 'COMMON.INTERACT'
7702       include 'COMMON.CONTACTS'
7703       include 'COMMON.TORSION'
7704       include 'COMMON.VAR'
7705       include 'COMMON.GEO'
7706       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7707      &  auxmat(2,2)
7708       iti1 = itortyp(itype(i+1))
7709       if (j.lt.nres-1) then
7710         itj1 = itortyp(itype(j+1))
7711       else
7712         itj1=ntortyp+1
7713       endif
7714       do iii=1,2
7715         dipi(iii,1)=Ub2(iii,i)
7716         dipderi(iii)=Ub2der(iii,i)
7717         dipi(iii,2)=b1(iii,iti1)
7718         dipj(iii,1)=Ub2(iii,j)
7719         dipderj(iii)=Ub2der(iii,j)
7720         dipj(iii,2)=b1(iii,itj1)
7721       enddo
7722       kkk=0
7723       do iii=1,2
7724         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7725         do jjj=1,2
7726           kkk=kkk+1
7727           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7728         enddo
7729       enddo
7730       do kkk=1,5
7731         do lll=1,3
7732           mmm=0
7733           do iii=1,2
7734             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7735      &        auxvec(1))
7736             do jjj=1,2
7737               mmm=mmm+1
7738               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7739             enddo
7740           enddo
7741         enddo
7742       enddo
7743       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7744       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7745       do iii=1,2
7746         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7747       enddo
7748       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7749       do iii=1,2
7750         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7751       enddo
7752       return
7753       end
7754 #endif
7755 C---------------------------------------------------------------------------
7756       subroutine calc_eello(i,j,k,l,jj,kk)
7757 C
7758 C This subroutine computes matrices and vectors needed to calculate
7759 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7760 C
7761       implicit real*8 (a-h,o-z)
7762       include 'DIMENSIONS'
7763       include 'COMMON.IOUNITS'
7764       include 'COMMON.CHAIN'
7765       include 'COMMON.DERIV'
7766       include 'COMMON.INTERACT'
7767       include 'COMMON.CONTACTS'
7768       include 'COMMON.TORSION'
7769       include 'COMMON.VAR'
7770       include 'COMMON.GEO'
7771       include 'COMMON.FFIELD'
7772       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7773      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7774       logical lprn
7775       common /kutas/ lprn
7776 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7777 cd     & ' jj=',jj,' kk=',kk
7778 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7779 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7780 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7781       do iii=1,2
7782         do jjj=1,2
7783           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7784           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7785         enddo
7786       enddo
7787       call transpose2(aa1(1,1),aa1t(1,1))
7788       call transpose2(aa2(1,1),aa2t(1,1))
7789       do kkk=1,5
7790         do lll=1,3
7791           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7792      &      aa1tder(1,1,lll,kkk))
7793           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7794      &      aa2tder(1,1,lll,kkk))
7795         enddo
7796       enddo
7797       if (l.eq.j+1) then
7798 C parallel orientation of the two CA-CA-CA frames.
7799         if (i.gt.1) then
7800           iti=itortyp(itype(i))
7801         else
7802           iti=ntortyp+1
7803         endif
7804         itk1=itortyp(itype(k+1))
7805         itj=itortyp(itype(j))
7806         if (l.lt.nres-1) then
7807           itl1=itortyp(itype(l+1))
7808         else
7809           itl1=ntortyp+1
7810         endif
7811 C A1 kernel(j+1) A2T
7812 cd        do iii=1,2
7813 cd          write (iout,'(3f10.5,5x,3f10.5)')
7814 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7815 cd        enddo
7816         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7817      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7818      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7819 C Following matrices are needed only for 6-th order cumulants
7820         IF (wcorr6.gt.0.0d0) THEN
7821         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7822      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7823      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7824         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7825      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7826      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7827      &   ADtEAderx(1,1,1,1,1,1))
7828         lprn=.false.
7829         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7830      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7831      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7832      &   ADtEA1derx(1,1,1,1,1,1))
7833         ENDIF
7834 C End 6-th order cumulants
7835 cd        lprn=.false.
7836 cd        if (lprn) then
7837 cd        write (2,*) 'In calc_eello6'
7838 cd        do iii=1,2
7839 cd          write (2,*) 'iii=',iii
7840 cd          do kkk=1,5
7841 cd            write (2,*) 'kkk=',kkk
7842 cd            do jjj=1,2
7843 cd              write (2,'(3(2f10.5),5x)')
7844 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7845 cd            enddo
7846 cd          enddo
7847 cd        enddo
7848 cd        endif
7849         call transpose2(EUgder(1,1,k),auxmat(1,1))
7850         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7851         call transpose2(EUg(1,1,k),auxmat(1,1))
7852         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7853         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7854         do iii=1,2
7855           do kkk=1,5
7856             do lll=1,3
7857               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7858      &          EAEAderx(1,1,lll,kkk,iii,1))
7859             enddo
7860           enddo
7861         enddo
7862 C A1T kernel(i+1) A2
7863         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7864      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7865      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7866 C Following matrices are needed only for 6-th order cumulants
7867         IF (wcorr6.gt.0.0d0) THEN
7868         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7869      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7870      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7871         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7872      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7873      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7874      &   ADtEAderx(1,1,1,1,1,2))
7875         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7876      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7877      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7878      &   ADtEA1derx(1,1,1,1,1,2))
7879         ENDIF
7880 C End 6-th order cumulants
7881         call transpose2(EUgder(1,1,l),auxmat(1,1))
7882         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7883         call transpose2(EUg(1,1,l),auxmat(1,1))
7884         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7885         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7886         do iii=1,2
7887           do kkk=1,5
7888             do lll=1,3
7889               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7890      &          EAEAderx(1,1,lll,kkk,iii,2))
7891             enddo
7892           enddo
7893         enddo
7894 C AEAb1 and AEAb2
7895 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7896 C They are needed only when the fifth- or the sixth-order cumulants are
7897 C indluded.
7898         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7899         call transpose2(AEA(1,1,1),auxmat(1,1))
7900         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7901         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7902         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7903         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7904         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7905         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7906         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7907         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7908         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7909         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7910         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7911         call transpose2(AEA(1,1,2),auxmat(1,1))
7912         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7913         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7914         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7915         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7916         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7917         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7918         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7919         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7920         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7921         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7922         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7923 C Calculate the Cartesian derivatives of the vectors.
7924         do iii=1,2
7925           do kkk=1,5
7926             do lll=1,3
7927               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7928               call matvec2(auxmat(1,1),b1(1,iti),
7929      &          AEAb1derx(1,lll,kkk,iii,1,1))
7930               call matvec2(auxmat(1,1),Ub2(1,i),
7931      &          AEAb2derx(1,lll,kkk,iii,1,1))
7932               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7933      &          AEAb1derx(1,lll,kkk,iii,2,1))
7934               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7935      &          AEAb2derx(1,lll,kkk,iii,2,1))
7936               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7937               call matvec2(auxmat(1,1),b1(1,itj),
7938      &          AEAb1derx(1,lll,kkk,iii,1,2))
7939               call matvec2(auxmat(1,1),Ub2(1,j),
7940      &          AEAb2derx(1,lll,kkk,iii,1,2))
7941               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7942      &          AEAb1derx(1,lll,kkk,iii,2,2))
7943               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7944      &          AEAb2derx(1,lll,kkk,iii,2,2))
7945             enddo
7946           enddo
7947         enddo
7948         ENDIF
7949 C End vectors
7950       else
7951 C Antiparallel orientation of the two CA-CA-CA frames.
7952         if (i.gt.1) then
7953           iti=itortyp(itype(i))
7954         else
7955           iti=ntortyp+1
7956         endif
7957         itk1=itortyp(itype(k+1))
7958         itl=itortyp(itype(l))
7959         itj=itortyp(itype(j))
7960         if (j.lt.nres-1) then
7961           itj1=itortyp(itype(j+1))
7962         else
7963           itj1=ntortyp+1
7964         endif
7965 C A2 kernel(j-1)T A1T
7966         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7967      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7968      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7969 C Following matrices are needed only for 6-th order cumulants
7970         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7971      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7972         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7973      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7974      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7975         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7976      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7977      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7978      &   ADtEAderx(1,1,1,1,1,1))
7979         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7980      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7981      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7982      &   ADtEA1derx(1,1,1,1,1,1))
7983         ENDIF
7984 C End 6-th order cumulants
7985         call transpose2(EUgder(1,1,k),auxmat(1,1))
7986         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7987         call transpose2(EUg(1,1,k),auxmat(1,1))
7988         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7989         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7990         do iii=1,2
7991           do kkk=1,5
7992             do lll=1,3
7993               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7994      &          EAEAderx(1,1,lll,kkk,iii,1))
7995             enddo
7996           enddo
7997         enddo
7998 C A2T kernel(i+1)T A1
7999         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8000      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
8001      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8002 C Following matrices are needed only for 6-th order cumulants
8003         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8004      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8005         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8006      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
8007      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8008         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8009      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
8010      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8011      &   ADtEAderx(1,1,1,1,1,2))
8012         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8013      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
8014      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8015      &   ADtEA1derx(1,1,1,1,1,2))
8016         ENDIF
8017 C End 6-th order cumulants
8018         call transpose2(EUgder(1,1,j),auxmat(1,1))
8019         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
8020         call transpose2(EUg(1,1,j),auxmat(1,1))
8021         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8022         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8023         do iii=1,2
8024           do kkk=1,5
8025             do lll=1,3
8026               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8027      &          EAEAderx(1,1,lll,kkk,iii,2))
8028             enddo
8029           enddo
8030         enddo
8031 C AEAb1 and AEAb2
8032 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8033 C They are needed only when the fifth- or the sixth-order cumulants are
8034 C indluded.
8035         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
8036      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
8037         call transpose2(AEA(1,1,1),auxmat(1,1))
8038         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
8039         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8040         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8041         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8042         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
8043         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8044         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
8045         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
8046         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8047         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8048         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8049         call transpose2(AEA(1,1,2),auxmat(1,1))
8050         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
8051         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
8052         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
8053         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8054         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
8055         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
8056         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
8057         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
8058         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
8059         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
8060         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
8061 C Calculate the Cartesian derivatives of the vectors.
8062         do iii=1,2
8063           do kkk=1,5
8064             do lll=1,3
8065               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8066               call matvec2(auxmat(1,1),b1(1,iti),
8067      &          AEAb1derx(1,lll,kkk,iii,1,1))
8068               call matvec2(auxmat(1,1),Ub2(1,i),
8069      &          AEAb2derx(1,lll,kkk,iii,1,1))
8070               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8071      &          AEAb1derx(1,lll,kkk,iii,2,1))
8072               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8073      &          AEAb2derx(1,lll,kkk,iii,2,1))
8074               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8075               call matvec2(auxmat(1,1),b1(1,itl),
8076      &          AEAb1derx(1,lll,kkk,iii,1,2))
8077               call matvec2(auxmat(1,1),Ub2(1,l),
8078      &          AEAb2derx(1,lll,kkk,iii,1,2))
8079               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
8080      &          AEAb1derx(1,lll,kkk,iii,2,2))
8081               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
8082      &          AEAb2derx(1,lll,kkk,iii,2,2))
8083             enddo
8084           enddo
8085         enddo
8086         ENDIF
8087 C End vectors
8088       endif
8089       return
8090       end
8091 C---------------------------------------------------------------------------
8092       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
8093      &  KK,KKderg,AKA,AKAderg,AKAderx)
8094       implicit none
8095       integer nderg
8096       logical transp
8097       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
8098      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
8099      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
8100       integer iii,kkk,lll
8101       integer jjj,mmm
8102       logical lprn
8103       common /kutas/ lprn
8104       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
8105       do iii=1,nderg
8106         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
8107      &    AKAderg(1,1,iii))
8108       enddo
8109 cd      if (lprn) write (2,*) 'In kernel'
8110       do kkk=1,5
8111 cd        if (lprn) write (2,*) 'kkk=',kkk
8112         do lll=1,3
8113           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
8114      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
8115 cd          if (lprn) then
8116 cd            write (2,*) 'lll=',lll
8117 cd            write (2,*) 'iii=1'
8118 cd            do jjj=1,2
8119 cd              write (2,'(3(2f10.5),5x)')
8120 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
8121 cd            enddo
8122 cd          endif
8123           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
8124      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
8125 cd          if (lprn) then
8126 cd            write (2,*) 'lll=',lll
8127 cd            write (2,*) 'iii=2'
8128 cd            do jjj=1,2
8129 cd              write (2,'(3(2f10.5),5x)')
8130 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
8131 cd            enddo
8132 cd          endif
8133         enddo
8134       enddo
8135       return
8136       end
8137 C---------------------------------------------------------------------------
8138       double precision function eello4(i,j,k,l,jj,kk)
8139       implicit real*8 (a-h,o-z)
8140       include 'DIMENSIONS'
8141       include 'COMMON.IOUNITS'
8142       include 'COMMON.CHAIN'
8143       include 'COMMON.DERIV'
8144       include 'COMMON.INTERACT'
8145       include 'COMMON.CONTACTS'
8146       include 'COMMON.TORSION'
8147       include 'COMMON.VAR'
8148       include 'COMMON.GEO'
8149       double precision pizda(2,2),ggg1(3),ggg2(3)
8150 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8151 cd        eello4=0.0d0
8152 cd        return
8153 cd      endif
8154 cd      print *,'eello4:',i,j,k,l,jj,kk
8155 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
8156 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
8157 cold      eij=facont_hb(jj,i)
8158 cold      ekl=facont_hb(kk,k)
8159 cold      ekont=eij*ekl
8160       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8161 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8162       gcorr_loc(k-1)=gcorr_loc(k-1)
8163      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8164       if (l.eq.j+1) then
8165         gcorr_loc(l-1)=gcorr_loc(l-1)
8166      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8167       else
8168         gcorr_loc(j-1)=gcorr_loc(j-1)
8169      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8170       endif
8171       do iii=1,2
8172         do kkk=1,5
8173           do lll=1,3
8174             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
8175      &                        -EAEAderx(2,2,lll,kkk,iii,1)
8176 cd            derx(lll,kkk,iii)=0.0d0
8177           enddo
8178         enddo
8179       enddo
8180 cd      gcorr_loc(l-1)=0.0d0
8181 cd      gcorr_loc(j-1)=0.0d0
8182 cd      gcorr_loc(k-1)=0.0d0
8183 cd      eel4=1.0d0
8184 cd      write (iout,*)'Contacts have occurred for peptide groups',
8185 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
8186 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8187       if (j.lt.nres-1) then
8188         j1=j+1
8189         j2=j-1
8190       else
8191         j1=j-1
8192         j2=j-2
8193       endif
8194       if (l.lt.nres-1) then
8195         l1=l+1
8196         l2=l-1
8197       else
8198         l1=l-1
8199         l2=l-2
8200       endif
8201       do ll=1,3
8202 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
8203 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
8204         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8205         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8206 cgrad        ghalf=0.5d0*ggg1(ll)
8207         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8208         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8209         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8210         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8211         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8212         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8213 cgrad        ghalf=0.5d0*ggg2(ll)
8214         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8215         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8216         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8217         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8218         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8219         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8220       enddo
8221 cgrad      do m=i+1,j-1
8222 cgrad        do ll=1,3
8223 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
8224 cgrad        enddo
8225 cgrad      enddo
8226 cgrad      do m=k+1,l-1
8227 cgrad        do ll=1,3
8228 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
8229 cgrad        enddo
8230 cgrad      enddo
8231 cgrad      do m=i+2,j2
8232 cgrad        do ll=1,3
8233 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8234 cgrad        enddo
8235 cgrad      enddo
8236 cgrad      do m=k+2,l2
8237 cgrad        do ll=1,3
8238 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8239 cgrad        enddo
8240 cgrad      enddo
8241 cd      do iii=1,nres-3
8242 cd        write (2,*) iii,gcorr_loc(iii)
8243 cd      enddo
8244       eello4=ekont*eel4
8245 cd      write (2,*) 'ekont',ekont
8246 cd      write (iout,*) 'eello4',ekont*eel4
8247       return
8248       end
8249 C---------------------------------------------------------------------------
8250       double precision function eello5(i,j,k,l,jj,kk)
8251       implicit real*8 (a-h,o-z)
8252       include 'DIMENSIONS'
8253       include 'COMMON.IOUNITS'
8254       include 'COMMON.CHAIN'
8255       include 'COMMON.DERIV'
8256       include 'COMMON.INTERACT'
8257       include 'COMMON.CONTACTS'
8258       include 'COMMON.TORSION'
8259       include 'COMMON.VAR'
8260       include 'COMMON.GEO'
8261       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
8262       double precision ggg1(3),ggg2(3)
8263 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8264 C                                                                              C
8265 C                            Parallel chains                                   C
8266 C                                                                              C
8267 C          o             o                   o             o                   C
8268 C         /l\           / \             \   / \           / \   /              C
8269 C        /   \         /   \             \ /   \         /   \ /               C
8270 C       j| o |l1       | o |              o| o |         | o |o                C
8271 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8272 C      \i/   \         /   \ /             /   \         /   \                 C
8273 C       o    k1             o                                                  C
8274 C         (I)          (II)                (III)          (IV)                 C
8275 C                                                                              C
8276 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8277 C                                                                              C
8278 C                            Antiparallel chains                               C
8279 C                                                                              C
8280 C          o             o                   o             o                   C
8281 C         /j\           / \             \   / \           / \   /              C
8282 C        /   \         /   \             \ /   \         /   \ /               C
8283 C      j1| o |l        | o |              o| o |         | o |o                C
8284 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8285 C      \i/   \         /   \ /             /   \         /   \                 C
8286 C       o     k1            o                                                  C
8287 C         (I)          (II)                (III)          (IV)                 C
8288 C                                                                              C
8289 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8290 C                                                                              C
8291 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
8292 C                                                                              C
8293 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8294 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8295 cd        eello5=0.0d0
8296 cd        return
8297 cd      endif
8298 cd      write (iout,*)
8299 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8300 cd     &   ' and',k,l
8301       itk=itortyp(itype(k))
8302       itl=itortyp(itype(l))
8303       itj=itortyp(itype(j))
8304       eello5_1=0.0d0
8305       eello5_2=0.0d0
8306       eello5_3=0.0d0
8307       eello5_4=0.0d0
8308 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8309 cd     &   eel5_3_num,eel5_4_num)
8310       do iii=1,2
8311         do kkk=1,5
8312           do lll=1,3
8313             derx(lll,kkk,iii)=0.0d0
8314           enddo
8315         enddo
8316       enddo
8317 cd      eij=facont_hb(jj,i)
8318 cd      ekl=facont_hb(kk,k)
8319 cd      ekont=eij*ekl
8320 cd      write (iout,*)'Contacts have occurred for peptide groups',
8321 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
8322 cd      goto 1111
8323 C Contribution from the graph I.
8324 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8325 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8326       call transpose2(EUg(1,1,k),auxmat(1,1))
8327       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8328       vv(1)=pizda(1,1)-pizda(2,2)
8329       vv(2)=pizda(1,2)+pizda(2,1)
8330       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
8331      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8332 C Explicit gradient in virtual-dihedral angles.
8333       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
8334      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
8335      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8336       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8337       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8338       vv(1)=pizda(1,1)-pizda(2,2)
8339       vv(2)=pizda(1,2)+pizda(2,1)
8340       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8341      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
8342      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8343       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8344       vv(1)=pizda(1,1)-pizda(2,2)
8345       vv(2)=pizda(1,2)+pizda(2,1)
8346       if (l.eq.j+1) then
8347         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
8348      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8349      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8350       else
8351         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
8352      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8353      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8354       endif
8355 C Cartesian gradient
8356       do iii=1,2
8357         do kkk=1,5
8358           do lll=1,3
8359             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
8360      &        pizda(1,1))
8361             vv(1)=pizda(1,1)-pizda(2,2)
8362             vv(2)=pizda(1,2)+pizda(2,1)
8363             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8364      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
8365      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8366           enddo
8367         enddo
8368       enddo
8369 c      goto 1112
8370 c1111  continue
8371 C Contribution from graph II
8372       call transpose2(EE(1,1,itk),auxmat(1,1))
8373       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8374       vv(1)=pizda(1,1)+pizda(2,2)
8375       vv(2)=pizda(2,1)-pizda(1,2)
8376       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
8377      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
8378 C Explicit gradient in virtual-dihedral angles.
8379       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8380      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8381       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8382       vv(1)=pizda(1,1)+pizda(2,2)
8383       vv(2)=pizda(2,1)-pizda(1,2)
8384       if (l.eq.j+1) then
8385         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8386      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
8387      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8388       else
8389         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8390      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
8391      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8392       endif
8393 C Cartesian gradient
8394       do iii=1,2
8395         do kkk=1,5
8396           do lll=1,3
8397             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8398      &        pizda(1,1))
8399             vv(1)=pizda(1,1)+pizda(2,2)
8400             vv(2)=pizda(2,1)-pizda(1,2)
8401             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8402      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
8403      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
8404           enddo
8405         enddo
8406       enddo
8407 cd      goto 1112
8408 cd1111  continue
8409       if (l.eq.j+1) then
8410 cd        goto 1110
8411 C Parallel orientation
8412 C Contribution from graph III
8413         call transpose2(EUg(1,1,l),auxmat(1,1))
8414         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8415         vv(1)=pizda(1,1)-pizda(2,2)
8416         vv(2)=pizda(1,2)+pizda(2,1)
8417         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
8418      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8419 C Explicit gradient in virtual-dihedral angles.
8420         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8421      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
8422      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8423         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8424         vv(1)=pizda(1,1)-pizda(2,2)
8425         vv(2)=pizda(1,2)+pizda(2,1)
8426         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8427      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
8428      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8429         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8430         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8431         vv(1)=pizda(1,1)-pizda(2,2)
8432         vv(2)=pizda(1,2)+pizda(2,1)
8433         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8434      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
8435      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8436 C Cartesian gradient
8437         do iii=1,2
8438           do kkk=1,5
8439             do lll=1,3
8440               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8441      &          pizda(1,1))
8442               vv(1)=pizda(1,1)-pizda(2,2)
8443               vv(2)=pizda(1,2)+pizda(2,1)
8444               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8445      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
8446      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8447             enddo
8448           enddo
8449         enddo
8450 cd        goto 1112
8451 C Contribution from graph IV
8452 cd1110    continue
8453         call transpose2(EE(1,1,itl),auxmat(1,1))
8454         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8455         vv(1)=pizda(1,1)+pizda(2,2)
8456         vv(2)=pizda(2,1)-pizda(1,2)
8457         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
8458      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
8459 C Explicit gradient in virtual-dihedral angles.
8460         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8461      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8462         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8463         vv(1)=pizda(1,1)+pizda(2,2)
8464         vv(2)=pizda(2,1)-pizda(1,2)
8465         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8466      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
8467      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8468 C Cartesian gradient
8469         do iii=1,2
8470           do kkk=1,5
8471             do lll=1,3
8472               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8473      &          pizda(1,1))
8474               vv(1)=pizda(1,1)+pizda(2,2)
8475               vv(2)=pizda(2,1)-pizda(1,2)
8476               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8477      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
8478      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
8479             enddo
8480           enddo
8481         enddo
8482       else
8483 C Antiparallel orientation
8484 C Contribution from graph III
8485 c        goto 1110
8486         call transpose2(EUg(1,1,j),auxmat(1,1))
8487         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8488         vv(1)=pizda(1,1)-pizda(2,2)
8489         vv(2)=pizda(1,2)+pizda(2,1)
8490         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
8491      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8492 C Explicit gradient in virtual-dihedral angles.
8493         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8494      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
8495      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8496         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8497         vv(1)=pizda(1,1)-pizda(2,2)
8498         vv(2)=pizda(1,2)+pizda(2,1)
8499         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8500      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
8501      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8502         call transpose2(EUgder(1,1,j),auxmat1(1,1))
8503         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8504         vv(1)=pizda(1,1)-pizda(2,2)
8505         vv(2)=pizda(1,2)+pizda(2,1)
8506         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8507      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
8508      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8509 C Cartesian gradient
8510         do iii=1,2
8511           do kkk=1,5
8512             do lll=1,3
8513               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8514      &          pizda(1,1))
8515               vv(1)=pizda(1,1)-pizda(2,2)
8516               vv(2)=pizda(1,2)+pizda(2,1)
8517               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8518      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
8519      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8520             enddo
8521           enddo
8522         enddo
8523 cd        goto 1112
8524 C Contribution from graph IV
8525 1110    continue
8526         call transpose2(EE(1,1,itj),auxmat(1,1))
8527         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8528         vv(1)=pizda(1,1)+pizda(2,2)
8529         vv(2)=pizda(2,1)-pizda(1,2)
8530         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
8531      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
8532 C Explicit gradient in virtual-dihedral angles.
8533         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8534      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
8535         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8536         vv(1)=pizda(1,1)+pizda(2,2)
8537         vv(2)=pizda(2,1)-pizda(1,2)
8538         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8539      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
8540      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
8541 C Cartesian gradient
8542         do iii=1,2
8543           do kkk=1,5
8544             do lll=1,3
8545               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8546      &          pizda(1,1))
8547               vv(1)=pizda(1,1)+pizda(2,2)
8548               vv(2)=pizda(2,1)-pizda(1,2)
8549               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8550      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
8551      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
8552             enddo
8553           enddo
8554         enddo
8555       endif
8556 1112  continue
8557       eel5=eello5_1+eello5_2+eello5_3+eello5_4
8558 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
8559 cd        write (2,*) 'ijkl',i,j,k,l
8560 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
8561 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
8562 cd      endif
8563 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
8564 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
8565 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
8566 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
8567       if (j.lt.nres-1) then
8568         j1=j+1
8569         j2=j-1
8570       else
8571         j1=j-1
8572         j2=j-2
8573       endif
8574       if (l.lt.nres-1) then
8575         l1=l+1
8576         l2=l-1
8577       else
8578         l1=l-1
8579         l2=l-2
8580       endif
8581 cd      eij=1.0d0
8582 cd      ekl=1.0d0
8583 cd      ekont=1.0d0
8584 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
8585 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
8586 C        summed up outside the subrouine as for the other subroutines
8587 C        handling long-range interactions. The old code is commented out
8588 C        with "cgrad" to keep track of changes.
8589       do ll=1,3
8590 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
8591 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
8592         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
8593         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
8594 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
8595 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
8596 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
8597 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
8598 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
8599 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
8600 c     &   gradcorr5ij,
8601 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
8602 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
8603 cgrad        ghalf=0.5d0*ggg1(ll)
8604 cd        ghalf=0.0d0
8605         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
8606         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
8607         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
8608         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
8609         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
8610         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
8611 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
8612 cgrad        ghalf=0.5d0*ggg2(ll)
8613 cd        ghalf=0.0d0
8614         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
8615         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
8616         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
8617         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
8618         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
8619         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
8620       enddo
8621 cd      goto 1112
8622 cgrad      do m=i+1,j-1
8623 cgrad        do ll=1,3
8624 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
8625 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
8626 cgrad        enddo
8627 cgrad      enddo
8628 cgrad      do m=k+1,l-1
8629 cgrad        do ll=1,3
8630 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
8631 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
8632 cgrad        enddo
8633 cgrad      enddo
8634 c1112  continue
8635 cgrad      do m=i+2,j2
8636 cgrad        do ll=1,3
8637 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
8638 cgrad        enddo
8639 cgrad      enddo
8640 cgrad      do m=k+2,l2
8641 cgrad        do ll=1,3
8642 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
8643 cgrad        enddo
8644 cgrad      enddo
8645 cd      do iii=1,nres-3
8646 cd        write (2,*) iii,g_corr5_loc(iii)
8647 cd      enddo
8648       eello5=ekont*eel5
8649 cd      write (2,*) 'ekont',ekont
8650 cd      write (iout,*) 'eello5',ekont*eel5
8651       return
8652       end
8653 c--------------------------------------------------------------------------
8654       double precision function eello6(i,j,k,l,jj,kk)
8655       implicit real*8 (a-h,o-z)
8656       include 'DIMENSIONS'
8657       include 'COMMON.IOUNITS'
8658       include 'COMMON.CHAIN'
8659       include 'COMMON.DERIV'
8660       include 'COMMON.INTERACT'
8661       include 'COMMON.CONTACTS'
8662       include 'COMMON.TORSION'
8663       include 'COMMON.VAR'
8664       include 'COMMON.GEO'
8665       include 'COMMON.FFIELD'
8666       double precision ggg1(3),ggg2(3)
8667 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8668 cd        eello6=0.0d0
8669 cd        return
8670 cd      endif
8671 cd      write (iout,*)
8672 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8673 cd     &   ' and',k,l
8674       eello6_1=0.0d0
8675       eello6_2=0.0d0
8676       eello6_3=0.0d0
8677       eello6_4=0.0d0
8678       eello6_5=0.0d0
8679       eello6_6=0.0d0
8680 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8681 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8682       do iii=1,2
8683         do kkk=1,5
8684           do lll=1,3
8685             derx(lll,kkk,iii)=0.0d0
8686           enddo
8687         enddo
8688       enddo
8689 cd      eij=facont_hb(jj,i)
8690 cd      ekl=facont_hb(kk,k)
8691 cd      ekont=eij*ekl
8692 cd      eij=1.0d0
8693 cd      ekl=1.0d0
8694 cd      ekont=1.0d0
8695       if (l.eq.j+1) then
8696         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8697         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8698         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8699         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8700         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8701         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8702       else
8703         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8704         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8705         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8706         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8707         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8708           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8709         else
8710           eello6_5=0.0d0
8711         endif
8712         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8713       endif
8714 C If turn contributions are considered, they will be handled separately.
8715       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8716 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8717 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8718 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8719 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8720 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8721 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8722 cd      goto 1112
8723       if (j.lt.nres-1) then
8724         j1=j+1
8725         j2=j-1
8726       else
8727         j1=j-1
8728         j2=j-2
8729       endif
8730       if (l.lt.nres-1) then
8731         l1=l+1
8732         l2=l-1
8733       else
8734         l1=l-1
8735         l2=l-2
8736       endif
8737       do ll=1,3
8738 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8739 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8740 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8741 cgrad        ghalf=0.5d0*ggg1(ll)
8742 cd        ghalf=0.0d0
8743         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8744         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8745         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8746         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8747         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8748         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8749         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8750         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8751 cgrad        ghalf=0.5d0*ggg2(ll)
8752 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8753 cd        ghalf=0.0d0
8754         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8755         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8756         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8757         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8758         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8759         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8760       enddo
8761 cd      goto 1112
8762 cgrad      do m=i+1,j-1
8763 cgrad        do ll=1,3
8764 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8765 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8766 cgrad        enddo
8767 cgrad      enddo
8768 cgrad      do m=k+1,l-1
8769 cgrad        do ll=1,3
8770 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8771 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8772 cgrad        enddo
8773 cgrad      enddo
8774 cgrad1112  continue
8775 cgrad      do m=i+2,j2
8776 cgrad        do ll=1,3
8777 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8778 cgrad        enddo
8779 cgrad      enddo
8780 cgrad      do m=k+2,l2
8781 cgrad        do ll=1,3
8782 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8783 cgrad        enddo
8784 cgrad      enddo
8785 cd      do iii=1,nres-3
8786 cd        write (2,*) iii,g_corr6_loc(iii)
8787 cd      enddo
8788       eello6=ekont*eel6
8789 cd      write (2,*) 'ekont',ekont
8790 cd      write (iout,*) 'eello6',ekont*eel6
8791       return
8792       end
8793 c--------------------------------------------------------------------------
8794       double precision function eello6_graph1(i,j,k,l,imat,swap)
8795       implicit real*8 (a-h,o-z)
8796       include 'DIMENSIONS'
8797       include 'COMMON.IOUNITS'
8798       include 'COMMON.CHAIN'
8799       include 'COMMON.DERIV'
8800       include 'COMMON.INTERACT'
8801       include 'COMMON.CONTACTS'
8802       include 'COMMON.TORSION'
8803       include 'COMMON.VAR'
8804       include 'COMMON.GEO'
8805       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8806       logical swap
8807       logical lprn
8808       common /kutas/ lprn
8809 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8810 C
8811 C      Parallel       Antiparallel
8812 C
8813 C          o             o
8814 C         /l\           /j\
8815 C        /   \         /   \
8816 C       /| o |         | o |\
8817 C     \ j|/k\|  /   \  |/k\|l /
8818 C      \ /   \ /     \ /   \ /
8819 C       o     o       o     o
8820 C       i             i
8821 C
8822 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8823       itk=itortyp(itype(k))
8824       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8825       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8826       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8827       call transpose2(EUgC(1,1,k),auxmat(1,1))
8828       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8829       vv1(1)=pizda1(1,1)-pizda1(2,2)
8830       vv1(2)=pizda1(1,2)+pizda1(2,1)
8831       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8832       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8833       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8834       s5=scalar2(vv(1),Dtobr2(1,i))
8835 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8836       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8837       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8838      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8839      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8840      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8841      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8842      & +scalar2(vv(1),Dtobr2der(1,i)))
8843       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8844       vv1(1)=pizda1(1,1)-pizda1(2,2)
8845       vv1(2)=pizda1(1,2)+pizda1(2,1)
8846       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8847       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8848       if (l.eq.j+1) then
8849         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8850      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8851      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8852      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8853      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8854       else
8855         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8856      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8857      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8858      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8859      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8860       endif
8861       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8862       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8863       vv1(1)=pizda1(1,1)-pizda1(2,2)
8864       vv1(2)=pizda1(1,2)+pizda1(2,1)
8865       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8866      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8867      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8868      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8869       do iii=1,2
8870         if (swap) then
8871           ind=3-iii
8872         else
8873           ind=iii
8874         endif
8875         do kkk=1,5
8876           do lll=1,3
8877             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8878             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8879             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8880             call transpose2(EUgC(1,1,k),auxmat(1,1))
8881             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8882      &        pizda1(1,1))
8883             vv1(1)=pizda1(1,1)-pizda1(2,2)
8884             vv1(2)=pizda1(1,2)+pizda1(2,1)
8885             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8886             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8887      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8888             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8889      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8890             s5=scalar2(vv(1),Dtobr2(1,i))
8891             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8892           enddo
8893         enddo
8894       enddo
8895       return
8896       end
8897 c----------------------------------------------------------------------------
8898       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8899       implicit real*8 (a-h,o-z)
8900       include 'DIMENSIONS'
8901       include 'COMMON.IOUNITS'
8902       include 'COMMON.CHAIN'
8903       include 'COMMON.DERIV'
8904       include 'COMMON.INTERACT'
8905       include 'COMMON.CONTACTS'
8906       include 'COMMON.TORSION'
8907       include 'COMMON.VAR'
8908       include 'COMMON.GEO'
8909       logical swap
8910       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8911      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8912       logical lprn
8913       common /kutas/ lprn
8914 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8915 C                                                                              C
8916 C      Parallel       Antiparallel                                             C
8917 C                                                                              C
8918 C          o             o                                                     C
8919 C     \   /l\           /j\   /                                                C
8920 C      \ /   \         /   \ /                                                 C
8921 C       o| o |         | o |o                                                  C
8922 C     \ j|/k\|      \  |/k\|l                                                  C
8923 C      \ /   \       \ /   \                                                   C
8924 C       o             o                                                        C
8925 C       i             i                                                        C
8926 C                                                                              C
8927 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8928 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8929 C AL 7/4/01 s1 would occur in the sixth-order moment,
8930 C           but not in a cluster cumulant
8931 #ifdef MOMENT
8932       s1=dip(1,jj,i)*dip(1,kk,k)
8933 #endif
8934       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8935       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8936       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8937       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8938       call transpose2(EUg(1,1,k),auxmat(1,1))
8939       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8940       vv(1)=pizda(1,1)-pizda(2,2)
8941       vv(2)=pizda(1,2)+pizda(2,1)
8942       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8943 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8944 #ifdef MOMENT
8945       eello6_graph2=-(s1+s2+s3+s4)
8946 #else
8947       eello6_graph2=-(s2+s3+s4)
8948 #endif
8949 c      eello6_graph2=-s3
8950 C Derivatives in gamma(i-1)
8951       if (i.gt.1) then
8952 #ifdef MOMENT
8953         s1=dipderg(1,jj,i)*dip(1,kk,k)
8954 #endif
8955         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8956         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8957         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8958         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8959 #ifdef MOMENT
8960         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8961 #else
8962         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8963 #endif
8964 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8965       endif
8966 C Derivatives in gamma(k-1)
8967 #ifdef MOMENT
8968       s1=dip(1,jj,i)*dipderg(1,kk,k)
8969 #endif
8970       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8971       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8972       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8973       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8974       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8975       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8976       vv(1)=pizda(1,1)-pizda(2,2)
8977       vv(2)=pizda(1,2)+pizda(2,1)
8978       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8979 #ifdef MOMENT
8980       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8981 #else
8982       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8983 #endif
8984 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8985 C Derivatives in gamma(j-1) or gamma(l-1)
8986       if (j.gt.1) then
8987 #ifdef MOMENT
8988         s1=dipderg(3,jj,i)*dip(1,kk,k)
8989 #endif
8990         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8991         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8992         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8993         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8994         vv(1)=pizda(1,1)-pizda(2,2)
8995         vv(2)=pizda(1,2)+pizda(2,1)
8996         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8997 #ifdef MOMENT
8998         if (swap) then
8999           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9000         else
9001           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9002         endif
9003 #endif
9004         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
9005 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
9006       endif
9007 C Derivatives in gamma(l-1) or gamma(j-1)
9008       if (l.gt.1) then
9009 #ifdef MOMENT
9010         s1=dip(1,jj,i)*dipderg(3,kk,k)
9011 #endif
9012         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
9013         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9014         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
9015         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9016         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
9017         vv(1)=pizda(1,1)-pizda(2,2)
9018         vv(2)=pizda(1,2)+pizda(2,1)
9019         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9020 #ifdef MOMENT
9021         if (swap) then
9022           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9023         else
9024           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9025         endif
9026 #endif
9027         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
9028 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
9029       endif
9030 C Cartesian derivatives.
9031       if (lprn) then
9032         write (2,*) 'In eello6_graph2'
9033         do iii=1,2
9034           write (2,*) 'iii=',iii
9035           do kkk=1,5
9036             write (2,*) 'kkk=',kkk
9037             do jjj=1,2
9038               write (2,'(3(2f10.5),5x)')
9039      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9040             enddo
9041           enddo
9042         enddo
9043       endif
9044       do iii=1,2
9045         do kkk=1,5
9046           do lll=1,3
9047 #ifdef MOMENT
9048             if (iii.eq.1) then
9049               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
9050             else
9051               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
9052             endif
9053 #endif
9054             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
9055      &        auxvec(1))
9056             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9057             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
9058      &        auxvec(1))
9059             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
9060             call transpose2(EUg(1,1,k),auxmat(1,1))
9061             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
9062      &        pizda(1,1))
9063             vv(1)=pizda(1,1)-pizda(2,2)
9064             vv(2)=pizda(1,2)+pizda(2,1)
9065             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9066 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
9067 #ifdef MOMENT
9068             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9069 #else
9070             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9071 #endif
9072             if (swap) then
9073               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9074             else
9075               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9076             endif
9077           enddo
9078         enddo
9079       enddo
9080       return
9081       end
9082 c----------------------------------------------------------------------------
9083       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
9084       implicit real*8 (a-h,o-z)
9085       include 'DIMENSIONS'
9086       include 'COMMON.IOUNITS'
9087       include 'COMMON.CHAIN'
9088       include 'COMMON.DERIV'
9089       include 'COMMON.INTERACT'
9090       include 'COMMON.CONTACTS'
9091       include 'COMMON.TORSION'
9092       include 'COMMON.VAR'
9093       include 'COMMON.GEO'
9094       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
9095       logical swap
9096 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9097 C                                                                              C
9098 C      Parallel       Antiparallel                                             C
9099 C                                                                              C
9100 C          o             o                                                     C
9101 C         /l\   /   \   /j\                                                    C
9102 C        /   \ /     \ /   \                                                   C
9103 C       /| o |o       o| o |\                                                  C
9104 C       j|/k\|  /      |/k\|l /                                                C
9105 C        /   \ /       /   \ /                                                 C
9106 C       /     o       /     o                                                  C
9107 C       i             i                                                        C
9108 C                                                                              C
9109 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9110 C
9111 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9112 C           energy moment and not to the cluster cumulant.
9113       iti=itortyp(itype(i))
9114       if (j.lt.nres-1) then
9115         itj1=itortyp(itype(j+1))
9116       else
9117         itj1=ntortyp+1
9118       endif
9119       itk=itortyp(itype(k))
9120       itk1=itortyp(itype(k+1))
9121       if (l.lt.nres-1) then
9122         itl1=itortyp(itype(l+1))
9123       else
9124         itl1=ntortyp+1
9125       endif
9126 #ifdef MOMENT
9127       s1=dip(4,jj,i)*dip(4,kk,k)
9128 #endif
9129       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
9130       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9131       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
9132       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9133       call transpose2(EE(1,1,itk),auxmat(1,1))
9134       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
9135       vv(1)=pizda(1,1)+pizda(2,2)
9136       vv(2)=pizda(2,1)-pizda(1,2)
9137       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9138 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9139 cd     & "sum",-(s2+s3+s4)
9140 #ifdef MOMENT
9141       eello6_graph3=-(s1+s2+s3+s4)
9142 #else
9143       eello6_graph3=-(s2+s3+s4)
9144 #endif
9145 c      eello6_graph3=-s4
9146 C Derivatives in gamma(k-1)
9147       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
9148       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9149       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9150       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9151 C Derivatives in gamma(l-1)
9152       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
9153       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9154       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9155       vv(1)=pizda(1,1)+pizda(2,2)
9156       vv(2)=pizda(2,1)-pizda(1,2)
9157       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9158       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9159 C Cartesian derivatives.
9160       do iii=1,2
9161         do kkk=1,5
9162           do lll=1,3
9163 #ifdef MOMENT
9164             if (iii.eq.1) then
9165               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9166             else
9167               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9168             endif
9169 #endif
9170             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
9171      &        auxvec(1))
9172             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9173             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
9174      &        auxvec(1))
9175             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9176             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
9177      &        pizda(1,1))
9178             vv(1)=pizda(1,1)+pizda(2,2)
9179             vv(2)=pizda(2,1)-pizda(1,2)
9180             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9181 #ifdef MOMENT
9182             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9183 #else
9184             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9185 #endif
9186             if (swap) then
9187               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9188             else
9189               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9190             endif
9191 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9192           enddo
9193         enddo
9194       enddo
9195       return
9196       end
9197 c----------------------------------------------------------------------------
9198       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
9199       implicit real*8 (a-h,o-z)
9200       include 'DIMENSIONS'
9201       include 'COMMON.IOUNITS'
9202       include 'COMMON.CHAIN'
9203       include 'COMMON.DERIV'
9204       include 'COMMON.INTERACT'
9205       include 'COMMON.CONTACTS'
9206       include 'COMMON.TORSION'
9207       include 'COMMON.VAR'
9208       include 'COMMON.GEO'
9209       include 'COMMON.FFIELD'
9210       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9211      & auxvec1(2),auxmat1(2,2)
9212       logical swap
9213 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9214 C                                                                              C
9215 C      Parallel       Antiparallel                                             C
9216 C                                                                              C
9217 C          o             o                                                     C
9218 C         /l\   /   \   /j\                                                    C
9219 C        /   \ /     \ /   \                                                   C
9220 C       /| o |o       o| o |\                                                  C
9221 C     \ j|/k\|      \  |/k\|l                                                  C
9222 C      \ /   \       \ /   \                                                   C
9223 C       o     \       o     \                                                  C
9224 C       i             i                                                        C
9225 C                                                                              C
9226 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9227 C
9228 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9229 C           energy moment and not to the cluster cumulant.
9230 cd      write (2,*) 'eello_graph4: wturn6',wturn6
9231       iti=itortyp(itype(i))
9232       itj=itortyp(itype(j))
9233       if (j.lt.nres-1) then
9234         itj1=itortyp(itype(j+1))
9235       else
9236         itj1=ntortyp+1
9237       endif
9238       itk=itortyp(itype(k))
9239       if (k.lt.nres-1) then
9240         itk1=itortyp(itype(k+1))
9241       else
9242         itk1=ntortyp+1
9243       endif
9244       itl=itortyp(itype(l))
9245       if (l.lt.nres-1) then
9246         itl1=itortyp(itype(l+1))
9247       else
9248         itl1=ntortyp+1
9249       endif
9250 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9251 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9252 cd     & ' itl',itl,' itl1',itl1
9253 #ifdef MOMENT
9254       if (imat.eq.1) then
9255         s1=dip(3,jj,i)*dip(3,kk,k)
9256       else
9257         s1=dip(2,jj,j)*dip(2,kk,l)
9258       endif
9259 #endif
9260       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9261       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9262       if (j.eq.l+1) then
9263         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
9264         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9265       else
9266         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
9267         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9268       endif
9269       call transpose2(EUg(1,1,k),auxmat(1,1))
9270       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9271       vv(1)=pizda(1,1)-pizda(2,2)
9272       vv(2)=pizda(2,1)+pizda(1,2)
9273       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9274 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9275 #ifdef MOMENT
9276       eello6_graph4=-(s1+s2+s3+s4)
9277 #else
9278       eello6_graph4=-(s2+s3+s4)
9279 #endif
9280 C Derivatives in gamma(i-1)
9281       if (i.gt.1) then
9282 #ifdef MOMENT
9283         if (imat.eq.1) then
9284           s1=dipderg(2,jj,i)*dip(3,kk,k)
9285         else
9286           s1=dipderg(4,jj,j)*dip(2,kk,l)
9287         endif
9288 #endif
9289         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9290         if (j.eq.l+1) then
9291           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
9292           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9293         else
9294           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
9295           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9296         endif
9297         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9298         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9299 cd          write (2,*) 'turn6 derivatives'
9300 #ifdef MOMENT
9301           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9302 #else
9303           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9304 #endif
9305         else
9306 #ifdef MOMENT
9307           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9308 #else
9309           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9310 #endif
9311         endif
9312       endif
9313 C Derivatives in gamma(k-1)
9314 #ifdef MOMENT
9315       if (imat.eq.1) then
9316         s1=dip(3,jj,i)*dipderg(2,kk,k)
9317       else
9318         s1=dip(2,jj,j)*dipderg(4,kk,l)
9319       endif
9320 #endif
9321       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9322       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9323       if (j.eq.l+1) then
9324         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
9325         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9326       else
9327         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
9328         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9329       endif
9330       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9331       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9332       vv(1)=pizda(1,1)-pizda(2,2)
9333       vv(2)=pizda(2,1)+pizda(1,2)
9334       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9335       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9336 #ifdef MOMENT
9337         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9338 #else
9339         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9340 #endif
9341       else
9342 #ifdef MOMENT
9343         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9344 #else
9345         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9346 #endif
9347       endif
9348 C Derivatives in gamma(j-1) or gamma(l-1)
9349       if (l.eq.j+1 .and. l.gt.1) then
9350         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9351         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9352         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9353         vv(1)=pizda(1,1)-pizda(2,2)
9354         vv(2)=pizda(2,1)+pizda(1,2)
9355         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9356         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9357       else if (j.gt.1) then
9358         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9359         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9360         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9361         vv(1)=pizda(1,1)-pizda(2,2)
9362         vv(2)=pizda(2,1)+pizda(1,2)
9363         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9364         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9365           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9366         else
9367           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9368         endif
9369       endif
9370 C Cartesian derivatives.
9371       do iii=1,2
9372         do kkk=1,5
9373           do lll=1,3
9374 #ifdef MOMENT
9375             if (iii.eq.1) then
9376               if (imat.eq.1) then
9377                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9378               else
9379                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9380               endif
9381             else
9382               if (imat.eq.1) then
9383                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9384               else
9385                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9386               endif
9387             endif
9388 #endif
9389             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
9390      &        auxvec(1))
9391             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9392             if (j.eq.l+1) then
9393               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9394      &          b1(1,itj1),auxvec(1))
9395               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
9396             else
9397               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9398      &          b1(1,itl1),auxvec(1))
9399               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
9400             endif
9401             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9402      &        pizda(1,1))
9403             vv(1)=pizda(1,1)-pizda(2,2)
9404             vv(2)=pizda(2,1)+pizda(1,2)
9405             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9406             if (swap) then
9407               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9408 #ifdef MOMENT
9409                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9410      &             -(s1+s2+s4)
9411 #else
9412                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9413      &             -(s2+s4)
9414 #endif
9415                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9416               else
9417 #ifdef MOMENT
9418                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9419 #else
9420                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9421 #endif
9422                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9423               endif
9424             else
9425 #ifdef MOMENT
9426               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9427 #else
9428               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9429 #endif
9430               if (l.eq.j+1) then
9431                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9432               else
9433                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9434               endif
9435             endif
9436           enddo
9437         enddo
9438       enddo
9439       return
9440       end
9441 c----------------------------------------------------------------------------
9442       double precision function eello_turn6(i,jj,kk)
9443       implicit real*8 (a-h,o-z)
9444       include 'DIMENSIONS'
9445       include 'COMMON.IOUNITS'
9446       include 'COMMON.CHAIN'
9447       include 'COMMON.DERIV'
9448       include 'COMMON.INTERACT'
9449       include 'COMMON.CONTACTS'
9450       include 'COMMON.TORSION'
9451       include 'COMMON.VAR'
9452       include 'COMMON.GEO'
9453       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
9454      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
9455      &  ggg1(3),ggg2(3)
9456       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
9457      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
9458 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9459 C           the respective energy moment and not to the cluster cumulant.
9460       s1=0.0d0
9461       s8=0.0d0
9462       s13=0.0d0
9463 c
9464       eello_turn6=0.0d0
9465       j=i+4
9466       k=i+1
9467       l=i+3
9468       iti=itortyp(itype(i))
9469       itk=itortyp(itype(k))
9470       itk1=itortyp(itype(k+1))
9471       itl=itortyp(itype(l))
9472       itj=itortyp(itype(j))
9473 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9474 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
9475 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9476 cd        eello6=0.0d0
9477 cd        return
9478 cd      endif
9479 cd      write (iout,*)
9480 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9481 cd     &   ' and',k,l
9482 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
9483       do iii=1,2
9484         do kkk=1,5
9485           do lll=1,3
9486             derx_turn(lll,kkk,iii)=0.0d0
9487           enddo
9488         enddo
9489       enddo
9490 cd      eij=1.0d0
9491 cd      ekl=1.0d0
9492 cd      ekont=1.0d0
9493       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9494 cd      eello6_5=0.0d0
9495 cd      write (2,*) 'eello6_5',eello6_5
9496 #ifdef MOMENT
9497       call transpose2(AEA(1,1,1),auxmat(1,1))
9498       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
9499       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
9500       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
9501 #endif
9502       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9503       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
9504       s2 = scalar2(b1(1,itk),vtemp1(1))
9505 #ifdef MOMENT
9506       call transpose2(AEA(1,1,2),atemp(1,1))
9507       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
9508       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
9509       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9510 #endif
9511       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
9512       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
9513       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
9514 #ifdef MOMENT
9515       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
9516       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
9517       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
9518       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
9519       ss13 = scalar2(b1(1,itk),vtemp4(1))
9520       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
9521 #endif
9522 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
9523 c      s1=0.0d0
9524 c      s2=0.0d0
9525 c      s8=0.0d0
9526 c      s12=0.0d0
9527 c      s13=0.0d0
9528       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
9529 C Derivatives in gamma(i+2)
9530       s1d =0.0d0
9531       s8d =0.0d0
9532 #ifdef MOMENT
9533       call transpose2(AEA(1,1,1),auxmatd(1,1))
9534       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9535       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9536       call transpose2(AEAderg(1,1,2),atempd(1,1))
9537       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9538       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9539 #endif
9540       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
9541       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9542       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9543 c      s1d=0.0d0
9544 c      s2d=0.0d0
9545 c      s8d=0.0d0
9546 c      s12d=0.0d0
9547 c      s13d=0.0d0
9548       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
9549 C Derivatives in gamma(i+3)
9550 #ifdef MOMENT
9551       call transpose2(AEA(1,1,1),auxmatd(1,1))
9552       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9553       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
9554       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
9555 #endif
9556       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
9557       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
9558       s2d = scalar2(b1(1,itk),vtemp1d(1))
9559 #ifdef MOMENT
9560       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
9561       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
9562 #endif
9563       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
9564 #ifdef MOMENT
9565       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
9566       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9567       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9568 #endif
9569 c      s1d=0.0d0
9570 c      s2d=0.0d0
9571 c      s8d=0.0d0
9572 c      s12d=0.0d0
9573 c      s13d=0.0d0
9574 #ifdef MOMENT
9575       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9576      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9577 #else
9578       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9579      &               -0.5d0*ekont*(s2d+s12d)
9580 #endif
9581 C Derivatives in gamma(i+4)
9582       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
9583       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9584       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9585 #ifdef MOMENT
9586       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
9587       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
9588       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9589 #endif
9590 c      s1d=0.0d0
9591 c      s2d=0.0d0
9592 c      s8d=0.0d0
9593 C      s12d=0.0d0
9594 c      s13d=0.0d0
9595 #ifdef MOMENT
9596       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
9597 #else
9598       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
9599 #endif
9600 C Derivatives in gamma(i+5)
9601 #ifdef MOMENT
9602       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
9603       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9604       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9605 #endif
9606       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
9607       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
9608       s2d = scalar2(b1(1,itk),vtemp1d(1))
9609 #ifdef MOMENT
9610       call transpose2(AEA(1,1,2),atempd(1,1))
9611       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
9612       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9613 #endif
9614       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
9615       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9616 #ifdef MOMENT
9617       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
9618       ss13d = scalar2(b1(1,itk),vtemp4d(1))
9619       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9620 #endif
9621 c      s1d=0.0d0
9622 c      s2d=0.0d0
9623 c      s8d=0.0d0
9624 c      s12d=0.0d0
9625 c      s13d=0.0d0
9626 #ifdef MOMENT
9627       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9628      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9629 #else
9630       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9631      &               -0.5d0*ekont*(s2d+s12d)
9632 #endif
9633 C Cartesian derivatives
9634       do iii=1,2
9635         do kkk=1,5
9636           do lll=1,3
9637 #ifdef MOMENT
9638             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
9639             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9640             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9641 #endif
9642             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9643             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
9644      &          vtemp1d(1))
9645             s2d = scalar2(b1(1,itk),vtemp1d(1))
9646 #ifdef MOMENT
9647             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
9648             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9649             s8d = -(atempd(1,1)+atempd(2,2))*
9650      &           scalar2(cc(1,1,itl),vtemp2(1))
9651 #endif
9652             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
9653      &           auxmatd(1,1))
9654             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9655             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9656 c      s1d=0.0d0
9657 c      s2d=0.0d0
9658 c      s8d=0.0d0
9659 c      s12d=0.0d0
9660 c      s13d=0.0d0
9661 #ifdef MOMENT
9662             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9663      &        - 0.5d0*(s1d+s2d)
9664 #else
9665             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9666      &        - 0.5d0*s2d
9667 #endif
9668 #ifdef MOMENT
9669             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9670      &        - 0.5d0*(s8d+s12d)
9671 #else
9672             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9673      &        - 0.5d0*s12d
9674 #endif
9675           enddo
9676         enddo
9677       enddo
9678 #ifdef MOMENT
9679       do kkk=1,5
9680         do lll=1,3
9681           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9682      &      achuj_tempd(1,1))
9683           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9684           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9685           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9686           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9687           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9688      &      vtemp4d(1))
9689           ss13d = scalar2(b1(1,itk),vtemp4d(1))
9690           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9691           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9692         enddo
9693       enddo
9694 #endif
9695 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9696 cd     &  16*eel_turn6_num
9697 cd      goto 1112
9698       if (j.lt.nres-1) then
9699         j1=j+1
9700         j2=j-1
9701       else
9702         j1=j-1
9703         j2=j-2
9704       endif
9705       if (l.lt.nres-1) then
9706         l1=l+1
9707         l2=l-1
9708       else
9709         l1=l-1
9710         l2=l-2
9711       endif
9712       do ll=1,3
9713 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9714 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9715 cgrad        ghalf=0.5d0*ggg1(ll)
9716 cd        ghalf=0.0d0
9717         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9718         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9719         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9720      &    +ekont*derx_turn(ll,2,1)
9721         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9722         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9723      &    +ekont*derx_turn(ll,4,1)
9724         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9725         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9726         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9727 cgrad        ghalf=0.5d0*ggg2(ll)
9728 cd        ghalf=0.0d0
9729         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9730      &    +ekont*derx_turn(ll,2,2)
9731         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9732         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9733      &    +ekont*derx_turn(ll,4,2)
9734         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9735         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9736         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9737       enddo
9738 cd      goto 1112
9739 cgrad      do m=i+1,j-1
9740 cgrad        do ll=1,3
9741 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9742 cgrad        enddo
9743 cgrad      enddo
9744 cgrad      do m=k+1,l-1
9745 cgrad        do ll=1,3
9746 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9747 cgrad        enddo
9748 cgrad      enddo
9749 cgrad1112  continue
9750 cgrad      do m=i+2,j2
9751 cgrad        do ll=1,3
9752 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9753 cgrad        enddo
9754 cgrad      enddo
9755 cgrad      do m=k+2,l2
9756 cgrad        do ll=1,3
9757 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9758 cgrad        enddo
9759 cgrad      enddo
9760 cd      do iii=1,nres-3
9761 cd        write (2,*) iii,g_corr6_loc(iii)
9762 cd      enddo
9763       eello_turn6=ekont*eel_turn6
9764 cd      write (2,*) 'ekont',ekont
9765 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9766       return
9767       end
9768
9769 C-----------------------------------------------------------------------------
9770       double precision function scalar(u,v)
9771 !DIR$ INLINEALWAYS scalar
9772 #ifndef OSF
9773 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9774 #endif
9775       implicit none
9776       double precision u(3),v(3)
9777 cd      double precision sc
9778 cd      integer i
9779 cd      sc=0.0d0
9780 cd      do i=1,3
9781 cd        sc=sc+u(i)*v(i)
9782 cd      enddo
9783 cd      scalar=sc
9784
9785       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9786       return
9787       end
9788 crc-------------------------------------------------
9789       SUBROUTINE MATVEC2(A1,V1,V2)
9790 !DIR$ INLINEALWAYS MATVEC2
9791 #ifndef OSF
9792 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9793 #endif
9794       implicit real*8 (a-h,o-z)
9795       include 'DIMENSIONS'
9796       DIMENSION A1(2,2),V1(2),V2(2)
9797 c      DO 1 I=1,2
9798 c        VI=0.0
9799 c        DO 3 K=1,2
9800 c    3     VI=VI+A1(I,K)*V1(K)
9801 c        Vaux(I)=VI
9802 c    1 CONTINUE
9803
9804       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9805       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9806
9807       v2(1)=vaux1
9808       v2(2)=vaux2
9809       END
9810 C---------------------------------------
9811       SUBROUTINE MATMAT2(A1,A2,A3)
9812 #ifndef OSF
9813 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9814 #endif
9815       implicit real*8 (a-h,o-z)
9816       include 'DIMENSIONS'
9817       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9818 c      DIMENSION AI3(2,2)
9819 c        DO  J=1,2
9820 c          A3IJ=0.0
9821 c          DO K=1,2
9822 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9823 c          enddo
9824 c          A3(I,J)=A3IJ
9825 c       enddo
9826 c      enddo
9827
9828       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9829       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9830       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9831       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9832
9833       A3(1,1)=AI3_11
9834       A3(2,1)=AI3_21
9835       A3(1,2)=AI3_12
9836       A3(2,2)=AI3_22
9837       END
9838
9839 c-------------------------------------------------------------------------
9840       double precision function scalar2(u,v)
9841 !DIR$ INLINEALWAYS scalar2
9842       implicit none
9843       double precision u(2),v(2)
9844       double precision sc
9845       integer i
9846       scalar2=u(1)*v(1)+u(2)*v(2)
9847       return
9848       end
9849
9850 C-----------------------------------------------------------------------------
9851
9852       subroutine transpose2(a,at)
9853 !DIR$ INLINEALWAYS transpose2
9854 #ifndef OSF
9855 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9856 #endif
9857       implicit none
9858       double precision a(2,2),at(2,2)
9859       at(1,1)=a(1,1)
9860       at(1,2)=a(2,1)
9861       at(2,1)=a(1,2)
9862       at(2,2)=a(2,2)
9863       return
9864       end
9865 c--------------------------------------------------------------------------
9866       subroutine transpose(n,a,at)
9867       implicit none
9868       integer n,i,j
9869       double precision a(n,n),at(n,n)
9870       do i=1,n
9871         do j=1,n
9872           at(j,i)=a(i,j)
9873         enddo
9874       enddo
9875       return
9876       end
9877 C---------------------------------------------------------------------------
9878       subroutine prodmat3(a1,a2,kk,transp,prod)
9879 !DIR$ INLINEALWAYS prodmat3
9880 #ifndef OSF
9881 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9882 #endif
9883       implicit none
9884       integer i,j
9885       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9886       logical transp
9887 crc      double precision auxmat(2,2),prod_(2,2)
9888
9889       if (transp) then
9890 crc        call transpose2(kk(1,1),auxmat(1,1))
9891 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9892 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9893
9894            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9895      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9896            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9897      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9898            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9899      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9900            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9901      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9902
9903       else
9904 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9905 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9906
9907            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9908      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9909            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9910      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9911            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9912      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9913            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9914      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9915
9916       endif
9917 c      call transpose2(a2(1,1),a2t(1,1))
9918
9919 crc      print *,transp
9920 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9921 crc      print *,((prod(i,j),i=1,2),j=1,2)
9922
9923       return
9924       end
9925