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 #ifdef TIMING
 547 #ifdef MPI
 548       time01=MPI_Wtime()
 549 #else
 550       time01=tcpu()
 551 #endif
 552 #endif
 553 #ifdef DEBUG
 554       write (iout,*) "sum_gradient gvdwc, gvdwx"
 555       do i=1,nres
 556         write (iout,'(i3,3f10.5,5x,3f10.5,5x,3f10.5,5x,3f10.5)')
 557      &   i,(gvdwx(j,i),j=1,3),(gvdwcT(j,i),j=1,3),(gvdwc(j,i),j=1,3),
 558      &   (gvdwcT(j,i),j=1,3)
 559       enddo
 560       call flush(iout)
 561 #endif
 562 #ifdef MPI
 563 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 564         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 565      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 566 #endif
 567 C
 568 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 569 C            in virtual-bond-vector coordinates
 570 C
 571 #ifdef DEBUG
 572 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 573 c      do i=1,nres-1
 574 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 575 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 576 c      enddo
 577 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 578 c      do i=1,nres-1
 579 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 580 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 581 c      enddo
 582       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 583       do i=1,nres
 584         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 585      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 586      &   g_corr5_loc(i)
 587       enddo
 588       call flush(iout)
 589 #endif
 590 #ifdef SPLITELE
 591 #ifdef TSCSC
 592       do i=1,nct
 593         do j=1,3
 594           gradbufc(j,i)=wsc*gvdwc(j,i)+wsc*wscT*gvdwcT(j,i)+
 595      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 596      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 597      &                wel_loc*gel_loc_long(j,i)+
 598      &                wcorr*gradcorr_long(j,i)+
 599      &                wcorr5*gradcorr5_long(j,i)+
 600      &                wcorr6*gradcorr6_long(j,i)+
 601      &                wturn6*gcorr6_turn_long(j,i)+
 602      &                wstrain*ghpbc(j,i)+
 603      &                wdfa_dist*gdfad(j,i)+
 604      &                wdfa_tor*gdfat(j,i)+
 605      &                wdfa_nei*gdfan(j,i)+
 606      &                wdfa_beta*gdfab(j,i)
 607         enddo
 608       enddo
 609 #else
 610       do i=1,nct
 611         do j=1,3
 612           gradbufc(j,i)=wsc*gvdwc(j,i)+
 613      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 614      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 615      &                wel_loc*gel_loc_long(j,i)+
 616      &                wcorr*gradcorr_long(j,i)+
 617      &                wcorr5*gradcorr5_long(j,i)+
 618      &                wcorr6*gradcorr6_long(j,i)+
 619      &                wturn6*gcorr6_turn_long(j,i)+
 620      &                wstrain*ghpbc(j,i)+
 621      &                wdfa_dist*gdfad(j,i)+
 622      &                wdfa_tor*gdfat(j,i)+
 623      &                wdfa_nei*gdfan(j,i)+
 624      &                wdfa_beta*gdfab(j,i)
 625         enddo
 626       enddo
 627 #endif
 628 #else
 629       do i=1,nct
 630         do j=1,3
 631           gradbufc(j,i)=wsc*gvdwc(j,i)+
 632      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 633      &                welec*gelc_long(j,i)+
 634      &                wbond*gradb(j,i)+
 635      &                wel_loc*gel_loc_long(j,i)+
 636      &                wcorr*gradcorr_long(j,i)+
 637      &                wcorr5*gradcorr5_long(j,i)+
 638      &                wcorr6*gradcorr6_long(j,i)+
 639      &                wturn6*gcorr6_turn_long(j,i)+
 640      &                wstrain*ghpbc(j,i)+
 641      &                wdfa_dist*gdfad(j,i)+
 642      &                wdfa_tor*gdfat(j,i)+
 643      &                wdfa_nei*gdfan(j,i)+
 644      &                wdfa_beta*gdfab(j,i)
 645         enddo
 646       enddo
 647 #endif
 648 #ifdef MPI
 649       if (nfgtasks.gt.1) then
 650       time00=MPI_Wtime()
 651 #ifdef DEBUG
 652       write (iout,*) "gradbufc before allreduce"
 653       do i=1,nres
 654         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 655       enddo
 656       call flush(iout)
 657 #endif
 658       do i=1,nres
 659         do j=1,3
 660           gradbufc_sum(j,i)=gradbufc(j,i)
 661         enddo
 662       enddo
 663 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 664 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 665 c      time_reduce=time_reduce+MPI_Wtime()-time00
 666 #ifdef DEBUG
 667 c      write (iout,*) "gradbufc_sum after allreduce"
 668 c      do i=1,nres
 669 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 670 c      enddo
 671 c      call flush(iout)
 672 #endif
 673 #ifdef TIMING
 674 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 675 #endif
 676       do i=nnt,nres
 677         do k=1,3
 678           gradbufc(k,i)=0.0d0
 679         enddo
 680       enddo
 681 #ifdef DEBUG
 682       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 683       write (iout,*) (i," jgrad_start",jgrad_start(i),
 684      &                  " jgrad_end  ",jgrad_end(i),
 685      &                  i=igrad_start,igrad_end)
 686 #endif
 687 c
 688 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 689 c do not parallelize this part.
 690 c
 691 c      do i=igrad_start,igrad_end
 692 c        do j=jgrad_start(i),jgrad_end(i)
 693 c          do k=1,3
 694 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 695 c          enddo
 696 c        enddo
 697 c      enddo
 698       do j=1,3
 699         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 700       enddo
 701       do i=nres-2,nnt,-1
 702         do j=1,3
 703           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 704         enddo
 705       enddo
 706 #ifdef DEBUG
 707       write (iout,*) "gradbufc after summing"
 708       do i=1,nres
 709         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 710       enddo
 711       call flush(iout)
 712 #endif
 713       else
 714 #endif
 715 #ifdef DEBUG
 716       write (iout,*) "gradbufc"
 717       do i=1,nres
 718         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 719       enddo
 720       call flush(iout)
 721 #endif
 722       do i=1,nres
 723         do j=1,3
 724           gradbufc_sum(j,i)=gradbufc(j,i)
 725           gradbufc(j,i)=0.0d0
 726         enddo
 727       enddo
 728       do j=1,3
 729         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 730       enddo
 731       do i=nres-2,nnt,-1
 732         do j=1,3
 733           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 734         enddo
 735       enddo
 736 c      do i=nnt,nres-1
 737 c        do k=1,3
 738 c          gradbufc(k,i)=0.0d0
 739 c        enddo
 740 c        do j=i+1,nres
 741 c          do k=1,3
 742 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 743 c          enddo
 744 c        enddo
 745 c      enddo
 746 #ifdef DEBUG
 747       write (iout,*) "gradbufc after summing"
 748       do i=1,nres
 749         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 750       enddo
 751       call flush(iout)
 752 #endif
 753 #ifdef MPI
 754       endif
 755 #endif
 756       do k=1,3
 757         gradbufc(k,nres)=0.0d0
 758       enddo
 759       do i=1,nct
 760         do j=1,3
 761 #ifdef SPLITELE
 762           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 763      &                wel_loc*gel_loc(j,i)+
 764      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 765      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 766      &                wel_loc*gel_loc_long(j,i)+
 767      &                wcorr*gradcorr_long(j,i)+
 768      &                wcorr5*gradcorr5_long(j,i)+
 769      &                wcorr6*gradcorr6_long(j,i)+
 770      &                wturn6*gcorr6_turn_long(j,i))+
 771      &                wbond*gradb(j,i)+
 772      &                wcorr*gradcorr(j,i)+
 773      &                wturn3*gcorr3_turn(j,i)+
 774      &                wturn4*gcorr4_turn(j,i)+
 775      &                wcorr5*gradcorr5(j,i)+
 776      &                wcorr6*gradcorr6(j,i)+
 777      &                wturn6*gcorr6_turn(j,i)+
 778      &                wsccor*gsccorc(j,i)
 779      &               +wscloc*gscloc(j,i)
 780 #else
 781           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 782      &                wel_loc*gel_loc(j,i)+
 783      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 784      &                welec*gelc_long(j,i)+
 785      &                wel_loc*gel_loc_long(j,i)+
 786      &                wcorr*gcorr_long(j,i)+
 787      &                wcorr5*gradcorr5_long(j,i)+
 788      &                wcorr6*gradcorr6_long(j,i)+
 789      &                wturn6*gcorr6_turn_long(j,i))+
 790      &                wbond*gradb(j,i)+
 791      &                wcorr*gradcorr(j,i)+
 792      &                wturn3*gcorr3_turn(j,i)+
 793      &                wturn4*gcorr4_turn(j,i)+
 794      &                wcorr5*gradcorr5(j,i)+
 795      &                wcorr6*gradcorr6(j,i)+
 796      &                wturn6*gcorr6_turn(j,i)+
 797      &                wsccor*gsccorc(j,i)
 798      &               +wscloc*gscloc(j,i)
 799 #endif
 800 #ifdef TSCSC
 801           gradx(j,i,icg)=wsc*gvdwx(j,i)+wsc*wscT*gvdwxT(j,i)+
 802      &                  wscp*gradx_scp(j,i)+
 803      &                  wbond*gradbx(j,i)+
 804      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 805      &                  wsccor*gsccorx(j,i)
 806      &                 +wscloc*gsclocx(j,i)
 807 #else
 808           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 809      &                  wbond*gradbx(j,i)+
 810      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 811      &                  wsccor*gsccorx(j,i)
 812      &                 +wscloc*gsclocx(j,i)
 813 #endif
 814         enddo
 815       enddo
 816 #ifdef DEBUG
 817       write (iout,*) "gloc before adding corr"
 818       do i=1,4*nres
 819         write (iout,*) i,gloc(i,icg)
 820       enddo
 821 #endif
 822       do i=1,nres-3
 823         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 824      &   +wcorr5*g_corr5_loc(i)
 825      &   +wcorr6*g_corr6_loc(i)
 826      &   +wturn4*gel_loc_turn4(i)
 827      &   +wturn3*gel_loc_turn3(i)
 828      &   +wturn6*gel_loc_turn6(i)
 829      &   +wel_loc*gel_loc_loc(i)
 830       enddo
 831 #ifdef DEBUG
 832       write (iout,*) "gloc after adding corr"
 833       do i=1,4*nres
 834         write (iout,*) i,gloc(i,icg)
 835       enddo
 836 #endif
 837 #ifdef MPI
 838       if (nfgtasks.gt.1) then
 839         do j=1,3
 840           do i=1,nres
 841             gradbufc(j,i)=gradc(j,i,icg)
 842             gradbufx(j,i)=gradx(j,i,icg)
 843           enddo
 844         enddo
 845         do i=1,4*nres
 846           glocbuf(i)=gloc(i,icg)
 847         enddo
 848 #ifdef DEBUG
 849       write (iout,*) "gloc_sc before reduce"
 850       do i=1,nres
 851        do j=1,3
 852         write (iout,*) i,j,gloc_sc(j,i,icg)
 853        enddo
 854       enddo
 855 #endif
 856         do i=1,nres
 857          do j=1,3
 858           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 859          enddo
 860         enddo
 861         time00=MPI_Wtime()
 862         call MPI_Barrier(FG_COMM,IERR)
 863         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 864         time00=MPI_Wtime()
 865         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 866      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 867         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 868      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 869         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 870      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 871         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 872      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 873         time_reduce=time_reduce+MPI_Wtime()-time00
 874 #ifdef DEBUG
 875       write (iout,*) "gloc_sc after reduce"
 876       do i=1,nres
 877        do j=1,3
 878         write (iout,*) i,j,gloc_sc(j,i,icg)
 879        enddo
 880       enddo
 881 #endif
 882 #ifdef DEBUG
 883       write (iout,*) "gloc after reduce"
 884       do i=1,4*nres
 885         write (iout,*) i,gloc(i,icg)
 886       enddo
 887 #endif
 888       endif
 889 #endif
 890       if (gnorm_check) then
 891 c
 892 c Compute the maximum elements of the gradient
 893 c
 894       gvdwc_max=0.0d0
 895       gvdwc_scp_max=0.0d0
 896       gelc_max=0.0d0
 897       gvdwpp_max=0.0d0
 898       gradb_max=0.0d0
 899       ghpbc_max=0.0d0
 900       gradcorr_max=0.0d0
 901       gel_loc_max=0.0d0
 902       gcorr3_turn_max=0.0d0
 903       gcorr4_turn_max=0.0d0
 904       gradcorr5_max=0.0d0
 905       gradcorr6_max=0.0d0
 906       gcorr6_turn_max=0.0d0
 907       gsccorc_max=0.0d0
 908       gscloc_max=0.0d0
 909       gvdwx_max=0.0d0
 910       gradx_scp_max=0.0d0
 911       ghpbx_max=0.0d0
 912       gradxorr_max=0.0d0
 913       gsccorx_max=0.0d0
 914       gsclocx_max=0.0d0
 915       do i=1,nct
 916         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 917         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 918 #ifdef TSCSC
 919         gvdwc_norm=dsqrt(scalar(gvdwcT(1,i),gvdwcT(1,i)))
 920         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 921 #endif
 922         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 923         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 924      &   gvdwc_scp_max=gvdwc_scp_norm
 925         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 926         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 927         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 928         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 929         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 930         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 931         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 932         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 933         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 934         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 935         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 936         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 937         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 938      &    gcorr3_turn(1,i)))
 939         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 940      &    gcorr3_turn_max=gcorr3_turn_norm
 941         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 942      &    gcorr4_turn(1,i)))
 943         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 944      &    gcorr4_turn_max=gcorr4_turn_norm
 945         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 946         if (gradcorr5_norm.gt.gradcorr5_max)
 947      &    gradcorr5_max=gradcorr5_norm
 948         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 949         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 950         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 951      &    gcorr6_turn(1,i)))
 952         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 953      &    gcorr6_turn_max=gcorr6_turn_norm
 954         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 955         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 956         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 957         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 958         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 959         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 960 #ifdef TSCSC
 961         gvdwx_norm=dsqrt(scalar(gvdwxT(1,i),gvdwxT(1,i)))
 962         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 963 #endif
 964         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 965         if (gradx_scp_norm.gt.gradx_scp_max)
 966      &    gradx_scp_max=gradx_scp_norm
 967         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 968         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 969         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 970         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 971         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 972         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 973         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 974         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 975       enddo
 976       if (gradout) then
 977 #ifdef AIX
 978         open(istat,file=statname,position="append")
 979 #else
 980         open(istat,file=statname,access="append")
 981 #endif
 982         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 983      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 984      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 985      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 986      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 987      &     gsccorx_max,gsclocx_max
 988         close(istat)
 989         if (gvdwc_max.gt.1.0d4) then
 990           write (iout,*) "gvdwc gvdwx gradb gradbx"
 991           do i=nnt,nct
 992             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 993      &        gradb(j,i),gradbx(j,i),j=1,3)
 994           enddo
 995           call pdbout(0.0d0,'cipiszcze',iout)
 996           call flush(iout)
 997         endif
 998       endif
 999       endif
1000 #ifdef DEBUG
1001       write (iout,*) "gradc gradx gloc"
1002       do i=1,nres
1003         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
1004      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
1005       enddo
1006 #endif
1007 #ifdef TIMING
1008 #ifdef MPI
1009       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
1010 #else
1011       time_sumgradient=time_sumgradient+tcpu()-time01
1012 #endif
1013 #endif
1014       return
1015       end
1016 c-------------------------------------------------------------------------------
1017       subroutine rescale_weights(t_bath)
1018       implicit real*8 (a-h,o-z)
1019       include 'DIMENSIONS'
1020       include 'COMMON.IOUNITS'
1021       include 'COMMON.FFIELD'
1022       include 'COMMON.SBRIDGE'
1023       double precision kfac /2.4d0/
1024       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
1025 c      facT=temp0/t_bath
1026 c      facT=2*temp0/(t_bath+temp0)
1027       if (rescale_mode.eq.0) then
1028         facT=1.0d0
1029         facT2=1.0d0
1030         facT3=1.0d0
1031         facT4=1.0d0
1032         facT5=1.0d0
1033       else if (rescale_mode.eq.1) then
1034         facT=kfac/(kfac-1.0d0+t_bath/temp0)
1035         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1036         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1037         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1038         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1039       else if (rescale_mode.eq.2) then
1040         x=t_bath/temp0
1041         x2=x*x
1042         x3=x2*x
1043         x4=x3*x
1044         x5=x4*x
1045         facT=licznik/dlog(dexp(x)+dexp(-x))
1046         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
1047         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
1048         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
1049         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
1050       else
1051         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1052         write (*,*) "Wrong RESCALE_MODE",rescale_mode
1053 #ifdef MPI
1054        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1055 #endif
1056        stop 555
1057       endif
1058       welec=weights(3)*fact
1059       wcorr=weights(4)*fact3
1060       wcorr5=weights(5)*fact4
1061       wcorr6=weights(6)*fact5
1062       wel_loc=weights(7)*fact2
1063       wturn3=weights(8)*fact2
1064       wturn4=weights(9)*fact3
1065       wturn6=weights(10)*fact5
1066       wtor=weights(13)*fact
1067       wtor_d=weights(14)*fact2
1068       wsccor=weights(21)*fact
1069 #ifdef TSCSC
1070 c      wsct=t_bath/temp0
1071       wsct=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
1072 #endif
1073       return
1074       end
1075 C------------------------------------------------------------------------
1076       subroutine enerprint(energia)
1077       implicit real*8 (a-h,o-z)
1078       include 'DIMENSIONS'
1079       include 'COMMON.IOUNITS'
1080       include 'COMMON.FFIELD'
1081       include 'COMMON.SBRIDGE'
1082       include 'COMMON.MD'
1083       double precision energia(0:n_ene)
1084       etot=energia(0)
1085 #ifdef TSCSC
1086       evdw=energia(22)+wsct*energia(23)
1087 #else
1088       evdw=energia(1)
1089 #endif
1090       evdw2=energia(2)
1091 #ifdef SCP14
1092       evdw2=energia(2)+energia(18)
1093 #else
1094       evdw2=energia(2)
1095 #endif
1096       ees=energia(3)
1097 #ifdef SPLITELE
1098       evdw1=energia(16)
1099 #endif
1100       ecorr=energia(4)
1101       ecorr5=energia(5)
1102       ecorr6=energia(6)
1103       eel_loc=energia(7)
1104       eello_turn3=energia(8)
1105       eello_turn4=energia(9)
1106       eello_turn6=energia(10)
1107       ebe=energia(11)
1108       escloc=energia(12)
1109       etors=energia(13)
1110       etors_d=energia(14)
1111       ehpb=energia(15)
1112       edihcnstr=energia(19)
1113       estr=energia(17)
1114       Uconst=energia(20)
1115       esccor=energia(21)
1116       ehomology_constr=energia(24)
1117 C     Bartek
1118       edfadis = energia(25)
1119       edfator = energia(26)
1120       edfanei = energia(27)
1121       edfabet = energia(28)
1122
1123 #ifdef SPLITELE
1124       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1125      &  estr,wbond,ebe,wang,
1126      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1127      &  ecorr,wcorr,
1128      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1129      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
1130      &  edihcnstr,ehomology_constr, ebr*nss,
1131      &  Uconst,edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
1132      &  edfabet,wdfa_beta,etot
1133    10 format (/'Virtual-chain energies:'//
1134      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
1135      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
1136      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
1137      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pE16.6,' (p-p VDW)'/
1138      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
1139      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
1140      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
1141      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
1142      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
1143      & 'EHPB=  ',1pE16.6,' WEIGHT=',1pE16.6,
1144      & ' (SS bridges & dist. cnstr.)'/
1145      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1146      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1147      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1148      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
1149      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
1150      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
1151      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
1152      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
1153      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1154      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1155      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1156      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1157      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
1158      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
1159      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
1160      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
1161      & 'ETOT=  ',1pE16.6,' (total)')
1162 #else
1163       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1164      &  estr,wbond,ebe,wang,
1165      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1166      &  ecorr,wcorr,
1167      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1168      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1169      &  ehomology_constr,ebr*nss,Uconst,edfadis,wdfa_dist,edfator,
1170      &  wdfa_tor,edfanei,wdfa_nei,edfabet,wdfa_beta,
1171      &  etot
1172    10 format (/'Virtual-chain energies:'//
1173      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1174      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1175      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1176      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1177      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1178      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1179      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1180      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1181      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1182      & ' (SS bridges & dist. cnstr.)'/
1183      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1184      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1185      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1186      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1187      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1188      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1189      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1190      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1191      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1192      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1193      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1194      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1195      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA distance energy)'/
1196      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA torsion energy)'/
1197      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA NCa energy)'/
1198      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA Beta energy)'/
1199      & 'ETOT=  ',1pE16.6,' (total)')
1200 #endif
1201       return
1202       end
1203 C-----------------------------------------------------------------------
1204       subroutine elj(evdw,evdw_p,evdw_m)
1205 C
1206 C This subroutine calculates the interaction energy of nonbonded side chains
1207 C assuming the LJ potential of interaction.
1208 C
1209       implicit real*8 (a-h,o-z)
1210       include 'DIMENSIONS'
1211       parameter (accur=1.0d-10)
1212       include 'COMMON.GEO'
1213       include 'COMMON.VAR'
1214       include 'COMMON.LOCAL'
1215       include 'COMMON.CHAIN'
1216       include 'COMMON.DERIV'
1217       include 'COMMON.INTERACT'
1218       include 'COMMON.TORSION'
1219       include 'COMMON.SBRIDGE'
1220       include 'COMMON.NAMES'
1221       include 'COMMON.IOUNITS'
1222       include 'COMMON.CONTACTS'
1223       dimension gg(3)
1224 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1225       evdw=0.0D0
1226       do i=iatsc_s,iatsc_e
1227         itypi=itype(i)
1228         itypi1=itype(i+1)
1229         xi=c(1,nres+i)
1230         yi=c(2,nres+i)
1231         zi=c(3,nres+i)
1232 C Change 12/1/95
1233         num_conti=0
1234 C
1235 C Calculate SC interaction energy.
1236 C
1237         do iint=1,nint_gr(i)
1238 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1239 cd   &                  'iend=',iend(i,iint)
1240           do j=istart(i,iint),iend(i,iint)
1241             itypj=itype(j)
1242             xj=c(1,nres+j)-xi
1243             yj=c(2,nres+j)-yi
1244             zj=c(3,nres+j)-zi
1245 C Change 12/1/95 to calculate four-body interactions
1246             rij=xj*xj+yj*yj+zj*zj
1247             rrij=1.0D0/rij
1248 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1249             eps0ij=eps(itypi,itypj)
1250             fac=rrij**expon2
1251             e1=fac*fac*aa(itypi,itypj)
1252             e2=fac*bb(itypi,itypj)
1253             evdwij=e1+e2
1254 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1255 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1256 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1257 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1258 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1259 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1260 #ifdef TSCSC
1261             if (bb(itypi,itypj).gt.0) then
1262                evdw_p=evdw_p+evdwij
1263             else
1264                evdw_m=evdw_m+evdwij
1265             endif
1266 #else
1267             evdw=evdw+evdwij
1268 #endif
1269 C
1270 C Calculate the components of the gradient in DC and X
1271 C
1272             fac=-rrij*(e1+evdwij)
1273             gg(1)=xj*fac
1274             gg(2)=yj*fac
1275             gg(3)=zj*fac
1276 #ifdef TSCSC
1277             if (bb(itypi,itypj).gt.0.0d0) then
1278               do k=1,3
1279                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1280                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1281                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1282                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1283               enddo
1284             else
1285               do k=1,3
1286                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1287                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1288                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1289                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1290               enddo
1291             endif
1292 #else
1293             do k=1,3
1294               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1295               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1296               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1297               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1298             enddo
1299 #endif
1300 cgrad            do k=i,j-1
1301 cgrad              do l=1,3
1302 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1303 cgrad              enddo
1304 cgrad            enddo
1305 C
1306 C 12/1/95, revised on 5/20/97
1307 C
1308 C Calculate the contact function. The ith column of the array JCONT will
1309 C contain the numbers of atoms that make contacts with the atom I (of numbers
1310 C greater than I). The arrays FACONT and GACONT will contain the values of
1311 C the contact function and its derivative.
1312 C
1313 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1314 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1315 C Uncomment next line, if the correlation interactions are contact function only
1316             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1317               rij=dsqrt(rij)
1318               sigij=sigma(itypi,itypj)
1319               r0ij=rs0(itypi,itypj)
1320 C
1321 C Check whether the SC's are not too far to make a contact.
1322 C
1323               rcut=1.5d0*r0ij
1324               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1325 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1326 C
1327               if (fcont.gt.0.0D0) then
1328 C If the SC-SC distance if close to sigma, apply spline.
1329 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1330 cAdam &             fcont1,fprimcont1)
1331 cAdam           fcont1=1.0d0-fcont1
1332 cAdam           if (fcont1.gt.0.0d0) then
1333 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1334 cAdam             fcont=fcont*fcont1
1335 cAdam           endif
1336 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1337 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1338 cga             do k=1,3
1339 cga               gg(k)=gg(k)*eps0ij
1340 cga             enddo
1341 cga             eps0ij=-evdwij*eps0ij
1342 C Uncomment for AL's type of SC correlation interactions.
1343 cadam           eps0ij=-evdwij
1344                 num_conti=num_conti+1
1345                 jcont(num_conti,i)=j
1346                 facont(num_conti,i)=fcont*eps0ij
1347                 fprimcont=eps0ij*fprimcont/rij
1348                 fcont=expon*fcont
1349 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1350 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1351 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1352 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1353                 gacont(1,num_conti,i)=-fprimcont*xj
1354                 gacont(2,num_conti,i)=-fprimcont*yj
1355                 gacont(3,num_conti,i)=-fprimcont*zj
1356 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1357 cd              write (iout,'(2i3,3f10.5)')
1358 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1359               endif
1360             endif
1361           enddo      ! j
1362         enddo        ! iint
1363 C Change 12/1/95
1364         num_cont(i)=num_conti
1365       enddo          ! i
1366       do i=1,nct
1367         do j=1,3
1368           gvdwc(j,i)=expon*gvdwc(j,i)
1369           gvdwx(j,i)=expon*gvdwx(j,i)
1370         enddo
1371       enddo
1372 C******************************************************************************
1373 C
1374 C                              N O T E !!!
1375 C
1376 C To save time, the factor of EXPON has been extracted from ALL components
1377 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1378 C use!
1379 C
1380 C******************************************************************************
1381       return
1382       end
1383 C-----------------------------------------------------------------------------
1384       subroutine eljk(evdw,evdw_p,evdw_m)
1385 C
1386 C This subroutine calculates the interaction energy of nonbonded side chains
1387 C assuming the LJK potential of interaction.
1388 C
1389       implicit real*8 (a-h,o-z)
1390       include 'DIMENSIONS'
1391       include 'COMMON.GEO'
1392       include 'COMMON.VAR'
1393       include 'COMMON.LOCAL'
1394       include 'COMMON.CHAIN'
1395       include 'COMMON.DERIV'
1396       include 'COMMON.INTERACT'
1397       include 'COMMON.IOUNITS'
1398       include 'COMMON.NAMES'
1399       dimension gg(3)
1400       logical scheck
1401 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1402       evdw=0.0D0
1403       do i=iatsc_s,iatsc_e
1404         itypi=itype(i)
1405         itypi1=itype(i+1)
1406         xi=c(1,nres+i)
1407         yi=c(2,nres+i)
1408         zi=c(3,nres+i)
1409 C
1410 C Calculate SC interaction energy.
1411 C
1412         do iint=1,nint_gr(i)
1413           do j=istart(i,iint),iend(i,iint)
1414             itypj=itype(j)
1415             xj=c(1,nres+j)-xi
1416             yj=c(2,nres+j)-yi
1417             zj=c(3,nres+j)-zi
1418             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1419             fac_augm=rrij**expon
1420             e_augm=augm(itypi,itypj)*fac_augm
1421             r_inv_ij=dsqrt(rrij)
1422             rij=1.0D0/r_inv_ij
1423             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1424             fac=r_shift_inv**expon
1425             e1=fac*fac*aa(itypi,itypj)
1426             e2=fac*bb(itypi,itypj)
1427             evdwij=e_augm+e1+e2
1428 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1429 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1430 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1431 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1432 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1433 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1434 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1435 #ifdef TSCSC
1436             if (bb(itypi,itypj).gt.0) then
1437                evdw_p=evdw_p+evdwij
1438             else
1439                evdw_m=evdw_m+evdwij
1440             endif
1441 #else
1442             evdw=evdw+evdwij
1443 #endif
1444 C
1445 C Calculate the components of the gradient in DC and X
1446 C
1447             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1448             gg(1)=xj*fac
1449             gg(2)=yj*fac
1450             gg(3)=zj*fac
1451 #ifdef TSCSC
1452             if (bb(itypi,itypj).gt.0.0d0) then
1453               do k=1,3
1454                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1455                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1456                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1457                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1458               enddo
1459             else
1460               do k=1,3
1461                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1462                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1463                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1464                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1465               enddo
1466             endif
1467 #else
1468             do k=1,3
1469               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1470               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1471               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1472               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1473             enddo
1474 #endif
1475 cgrad            do k=i,j-1
1476 cgrad              do l=1,3
1477 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1478 cgrad              enddo
1479 cgrad            enddo
1480           enddo      ! j
1481         enddo        ! iint
1482       enddo          ! i
1483       do i=1,nct
1484         do j=1,3
1485           gvdwc(j,i)=expon*gvdwc(j,i)
1486           gvdwx(j,i)=expon*gvdwx(j,i)
1487         enddo
1488       enddo
1489       return
1490       end
1491 C-----------------------------------------------------------------------------
1492       subroutine ebp(evdw,evdw_p,evdw_m)
1493 C
1494 C This subroutine calculates the interaction energy of nonbonded side chains
1495 C assuming the Berne-Pechukas potential of interaction.
1496 C
1497       implicit real*8 (a-h,o-z)
1498       include 'DIMENSIONS'
1499       include 'COMMON.GEO'
1500       include 'COMMON.VAR'
1501       include 'COMMON.LOCAL'
1502       include 'COMMON.CHAIN'
1503       include 'COMMON.DERIV'
1504       include 'COMMON.NAMES'
1505       include 'COMMON.INTERACT'
1506       include 'COMMON.IOUNITS'
1507       include 'COMMON.CALC'
1508       common /srutu/ icall
1509 c     double precision rrsave(maxdim)
1510       logical lprn
1511       evdw=0.0D0
1512 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1513       evdw=0.0D0
1514 c     if (icall.eq.0) then
1515 c       lprn=.true.
1516 c     else
1517         lprn=.false.
1518 c     endif
1519       ind=0
1520       do i=iatsc_s,iatsc_e
1521         itypi=itype(i)
1522         itypi1=itype(i+1)
1523         xi=c(1,nres+i)
1524         yi=c(2,nres+i)
1525         zi=c(3,nres+i)
1526         dxi=dc_norm(1,nres+i)
1527         dyi=dc_norm(2,nres+i)
1528         dzi=dc_norm(3,nres+i)
1529 c        dsci_inv=dsc_inv(itypi)
1530         dsci_inv=vbld_inv(i+nres)
1531 C
1532 C Calculate SC interaction energy.
1533 C
1534         do iint=1,nint_gr(i)
1535           do j=istart(i,iint),iend(i,iint)
1536             ind=ind+1
1537             itypj=itype(j)
1538 c            dscj_inv=dsc_inv(itypj)
1539             dscj_inv=vbld_inv(j+nres)
1540             chi1=chi(itypi,itypj)
1541             chi2=chi(itypj,itypi)
1542             chi12=chi1*chi2
1543             chip1=chip(itypi)
1544             chip2=chip(itypj)
1545             chip12=chip1*chip2
1546             alf1=alp(itypi)
1547             alf2=alp(itypj)
1548             alf12=0.5D0*(alf1+alf2)
1549 C For diagnostics only!!!
1550 c           chi1=0.0D0
1551 c           chi2=0.0D0
1552 c           chi12=0.0D0
1553 c           chip1=0.0D0
1554 c           chip2=0.0D0
1555 c           chip12=0.0D0
1556 c           alf1=0.0D0
1557 c           alf2=0.0D0
1558 c           alf12=0.0D0
1559             xj=c(1,nres+j)-xi
1560             yj=c(2,nres+j)-yi
1561             zj=c(3,nres+j)-zi
1562             dxj=dc_norm(1,nres+j)
1563             dyj=dc_norm(2,nres+j)
1564             dzj=dc_norm(3,nres+j)
1565             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1566 cd          if (icall.eq.0) then
1567 cd            rrsave(ind)=rrij
1568 cd          else
1569 cd            rrij=rrsave(ind)
1570 cd          endif
1571             rij=dsqrt(rrij)
1572 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1573             call sc_angular
1574 C Calculate whole angle-dependent part of epsilon and contributions
1575 C to its derivatives
1576             fac=(rrij*sigsq)**expon2
1577             e1=fac*fac*aa(itypi,itypj)
1578             e2=fac*bb(itypi,itypj)
1579             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1580             eps2der=evdwij*eps3rt
1581             eps3der=evdwij*eps2rt
1582             evdwij=evdwij*eps2rt*eps3rt
1583 #ifdef TSCSC
1584             if (bb(itypi,itypj).gt.0) then
1585                evdw_p=evdw_p+evdwij
1586             else
1587                evdw_m=evdw_m+evdwij
1588             endif
1589 #else
1590             evdw=evdw+evdwij
1591 #endif
1592             if (lprn) then
1593             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1594             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1595 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1596 cd     &        restyp(itypi),i,restyp(itypj),j,
1597 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1598 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1599 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1600 cd     &        evdwij
1601             endif
1602 C Calculate gradient components.
1603             e1=e1*eps1*eps2rt**2*eps3rt**2
1604             fac=-expon*(e1+evdwij)
1605             sigder=fac/sigsq
1606             fac=rrij*fac
1607 C Calculate radial part of the gradient
1608             gg(1)=xj*fac
1609             gg(2)=yj*fac
1610             gg(3)=zj*fac
1611 C Calculate the angular part of the gradient and sum add the contributions
1612 C to the appropriate components of the Cartesian gradient.
1613 #ifdef TSCSC
1614             if (bb(itypi,itypj).gt.0) then
1615                call sc_grad
1616             else
1617                call sc_grad_T
1618             endif
1619 #else
1620             call sc_grad
1621 #endif
1622           enddo      ! j
1623         enddo        ! iint
1624       enddo          ! i
1625 c     stop
1626       return
1627       end
1628 C-----------------------------------------------------------------------------
1629       subroutine egb(evdw,evdw_p,evdw_m)
1630 C
1631 C This subroutine calculates the interaction energy of nonbonded side chains
1632 C assuming the Gay-Berne potential of interaction.
1633 C
1634       implicit real*8 (a-h,o-z)
1635       include 'DIMENSIONS'
1636       include 'COMMON.GEO'
1637       include 'COMMON.VAR'
1638       include 'COMMON.LOCAL'
1639       include 'COMMON.CHAIN'
1640       include 'COMMON.DERIV'
1641       include 'COMMON.NAMES'
1642       include 'COMMON.INTERACT'
1643       include 'COMMON.IOUNITS'
1644       include 'COMMON.CALC'
1645       include 'COMMON.CONTROL'
1646       include 'COMMON.SBRIDGE'
1647       logical lprn
1648       evdw=0.0D0
1649 ccccc      energy_dec=.false.
1650 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1651       evdw=0.0D0
1652       evdw_p=0.0D0
1653       evdw_m=0.0D0
1654       lprn=.false.
1655 c     if (icall.eq.0) lprn=.false.
1656       ind=0
1657       do i=iatsc_s,iatsc_e
1658         itypi=itype(i)
1659         itypi1=itype(i+1)
1660         xi=c(1,nres+i)
1661         yi=c(2,nres+i)
1662         zi=c(3,nres+i)
1663         dxi=dc_norm(1,nres+i)
1664         dyi=dc_norm(2,nres+i)
1665         dzi=dc_norm(3,nres+i)
1666 c        dsci_inv=dsc_inv(itypi)
1667         dsci_inv=vbld_inv(i+nres)
1668 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1669 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1670 C
1671 C Calculate SC interaction energy.
1672 C
1673         do iint=1,nint_gr(i)
1674           do j=istart(i,iint),iend(i,iint)
1675             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1676               call dyn_ssbond_ene(i,j,evdwij)
1677               evdw=evdw+evdwij
1678               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1679      &                        'evdw',i,j,evdwij,' ss'
1680             ELSE
1681             ind=ind+1
1682             itypj=itype(j)
1683 c            dscj_inv=dsc_inv(itypj)
1684             dscj_inv=vbld_inv(j+nres)
1685 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1686 c     &       1.0d0/vbld(j+nres)
1687 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1688             sig0ij=sigma(itypi,itypj)
1689             chi1=chi(itypi,itypj)
1690             chi2=chi(itypj,itypi)
1691             chi12=chi1*chi2
1692             chip1=chip(itypi)
1693             chip2=chip(itypj)
1694             chip12=chip1*chip2
1695             alf1=alp(itypi)
1696             alf2=alp(itypj)
1697             alf12=0.5D0*(alf1+alf2)
1698 C For diagnostics only!!!
1699 c           chi1=0.0D0
1700 c           chi2=0.0D0
1701 c           chi12=0.0D0
1702 c           chip1=0.0D0
1703 c           chip2=0.0D0
1704 c           chip12=0.0D0
1705 c           alf1=0.0D0
1706 c           alf2=0.0D0
1707 c           alf12=0.0D0
1708             xj=c(1,nres+j)-xi
1709             yj=c(2,nres+j)-yi
1710             zj=c(3,nres+j)-zi
1711             dxj=dc_norm(1,nres+j)
1712             dyj=dc_norm(2,nres+j)
1713             dzj=dc_norm(3,nres+j)
1714 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1715 c            write (iout,*) "j",j," dc_norm",
1716 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1717             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1718             rij=dsqrt(rrij)
1719 C Calculate angle-dependent terms of energy and contributions to their
1720 C derivatives.
1721             call sc_angular
1722             sigsq=1.0D0/sigsq
1723             sig=sig0ij*dsqrt(sigsq)
1724             rij_shift=1.0D0/rij-sig+sig0ij
1725 c for diagnostics; uncomment
1726 c            rij_shift=1.2*sig0ij
1727 C I hate to put IF's in the loops, but here don't have another choice!!!!
1728             if (rij_shift.le.0.0D0) then
1729               evdw=1.0D20
1730 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1731 cd     &        restyp(itypi),i,restyp(itypj),j,
1732 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1733               return
1734             endif
1735             sigder=-sig*sigsq
1736 c---------------------------------------------------------------
1737             rij_shift=1.0D0/rij_shift
1738             fac=rij_shift**expon
1739             e1=fac*fac*aa(itypi,itypj)
1740             e2=fac*bb(itypi,itypj)
1741             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1742             eps2der=evdwij*eps3rt
1743             eps3der=evdwij*eps2rt
1744 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1745 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1746             evdwij=evdwij*eps2rt*eps3rt
1747 #ifdef TSCSC
1748             if (bb(itypi,itypj).gt.0) then
1749                evdw_p=evdw_p+evdwij
1750             else
1751                evdw_m=evdw_m+evdwij
1752             endif
1753 #else
1754             evdw=evdw+evdwij
1755 #endif
1756             if (lprn) then
1757             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1758             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1759             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1760      &        restyp(itypi),i,restyp(itypj),j,
1761      &        epsi,sigm,chi1,chi2,chip1,chip2,
1762      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1763      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1764      &        evdwij
1765             endif
1766
1767             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1768      &                        'evdw',i,j,evdwij
1769
1770 C Calculate gradient components.
1771             e1=e1*eps1*eps2rt**2*eps3rt**2
1772             fac=-expon*(e1+evdwij)*rij_shift
1773             sigder=fac*sigder
1774             fac=rij*fac
1775 c            fac=0.0d0
1776 C Calculate the radial part of the gradient
1777             gg(1)=xj*fac
1778             gg(2)=yj*fac
1779             gg(3)=zj*fac
1780 C Calculate angular part of the gradient.
1781 #ifdef TSCSC
1782             if (bb(itypi,itypj).gt.0) then
1783                call sc_grad
1784             else
1785                call sc_grad_T
1786             endif
1787 #else
1788             call sc_grad
1789 #endif
1790             ENDIF    ! dyn_ss
1791           enddo      ! j
1792         enddo        ! iint
1793       enddo          ! i
1794 c      write (iout,*) "Number of loop steps in EGB:",ind
1795 cccc      energy_dec=.false.
1796       return
1797       end
1798 C-----------------------------------------------------------------------------
1799       subroutine egbv(evdw,evdw_p,evdw_m)
1800 C
1801 C This subroutine calculates the interaction energy of nonbonded side chains
1802 C assuming the Gay-Berne-Vorobjev potential of interaction.
1803 C
1804       implicit real*8 (a-h,o-z)
1805       include 'DIMENSIONS'
1806       include 'COMMON.GEO'
1807       include 'COMMON.VAR'
1808       include 'COMMON.LOCAL'
1809       include 'COMMON.CHAIN'
1810       include 'COMMON.DERIV'
1811       include 'COMMON.NAMES'
1812       include 'COMMON.INTERACT'
1813       include 'COMMON.IOUNITS'
1814       include 'COMMON.CALC'
1815       common /srutu/ icall
1816       logical lprn
1817       evdw=0.0D0
1818 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1819       evdw=0.0D0
1820       lprn=.false.
1821 c     if (icall.eq.0) lprn=.true.
1822       ind=0
1823       do i=iatsc_s,iatsc_e
1824         itypi=itype(i)
1825         itypi1=itype(i+1)
1826         xi=c(1,nres+i)
1827         yi=c(2,nres+i)
1828         zi=c(3,nres+i)
1829         dxi=dc_norm(1,nres+i)
1830         dyi=dc_norm(2,nres+i)
1831         dzi=dc_norm(3,nres+i)
1832 c        dsci_inv=dsc_inv(itypi)
1833         dsci_inv=vbld_inv(i+nres)
1834 C
1835 C Calculate SC interaction energy.
1836 C
1837         do iint=1,nint_gr(i)
1838           do j=istart(i,iint),iend(i,iint)
1839             ind=ind+1
1840             itypj=itype(j)
1841 c            dscj_inv=dsc_inv(itypj)
1842             dscj_inv=vbld_inv(j+nres)
1843             sig0ij=sigma(itypi,itypj)
1844             r0ij=r0(itypi,itypj)
1845             chi1=chi(itypi,itypj)
1846             chi2=chi(itypj,itypi)
1847             chi12=chi1*chi2
1848             chip1=chip(itypi)
1849             chip2=chip(itypj)
1850             chip12=chip1*chip2
1851             alf1=alp(itypi)
1852             alf2=alp(itypj)
1853             alf12=0.5D0*(alf1+alf2)
1854 C For diagnostics only!!!
1855 c           chi1=0.0D0
1856 c           chi2=0.0D0
1857 c           chi12=0.0D0
1858 c           chip1=0.0D0
1859 c           chip2=0.0D0
1860 c           chip12=0.0D0
1861 c           alf1=0.0D0
1862 c           alf2=0.0D0
1863 c           alf12=0.0D0
1864             xj=c(1,nres+j)-xi
1865             yj=c(2,nres+j)-yi
1866             zj=c(3,nres+j)-zi
1867             dxj=dc_norm(1,nres+j)
1868             dyj=dc_norm(2,nres+j)
1869             dzj=dc_norm(3,nres+j)
1870             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1871             rij=dsqrt(rrij)
1872 C Calculate angle-dependent terms of energy and contributions to their
1873 C derivatives.
1874             call sc_angular
1875             sigsq=1.0D0/sigsq
1876             sig=sig0ij*dsqrt(sigsq)
1877             rij_shift=1.0D0/rij-sig+r0ij
1878 C I hate to put IF's in the loops, but here don't have another choice!!!!
1879             if (rij_shift.le.0.0D0) then
1880               evdw=1.0D20
1881               return
1882             endif
1883             sigder=-sig*sigsq
1884 c---------------------------------------------------------------
1885             rij_shift=1.0D0/rij_shift
1886             fac=rij_shift**expon
1887             e1=fac*fac*aa(itypi,itypj)
1888             e2=fac*bb(itypi,itypj)
1889             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1890             eps2der=evdwij*eps3rt
1891             eps3der=evdwij*eps2rt
1892             fac_augm=rrij**expon
1893             e_augm=augm(itypi,itypj)*fac_augm
1894             evdwij=evdwij*eps2rt*eps3rt
1895 #ifdef TSCSC
1896             if (bb(itypi,itypj).gt.0) then
1897                evdw_p=evdw_p+evdwij+e_augm
1898             else
1899                evdw_m=evdw_m+evdwij+e_augm
1900             endif
1901 #else
1902             evdw=evdw+evdwij+e_augm
1903 #endif
1904             if (lprn) then
1905             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1906             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1907             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1908      &        restyp(itypi),i,restyp(itypj),j,
1909      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1910      &        chi1,chi2,chip1,chip2,
1911      &        eps1,eps2rt**2,eps3rt**2,
1912      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1913      &        evdwij+e_augm
1914             endif
1915 C Calculate gradient components.
1916             e1=e1*eps1*eps2rt**2*eps3rt**2
1917             fac=-expon*(e1+evdwij)*rij_shift
1918             sigder=fac*sigder
1919             fac=rij*fac-2*expon*rrij*e_augm
1920 C Calculate the radial part of the gradient
1921             gg(1)=xj*fac
1922             gg(2)=yj*fac
1923             gg(3)=zj*fac
1924 C Calculate angular part of the gradient.
1925 #ifdef TSCSC
1926             if (bb(itypi,itypj).gt.0) then
1927                call sc_grad
1928             else
1929                call sc_grad_T
1930             endif
1931 #else
1932             call sc_grad
1933 #endif
1934           enddo      ! j
1935         enddo        ! iint
1936       enddo          ! i
1937       end
1938 C-----------------------------------------------------------------------------
1939       subroutine sc_angular
1940 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1941 C om12. Called by ebp, egb, and egbv.
1942       implicit none
1943       include 'COMMON.CALC'
1944       include 'COMMON.IOUNITS'
1945       erij(1)=xj*rij
1946       erij(2)=yj*rij
1947       erij(3)=zj*rij
1948       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1949       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1950       om12=dxi*dxj+dyi*dyj+dzi*dzj
1951       chiom12=chi12*om12
1952 C Calculate eps1(om12) and its derivative in om12
1953       faceps1=1.0D0-om12*chiom12
1954       faceps1_inv=1.0D0/faceps1
1955       eps1=dsqrt(faceps1_inv)
1956 C Following variable is eps1*deps1/dom12
1957       eps1_om12=faceps1_inv*chiom12
1958 c diagnostics only
1959 c      faceps1_inv=om12
1960 c      eps1=om12
1961 c      eps1_om12=1.0d0
1962 c      write (iout,*) "om12",om12," eps1",eps1
1963 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1964 C and om12.
1965       om1om2=om1*om2
1966       chiom1=chi1*om1
1967       chiom2=chi2*om2
1968       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1969       sigsq=1.0D0-facsig*faceps1_inv
1970       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1971       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1972       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1973 c diagnostics only
1974 c      sigsq=1.0d0
1975 c      sigsq_om1=0.0d0
1976 c      sigsq_om2=0.0d0
1977 c      sigsq_om12=0.0d0
1978 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1979 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1980 c     &    " eps1",eps1
1981 C Calculate eps2 and its derivatives in om1, om2, and om12.
1982       chipom1=chip1*om1
1983       chipom2=chip2*om2
1984       chipom12=chip12*om12
1985       facp=1.0D0-om12*chipom12
1986       facp_inv=1.0D0/facp
1987       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1988 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1989 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1990 C Following variable is the square root of eps2
1991       eps2rt=1.0D0-facp1*facp_inv
1992 C Following three variables are the derivatives of the square root of eps
1993 C in om1, om2, and om12.
1994       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1995       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1996       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1997 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1998       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1999 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2000 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2001 c     &  " eps2rt_om12",eps2rt_om12
2002 C Calculate whole angle-dependent part of epsilon and contributions
2003 C to its derivatives
2004       return
2005       end
2006
2007 C----------------------------------------------------------------------------
2008       subroutine sc_grad_T
2009       implicit real*8 (a-h,o-z)
2010       include 'DIMENSIONS'
2011       include 'COMMON.CHAIN'
2012       include 'COMMON.DERIV'
2013       include 'COMMON.CALC'
2014       include 'COMMON.IOUNITS'
2015       double precision dcosom1(3),dcosom2(3)
2016       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2017       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2018       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2019      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2020 c diagnostics only
2021 c      eom1=0.0d0
2022 c      eom2=0.0d0
2023 c      eom12=evdwij*eps1_om12
2024 c end diagnostics
2025 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2026 c     &  " sigder",sigder
2027 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2028 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2029       do k=1,3
2030         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2031         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2032       enddo
2033       do k=1,3
2034         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
2035       enddo
2036 c      write (iout,*) "gg",(gg(k),k=1,3)
2037       do k=1,3
2038         gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
2039      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2040      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2041         gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
2042      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2043      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2044 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2045 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2046 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2047 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2048       enddo
2049 C
2050 C Calculate the components of the gradient in DC and X
2051 C
2052 cgrad      do k=i,j-1
2053 cgrad        do l=1,3
2054 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2055 cgrad        enddo
2056 cgrad      enddo
2057       do l=1,3
2058         gvdwcT(l,i)=gvdwcT(l,i)-gg(l)
2059         gvdwcT(l,j)=gvdwcT(l,j)+gg(l)
2060       enddo
2061       return
2062       end
2063
2064 C----------------------------------------------------------------------------
2065       subroutine sc_grad
2066       implicit real*8 (a-h,o-z)
2067       include 'DIMENSIONS'
2068       include 'COMMON.CHAIN'
2069       include 'COMMON.DERIV'
2070       include 'COMMON.CALC'
2071       include 'COMMON.IOUNITS'
2072       double precision dcosom1(3),dcosom2(3)
2073       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2074       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2075       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2076      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2077 c diagnostics only
2078 c      eom1=0.0d0
2079 c      eom2=0.0d0
2080 c      eom12=evdwij*eps1_om12
2081 c end diagnostics
2082 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2083 c     &  " sigder",sigder
2084 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2085 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2086       do k=1,3
2087         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2088         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2089       enddo
2090       do k=1,3
2091         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
2092       enddo
2093 c      write (iout,*) "gg",(gg(k),k=1,3)
2094       do k=1,3
2095         gvdwx(k,i)=gvdwx(k,i)-gg(k)
2096      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2097      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2098         gvdwx(k,j)=gvdwx(k,j)+gg(k)
2099      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2100      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2101 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2102 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2103 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2104 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2105       enddo
2106 C
2107 C Calculate the components of the gradient in DC and X
2108 C
2109 cgrad      do k=i,j-1
2110 cgrad        do l=1,3
2111 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2112 cgrad        enddo
2113 cgrad      enddo
2114       do l=1,3
2115         gvdwc(l,i)=gvdwc(l,i)-gg(l)
2116         gvdwc(l,j)=gvdwc(l,j)+gg(l)
2117       enddo
2118       return
2119       end
2120 C-----------------------------------------------------------------------
2121       subroutine e_softsphere(evdw)
2122 C
2123 C This subroutine calculates the interaction energy of nonbonded side chains
2124 C assuming the LJ potential of interaction.
2125 C
2126       implicit real*8 (a-h,o-z)
2127       include 'DIMENSIONS'
2128       parameter (accur=1.0d-10)
2129       include 'COMMON.GEO'
2130       include 'COMMON.VAR'
2131       include 'COMMON.LOCAL'
2132       include 'COMMON.CHAIN'
2133       include 'COMMON.DERIV'
2134       include 'COMMON.INTERACT'
2135       include 'COMMON.TORSION'
2136       include 'COMMON.SBRIDGE'
2137       include 'COMMON.NAMES'
2138       include 'COMMON.IOUNITS'
2139       include 'COMMON.CONTACTS'
2140       dimension gg(3)
2141 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2142       evdw=0.0D0
2143       do i=iatsc_s,iatsc_e
2144         itypi=itype(i)
2145         itypi1=itype(i+1)
2146         xi=c(1,nres+i)
2147         yi=c(2,nres+i)
2148         zi=c(3,nres+i)
2149 C
2150 C Calculate SC interaction energy.
2151 C
2152         do iint=1,nint_gr(i)
2153 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2154 cd   &                  'iend=',iend(i,iint)
2155           do j=istart(i,iint),iend(i,iint)
2156             itypj=itype(j)
2157             xj=c(1,nres+j)-xi
2158             yj=c(2,nres+j)-yi
2159             zj=c(3,nres+j)-zi
2160             rij=xj*xj+yj*yj+zj*zj
2161 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2162             r0ij=r0(itypi,itypj)
2163             r0ijsq=r0ij*r0ij
2164 c            print *,i,j,r0ij,dsqrt(rij)
2165             if (rij.lt.r0ijsq) then
2166               evdwij=0.25d0*(rij-r0ijsq)**2
2167               fac=rij-r0ijsq
2168             else
2169               evdwij=0.0d0
2170               fac=0.0d0
2171             endif
2172             evdw=evdw+evdwij
2173 C
2174 C Calculate the components of the gradient in DC and X
2175 C
2176             gg(1)=xj*fac
2177             gg(2)=yj*fac
2178             gg(3)=zj*fac
2179             do k=1,3
2180               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2181               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2182               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2183               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2184             enddo
2185 cgrad            do k=i,j-1
2186 cgrad              do l=1,3
2187 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2188 cgrad              enddo
2189 cgrad            enddo
2190           enddo ! j
2191         enddo ! iint
2192       enddo ! i
2193       return
2194       end
2195 C--------------------------------------------------------------------------
2196       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2197      &              eello_turn4)
2198 C
2199 C Soft-sphere potential of p-p interaction
2200 C
2201       implicit real*8 (a-h,o-z)
2202       include 'DIMENSIONS'
2203       include 'COMMON.CONTROL'
2204       include 'COMMON.IOUNITS'
2205       include 'COMMON.GEO'
2206       include 'COMMON.VAR'
2207       include 'COMMON.LOCAL'
2208       include 'COMMON.CHAIN'
2209       include 'COMMON.DERIV'
2210       include 'COMMON.INTERACT'
2211       include 'COMMON.CONTACTS'
2212       include 'COMMON.TORSION'
2213       include 'COMMON.VECTORS'
2214       include 'COMMON.FFIELD'
2215       dimension ggg(3)
2216 cd      write(iout,*) 'In EELEC_soft_sphere'
2217       ees=0.0D0
2218       evdw1=0.0D0
2219       eel_loc=0.0d0
2220       eello_turn3=0.0d0
2221       eello_turn4=0.0d0
2222       ind=0
2223       do i=iatel_s,iatel_e
2224         dxi=dc(1,i)
2225         dyi=dc(2,i)
2226         dzi=dc(3,i)
2227         xmedi=c(1,i)+0.5d0*dxi
2228         ymedi=c(2,i)+0.5d0*dyi
2229         zmedi=c(3,i)+0.5d0*dzi
2230         num_conti=0
2231 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2232         do j=ielstart(i),ielend(i)
2233           ind=ind+1
2234           iteli=itel(i)
2235           itelj=itel(j)
2236           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2237           r0ij=rpp(iteli,itelj)
2238           r0ijsq=r0ij*r0ij
2239           dxj=dc(1,j)
2240           dyj=dc(2,j)
2241           dzj=dc(3,j)
2242           xj=c(1,j)+0.5D0*dxj-xmedi
2243           yj=c(2,j)+0.5D0*dyj-ymedi
2244           zj=c(3,j)+0.5D0*dzj-zmedi
2245           rij=xj*xj+yj*yj+zj*zj
2246           if (rij.lt.r0ijsq) then
2247             evdw1ij=0.25d0*(rij-r0ijsq)**2
2248             fac=rij-r0ijsq
2249           else
2250             evdw1ij=0.0d0
2251             fac=0.0d0
2252           endif
2253           evdw1=evdw1+evdw1ij
2254 C
2255 C Calculate contributions to the Cartesian gradient.
2256 C
2257           ggg(1)=fac*xj
2258           ggg(2)=fac*yj
2259           ggg(3)=fac*zj
2260           do k=1,3
2261             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2262             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2263           enddo
2264 *
2265 * Loop over residues i+1 thru j-1.
2266 *
2267 cgrad          do k=i+1,j-1
2268 cgrad            do l=1,3
2269 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2270 cgrad            enddo
2271 cgrad          enddo
2272         enddo ! j
2273       enddo   ! i
2274 cgrad      do i=nnt,nct-1
2275 cgrad        do k=1,3
2276 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2277 cgrad        enddo
2278 cgrad        do j=i+1,nct-1
2279 cgrad          do k=1,3
2280 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2281 cgrad          enddo
2282 cgrad        enddo
2283 cgrad      enddo
2284       return
2285       end
2286 c------------------------------------------------------------------------------
2287       subroutine vec_and_deriv
2288       implicit real*8 (a-h,o-z)
2289       include 'DIMENSIONS'
2290 #ifdef MPI
2291       include 'mpif.h'
2292 #endif
2293       include 'COMMON.IOUNITS'
2294       include 'COMMON.GEO'
2295       include 'COMMON.VAR'
2296       include 'COMMON.LOCAL'
2297       include 'COMMON.CHAIN'
2298       include 'COMMON.VECTORS'
2299       include 'COMMON.SETUP'
2300       include 'COMMON.TIME1'
2301       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2302 C Compute the local reference systems. For reference system (i), the
2303 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2304 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2305 #ifdef PARVEC
2306       do i=ivec_start,ivec_end
2307 #else
2308       do i=1,nres-1
2309 #endif
2310           if (i.eq.nres-1) then
2311 C Case of the last full residue
2312 C Compute the Z-axis
2313             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2314             costh=dcos(pi-theta(nres))
2315             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2316             do k=1,3
2317               uz(k,i)=fac*uz(k,i)
2318             enddo
2319 C Compute the derivatives of uz
2320             uzder(1,1,1)= 0.0d0
2321             uzder(2,1,1)=-dc_norm(3,i-1)
2322             uzder(3,1,1)= dc_norm(2,i-1)
2323             uzder(1,2,1)= dc_norm(3,i-1)
2324             uzder(2,2,1)= 0.0d0
2325             uzder(3,2,1)=-dc_norm(1,i-1)
2326             uzder(1,3,1)=-dc_norm(2,i-1)
2327             uzder(2,3,1)= dc_norm(1,i-1)
2328             uzder(3,3,1)= 0.0d0
2329             uzder(1,1,2)= 0.0d0
2330             uzder(2,1,2)= dc_norm(3,i)
2331             uzder(3,1,2)=-dc_norm(2,i)
2332             uzder(1,2,2)=-dc_norm(3,i)
2333             uzder(2,2,2)= 0.0d0
2334             uzder(3,2,2)= dc_norm(1,i)
2335             uzder(1,3,2)= dc_norm(2,i)
2336             uzder(2,3,2)=-dc_norm(1,i)
2337             uzder(3,3,2)= 0.0d0
2338 C Compute the Y-axis
2339             facy=fac
2340             do k=1,3
2341               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2342             enddo
2343 C Compute the derivatives of uy
2344             do j=1,3
2345               do k=1,3
2346                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2347      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2348                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2349               enddo
2350               uyder(j,j,1)=uyder(j,j,1)-costh
2351               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2352             enddo
2353             do j=1,2
2354               do k=1,3
2355                 do l=1,3
2356                   uygrad(l,k,j,i)=uyder(l,k,j)
2357                   uzgrad(l,k,j,i)=uzder(l,k,j)
2358                 enddo
2359               enddo
2360             enddo
2361             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2362             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2363             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2364             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2365           else
2366 C Other residues
2367 C Compute the Z-axis
2368             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2369             costh=dcos(pi-theta(i+2))
2370             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2371             do k=1,3
2372               uz(k,i)=fac*uz(k,i)
2373             enddo
2374 C Compute the derivatives of uz
2375             uzder(1,1,1)= 0.0d0
2376             uzder(2,1,1)=-dc_norm(3,i+1)
2377             uzder(3,1,1)= dc_norm(2,i+1)
2378             uzder(1,2,1)= dc_norm(3,i+1)
2379             uzder(2,2,1)= 0.0d0
2380             uzder(3,2,1)=-dc_norm(1,i+1)
2381             uzder(1,3,1)=-dc_norm(2,i+1)
2382             uzder(2,3,1)= dc_norm(1,i+1)
2383             uzder(3,3,1)= 0.0d0
2384             uzder(1,1,2)= 0.0d0
2385             uzder(2,1,2)= dc_norm(3,i)
2386             uzder(3,1,2)=-dc_norm(2,i)
2387             uzder(1,2,2)=-dc_norm(3,i)
2388             uzder(2,2,2)= 0.0d0
2389             uzder(3,2,2)= dc_norm(1,i)
2390             uzder(1,3,2)= dc_norm(2,i)
2391             uzder(2,3,2)=-dc_norm(1,i)
2392             uzder(3,3,2)= 0.0d0
2393 C Compute the Y-axis
2394             facy=fac
2395             do k=1,3
2396               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2397             enddo
2398 C Compute the derivatives of uy
2399             do j=1,3
2400               do k=1,3
2401                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2402      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2403                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2404               enddo
2405               uyder(j,j,1)=uyder(j,j,1)-costh
2406               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2407             enddo
2408             do j=1,2
2409               do k=1,3
2410                 do l=1,3
2411                   uygrad(l,k,j,i)=uyder(l,k,j)
2412                   uzgrad(l,k,j,i)=uzder(l,k,j)
2413                 enddo
2414               enddo
2415             enddo
2416             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2417             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2418             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2419             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2420           endif
2421       enddo
2422       do i=1,nres-1
2423         vbld_inv_temp(1)=vbld_inv(i+1)
2424         if (i.lt.nres-1) then
2425           vbld_inv_temp(2)=vbld_inv(i+2)
2426           else
2427           vbld_inv_temp(2)=vbld_inv(i)
2428           endif
2429         do j=1,2
2430           do k=1,3
2431             do l=1,3
2432               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2433               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2434             enddo
2435           enddo
2436         enddo
2437       enddo
2438 #if defined(PARVEC) && defined(MPI)
2439       if (nfgtasks1.gt.1) then
2440         time00=MPI_Wtime()
2441 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2442 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2443 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2444         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2445      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2446      &   FG_COMM1,IERR)
2447         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2448      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2449      &   FG_COMM1,IERR)
2450         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2451      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2452      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2453         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2454      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2455      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2456         time_gather=time_gather+MPI_Wtime()-time00
2457       endif
2458 c      if (fg_rank.eq.0) then
2459 c        write (iout,*) "Arrays UY and UZ"
2460 c        do i=1,nres-1
2461 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2462 c     &     (uz(k,i),k=1,3)
2463 c        enddo
2464 c      endif
2465 #endif
2466       return
2467       end
2468 C-----------------------------------------------------------------------------
2469       subroutine check_vecgrad
2470       implicit real*8 (a-h,o-z)
2471       include 'DIMENSIONS'
2472       include 'COMMON.IOUNITS'
2473       include 'COMMON.GEO'
2474       include 'COMMON.VAR'
2475       include 'COMMON.LOCAL'
2476       include 'COMMON.CHAIN'
2477       include 'COMMON.VECTORS'
2478       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2479       dimension uyt(3,maxres),uzt(3,maxres)
2480       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2481       double precision delta /1.0d-7/
2482       call vec_and_deriv
2483 cd      do i=1,nres
2484 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2485 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2486 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2487 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2488 cd     &     (dc_norm(if90,i),if90=1,3)
2489 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2490 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2491 cd          write(iout,'(a)')
2492 cd      enddo
2493       do i=1,nres
2494         do j=1,2
2495           do k=1,3
2496             do l=1,3
2497               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2498               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2499             enddo
2500           enddo
2501         enddo
2502       enddo
2503       call vec_and_deriv
2504       do i=1,nres
2505         do j=1,3
2506           uyt(j,i)=uy(j,i)
2507           uzt(j,i)=uz(j,i)
2508         enddo
2509       enddo
2510       do i=1,nres
2511 cd        write (iout,*) 'i=',i
2512         do k=1,3
2513           erij(k)=dc_norm(k,i)
2514         enddo
2515         do j=1,3
2516           do k=1,3
2517             dc_norm(k,i)=erij(k)
2518           enddo
2519           dc_norm(j,i)=dc_norm(j,i)+delta
2520 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2521 c          do k=1,3
2522 c            dc_norm(k,i)=dc_norm(k,i)/fac
2523 c          enddo
2524 c          write (iout,*) (dc_norm(k,i),k=1,3)
2525 c          write (iout,*) (erij(k),k=1,3)
2526           call vec_and_deriv
2527           do k=1,3
2528             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2529             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2530             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2531             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2532           enddo
2533 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2534 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2535 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2536         enddo
2537         do k=1,3
2538           dc_norm(k,i)=erij(k)
2539         enddo
2540 cd        do k=1,3
2541 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2542 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2543 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2544 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2545 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2546 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2547 cd          write (iout,'(a)')
2548 cd        enddo
2549       enddo
2550       return
2551       end
2552 C--------------------------------------------------------------------------
2553       subroutine set_matrices
2554       implicit real*8 (a-h,o-z)
2555       include 'DIMENSIONS'
2556 #ifdef MPI
2557       include "mpif.h"
2558       include "COMMON.SETUP"
2559       integer IERR
2560       integer status(MPI_STATUS_SIZE)
2561 #endif
2562       include 'COMMON.IOUNITS'
2563       include 'COMMON.GEO'
2564       include 'COMMON.VAR'
2565       include 'COMMON.LOCAL'
2566       include 'COMMON.CHAIN'
2567       include 'COMMON.DERIV'
2568       include 'COMMON.INTERACT'
2569       include 'COMMON.CONTACTS'
2570       include 'COMMON.TORSION'
2571       include 'COMMON.VECTORS'
2572       include 'COMMON.FFIELD'
2573       double precision auxvec(2),auxmat(2,2)
2574 C
2575 C Compute the virtual-bond-torsional-angle dependent quantities needed
2576 C to calculate the el-loc multibody terms of various order.
2577 C
2578 #ifdef PARMAT
2579       do i=ivec_start+2,ivec_end+2
2580 #else
2581       do i=3,nres+1
2582 #endif
2583         if (i .lt. nres+1) then
2584           sin1=dsin(phi(i))
2585           cos1=dcos(phi(i))
2586           sintab(i-2)=sin1
2587           costab(i-2)=cos1
2588           obrot(1,i-2)=cos1
2589           obrot(2,i-2)=sin1
2590           sin2=dsin(2*phi(i))
2591           cos2=dcos(2*phi(i))
2592           sintab2(i-2)=sin2
2593           costab2(i-2)=cos2
2594           obrot2(1,i-2)=cos2
2595           obrot2(2,i-2)=sin2
2596           Ug(1,1,i-2)=-cos1
2597           Ug(1,2,i-2)=-sin1
2598           Ug(2,1,i-2)=-sin1
2599           Ug(2,2,i-2)= cos1
2600           Ug2(1,1,i-2)=-cos2
2601           Ug2(1,2,i-2)=-sin2
2602           Ug2(2,1,i-2)=-sin2
2603           Ug2(2,2,i-2)= cos2
2604         else
2605           costab(i-2)=1.0d0
2606           sintab(i-2)=0.0d0
2607           obrot(1,i-2)=1.0d0
2608           obrot(2,i-2)=0.0d0
2609           obrot2(1,i-2)=0.0d0
2610           obrot2(2,i-2)=0.0d0
2611           Ug(1,1,i-2)=1.0d0
2612           Ug(1,2,i-2)=0.0d0
2613           Ug(2,1,i-2)=0.0d0
2614           Ug(2,2,i-2)=1.0d0
2615           Ug2(1,1,i-2)=0.0d0
2616           Ug2(1,2,i-2)=0.0d0
2617           Ug2(2,1,i-2)=0.0d0
2618           Ug2(2,2,i-2)=0.0d0
2619         endif
2620         if (i .gt. 3 .and. i .lt. nres+1) then
2621           obrot_der(1,i-2)=-sin1
2622           obrot_der(2,i-2)= cos1
2623           Ugder(1,1,i-2)= sin1
2624           Ugder(1,2,i-2)=-cos1
2625           Ugder(2,1,i-2)=-cos1
2626           Ugder(2,2,i-2)=-sin1
2627           dwacos2=cos2+cos2
2628           dwasin2=sin2+sin2
2629           obrot2_der(1,i-2)=-dwasin2
2630           obrot2_der(2,i-2)= dwacos2
2631           Ug2der(1,1,i-2)= dwasin2
2632           Ug2der(1,2,i-2)=-dwacos2
2633           Ug2der(2,1,i-2)=-dwacos2
2634           Ug2der(2,2,i-2)=-dwasin2
2635         else
2636           obrot_der(1,i-2)=0.0d0
2637           obrot_der(2,i-2)=0.0d0
2638           Ugder(1,1,i-2)=0.0d0
2639           Ugder(1,2,i-2)=0.0d0
2640           Ugder(2,1,i-2)=0.0d0
2641           Ugder(2,2,i-2)=0.0d0
2642           obrot2_der(1,i-2)=0.0d0
2643           obrot2_der(2,i-2)=0.0d0
2644           Ug2der(1,1,i-2)=0.0d0
2645           Ug2der(1,2,i-2)=0.0d0
2646           Ug2der(2,1,i-2)=0.0d0
2647           Ug2der(2,2,i-2)=0.0d0
2648         endif
2649 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2650         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2651           iti = itortyp(itype(i-2))
2652         else
2653           iti=ntortyp+1
2654         endif
2655 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2656         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2657           iti1 = itortyp(itype(i-1))
2658         else
2659           iti1=ntortyp+1
2660         endif
2661 cd        write (iout,*) '*******i',i,' iti1',iti
2662 cd        write (iout,*) 'b1',b1(:,iti)
2663 cd        write (iout,*) 'b2',b2(:,iti)
2664 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2665 c        if (i .gt. iatel_s+2) then
2666         if (i .gt. nnt+2) then
2667           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2668           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2669           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2670      &    then
2671           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2672           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2673           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2674           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2675           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2676           endif
2677         else
2678           do k=1,2
2679             Ub2(k,i-2)=0.0d0
2680             Ctobr(k,i-2)=0.0d0
2681             Dtobr2(k,i-2)=0.0d0
2682             do l=1,2
2683               EUg(l,k,i-2)=0.0d0
2684               CUg(l,k,i-2)=0.0d0
2685               DUg(l,k,i-2)=0.0d0
2686               DtUg2(l,k,i-2)=0.0d0
2687             enddo
2688           enddo
2689         endif
2690         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2691         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2692         do k=1,2
2693           muder(k,i-2)=Ub2der(k,i-2)
2694         enddo
2695 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2696         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2697           iti1 = itortyp(itype(i-1))
2698         else
2699           iti1=ntortyp+1
2700         endif
2701         do k=1,2
2702           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2703         enddo
2704 cd        write (iout,*) 'mu ',mu(:,i-2)
2705 cd        write (iout,*) 'mu1',mu1(:,i-2)
2706 cd        write (iout,*) 'mu2',mu2(:,i-2)
2707         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2708      &  then
2709         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2710         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2711         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2712         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2713         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2714 C Vectors and matrices dependent on a single virtual-bond dihedral.
2715         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2716         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2717         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2718         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2719         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2720         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2721         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2722         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2723         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2724         endif
2725       enddo
2726 C Matrices dependent on two consecutive virtual-bond dihedrals.
2727 C The order of matrices is from left to right.
2728       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2729      &then
2730 c      do i=max0(ivec_start,2),ivec_end
2731       do i=2,nres-1
2732         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2733         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2734         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2735         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2736         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2737         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2738         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2739         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2740       enddo
2741       endif
2742 #if defined(MPI) && defined(PARMAT)
2743 #ifdef DEBUG
2744 c      if (fg_rank.eq.0) then
2745         write (iout,*) "Arrays UG and UGDER before GATHER"
2746         do i=1,nres-1
2747           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2748      &     ((ug(l,k,i),l=1,2),k=1,2),
2749      &     ((ugder(l,k,i),l=1,2),k=1,2)
2750         enddo
2751         write (iout,*) "Arrays UG2 and UG2DER"
2752         do i=1,nres-1
2753           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2754      &     ((ug2(l,k,i),l=1,2),k=1,2),
2755      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2756         enddo
2757         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2758         do i=1,nres-1
2759           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2760      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2761      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2762         enddo
2763         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2764         do i=1,nres-1
2765           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2766      &     costab(i),sintab(i),costab2(i),sintab2(i)
2767         enddo
2768         write (iout,*) "Array MUDER"
2769         do i=1,nres-1
2770           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2771         enddo
2772 c      endif
2773 #endif
2774       if (nfgtasks.gt.1) then
2775         time00=MPI_Wtime()
2776 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2777 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2778 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2779 #ifdef MATGATHER
2780         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2781      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2782      &   FG_COMM1,IERR)
2783         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2784      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2785      &   FG_COMM1,IERR)
2786         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2787      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2788      &   FG_COMM1,IERR)
2789         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2790      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2791      &   FG_COMM1,IERR)
2792         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2793      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2794      &   FG_COMM1,IERR)
2795         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2796      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2797      &   FG_COMM1,IERR)
2798         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2799      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2800      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2801         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2802      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2803      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2804         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2805      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2806      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2807         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2808      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2809      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2810         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2811      &  then
2812         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2813      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2814      &   FG_COMM1,IERR)
2815         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2816      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2817      &   FG_COMM1,IERR)
2818         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2819      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2820      &   FG_COMM1,IERR)
2821        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2822      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2823      &   FG_COMM1,IERR)
2824         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2825      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2826      &   FG_COMM1,IERR)
2827         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2828      &   ivec_count(fg_rank1),
2829      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2830      &   FG_COMM1,IERR)
2831         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2832      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2833      &   FG_COMM1,IERR)
2834         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2835      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2836      &   FG_COMM1,IERR)
2837         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2838      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2839      &   FG_COMM1,IERR)
2840         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2841      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2842      &   FG_COMM1,IERR)
2843         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2844      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2845      &   FG_COMM1,IERR)
2846         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2847      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2848      &   FG_COMM1,IERR)
2849         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2850      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2851      &   FG_COMM1,IERR)
2852         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2853      &   ivec_count(fg_rank1),
2854      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2855      &   FG_COMM1,IERR)
2856         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2857      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2858      &   FG_COMM1,IERR)
2859        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2860      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2861      &   FG_COMM1,IERR)
2862         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2863      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2864      &   FG_COMM1,IERR)
2865        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2866      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2867      &   FG_COMM1,IERR)
2868         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2869      &   ivec_count(fg_rank1),
2870      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2871      &   FG_COMM1,IERR)
2872         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2873      &   ivec_count(fg_rank1),
2874      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2875      &   FG_COMM1,IERR)
2876         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2877      &   ivec_count(fg_rank1),
2878      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2879      &   MPI_MAT2,FG_COMM1,IERR)
2880         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2881      &   ivec_count(fg_rank1),
2882      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2883      &   MPI_MAT2,FG_COMM1,IERR)
2884         endif
2885 #else
2886 c Passes matrix info through the ring
2887       isend=fg_rank1
2888       irecv=fg_rank1-1
2889       if (irecv.lt.0) irecv=nfgtasks1-1
2890       iprev=irecv
2891       inext=fg_rank1+1
2892       if (inext.ge.nfgtasks1) inext=0
2893       do i=1,nfgtasks1-1
2894 c        write (iout,*) "isend",isend," irecv",irecv
2895 c        call flush(iout)
2896         lensend=lentyp(isend)
2897         lenrecv=lentyp(irecv)
2898 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2899 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2900 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2901 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2902 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2903 c        write (iout,*) "Gather ROTAT1"
2904 c        call flush(iout)
2905 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2906 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2907 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2908 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2909 c        write (iout,*) "Gather ROTAT2"
2910 c        call flush(iout)
2911         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2912      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2913      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2914      &   iprev,4400+irecv,FG_COMM,status,IERR)
2915 c        write (iout,*) "Gather ROTAT_OLD"
2916 c        call flush(iout)
2917         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2918      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2919      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2920      &   iprev,5500+irecv,FG_COMM,status,IERR)
2921 c        write (iout,*) "Gather PRECOMP11"
2922 c        call flush(iout)
2923         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2924      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2925      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2926      &   iprev,6600+irecv,FG_COMM,status,IERR)
2927 c        write (iout,*) "Gather PRECOMP12"
2928 c        call flush(iout)
2929         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2930      &  then
2931         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2932      &   MPI_ROTAT2(lensend),inext,7700+isend,
2933      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2934      &   iprev,7700+irecv,FG_COMM,status,IERR)
2935 c        write (iout,*) "Gather PRECOMP21"
2936 c        call flush(iout)
2937         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2938      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2939      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2940      &   iprev,8800+irecv,FG_COMM,status,IERR)
2941 c        write (iout,*) "Gather PRECOMP22"
2942 c        call flush(iout)
2943         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2944      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2945      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2946      &   MPI_PRECOMP23(lenrecv),
2947      &   iprev,9900+irecv,FG_COMM,status,IERR)
2948 c        write (iout,*) "Gather PRECOMP23"
2949 c        call flush(iout)
2950         endif
2951         isend=irecv
2952         irecv=irecv-1
2953         if (irecv.lt.0) irecv=nfgtasks1-1
2954       enddo
2955 #endif
2956         time_gather=time_gather+MPI_Wtime()-time00
2957       endif
2958 #ifdef DEBUG
2959 c      if (fg_rank.eq.0) then
2960         write (iout,*) "Arrays UG and UGDER"
2961         do i=1,nres-1
2962           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2963      &     ((ug(l,k,i),l=1,2),k=1,2),
2964      &     ((ugder(l,k,i),l=1,2),k=1,2)
2965         enddo
2966         write (iout,*) "Arrays UG2 and UG2DER"
2967         do i=1,nres-1
2968           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2969      &     ((ug2(l,k,i),l=1,2),k=1,2),
2970      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2971         enddo
2972         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2973         do i=1,nres-1
2974           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2975      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2976      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2977         enddo
2978         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2979         do i=1,nres-1
2980           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2981      &     costab(i),sintab(i),costab2(i),sintab2(i)
2982         enddo
2983         write (iout,*) "Array MUDER"
2984         do i=1,nres-1
2985           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2986         enddo
2987 c      endif
2988 #endif
2989 #endif
2990 cd      do i=1,nres
2991 cd        iti = itortyp(itype(i))
2992 cd        write (iout,*) i
2993 cd        do j=1,2
2994 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2995 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2996 cd        enddo
2997 cd      enddo
2998       return
2999       end
3000 C--------------------------------------------------------------------------
3001       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3002 C
3003 C This subroutine calculates the average interaction energy and its gradient
3004 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3005 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3006 C The potential depends both on the distance of peptide-group centers and on
3007 C the orientation of the CA-CA virtual bonds.
3008 C
3009       implicit real*8 (a-h,o-z)
3010 #ifdef MPI
3011       include 'mpif.h'
3012 #endif
3013       include 'DIMENSIONS'
3014       include 'COMMON.CONTROL'
3015       include 'COMMON.SETUP'
3016       include 'COMMON.IOUNITS'
3017       include 'COMMON.GEO'
3018       include 'COMMON.VAR'
3019       include 'COMMON.LOCAL'
3020       include 'COMMON.CHAIN'
3021       include 'COMMON.DERIV'
3022       include 'COMMON.INTERACT'
3023       include 'COMMON.CONTACTS'
3024       include 'COMMON.TORSION'
3025       include 'COMMON.VECTORS'
3026       include 'COMMON.FFIELD'
3027       include 'COMMON.TIME1'
3028       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3029      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3030       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3031      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3032       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3033      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3034      &    num_conti,j1,j2
3035 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3036 #ifdef MOMENT
3037       double precision scal_el /1.0d0/
3038 #else
3039       double precision scal_el /0.5d0/
3040 #endif
3041 C 12/13/98
3042 C 13-go grudnia roku pamietnego...
3043       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3044      &                   0.0d0,1.0d0,0.0d0,
3045      &                   0.0d0,0.0d0,1.0d0/
3046 cd      write(iout,*) 'In EELEC'
3047 cd      do i=1,nloctyp
3048 cd        write(iout,*) 'Type',i
3049 cd        write(iout,*) 'B1',B1(:,i)
3050 cd        write(iout,*) 'B2',B2(:,i)
3051 cd        write(iout,*) 'CC',CC(:,:,i)
3052 cd        write(iout,*) 'DD',DD(:,:,i)
3053 cd        write(iout,*) 'EE',EE(:,:,i)
3054 cd      enddo
3055 cd      call check_vecgrad
3056 cd      stop
3057       if (icheckgrad.eq.1) then
3058         do i=1,nres-1
3059           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3060           do k=1,3
3061             dc_norm(k,i)=dc(k,i)*fac
3062           enddo
3063 c          write (iout,*) 'i',i,' fac',fac
3064         enddo
3065       endif
3066       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3067      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3068      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3069 c        call vec_and_deriv
3070 #ifdef TIMING
3071         time01=MPI_Wtime()
3072 #endif
3073         call set_matrices
3074 #ifdef TIMING
3075         time_mat=time_mat+MPI_Wtime()-time01
3076 #endif
3077       endif
3078 cd      do i=1,nres-1
3079 cd        write (iout,*) 'i=',i
3080 cd        do k=1,3
3081 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3082 cd        enddo
3083 cd        do k=1,3
3084 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3085 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3086 cd        enddo
3087 cd      enddo
3088       t_eelecij=0.0d0
3089       ees=0.0D0
3090       evdw1=0.0D0
3091       eel_loc=0.0d0
3092       eello_turn3=0.0d0
3093       eello_turn4=0.0d0
3094       ind=0
3095       do i=1,nres
3096         num_cont_hb(i)=0
3097       enddo
3098 cd      print '(a)','Enter EELEC'
3099 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3100       do i=1,nres
3101         gel_loc_loc(i)=0.0d0
3102         gcorr_loc(i)=0.0d0
3103       enddo
3104 c
3105 c
3106 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3107 C
3108 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3109 C
3110       do i=iturn3_start,iturn3_end
3111         dxi=dc(1,i)
3112         dyi=dc(2,i)
3113         dzi=dc(3,i)
3114         dx_normi=dc_norm(1,i)
3115         dy_normi=dc_norm(2,i)
3116         dz_normi=dc_norm(3,i)
3117         xmedi=c(1,i)+0.5d0*dxi
3118         ymedi=c(2,i)+0.5d0*dyi
3119         zmedi=c(3,i)+0.5d0*dzi
3120         num_conti=0
3121         call eelecij(i,i+2,ees,evdw1,eel_loc)
3122         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3123         num_cont_hb(i)=num_conti
3124       enddo
3125       do i=iturn4_start,iturn4_end
3126         dxi=dc(1,i)
3127         dyi=dc(2,i)
3128         dzi=dc(3,i)
3129         dx_normi=dc_norm(1,i)
3130         dy_normi=dc_norm(2,i)
3131         dz_normi=dc_norm(3,i)
3132         xmedi=c(1,i)+0.5d0*dxi
3133         ymedi=c(2,i)+0.5d0*dyi
3134         zmedi=c(3,i)+0.5d0*dzi
3135         num_conti=num_cont_hb(i)
3136         call eelecij(i,i+3,ees,evdw1,eel_loc)
3137         if (wturn4.gt.0.0d0) call eturn4(i,eello_turn4)
3138         num_cont_hb(i)=num_conti
3139       enddo   ! i
3140 c
3141 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3142 c
3143       do i=iatel_s,iatel_e
3144         dxi=dc(1,i)
3145         dyi=dc(2,i)
3146         dzi=dc(3,i)
3147         dx_normi=dc_norm(1,i)
3148         dy_normi=dc_norm(2,i)
3149         dz_normi=dc_norm(3,i)
3150         xmedi=c(1,i)+0.5d0*dxi
3151         ymedi=c(2,i)+0.5d0*dyi
3152         zmedi=c(3,i)+0.5d0*dzi
3153 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3154         num_conti=num_cont_hb(i)
3155         do j=ielstart(i),ielend(i)
3156           call eelecij(i,j,ees,evdw1,eel_loc)
3157         enddo ! j
3158         num_cont_hb(i)=num_conti
3159       enddo   ! i
3160 c      write (iout,*) "Number of loop steps in EELEC:",ind
3161 cd      do i=1,nres
3162 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3163 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3164 cd      enddo
3165 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3166 ccc      eel_loc=eel_loc+eello_turn3
3167 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3168       return
3169       end
3170 C-------------------------------------------------------------------------------
3171       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3172       implicit real*8 (a-h,o-z)
3173       include 'DIMENSIONS'
3174 #ifdef MPI
3175       include "mpif.h"
3176 #endif
3177       include 'COMMON.CONTROL'
3178       include 'COMMON.IOUNITS'
3179       include 'COMMON.GEO'
3180       include 'COMMON.VAR'
3181       include 'COMMON.LOCAL'
3182       include 'COMMON.CHAIN'
3183       include 'COMMON.DERIV'
3184       include 'COMMON.INTERACT'
3185       include 'COMMON.CONTACTS'
3186       include 'COMMON.TORSION'
3187       include 'COMMON.VECTORS'
3188       include 'COMMON.FFIELD'
3189       include 'COMMON.TIME1'
3190       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3191      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3192       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3193      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3194       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3195      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3196      &    num_conti,j1,j2
3197 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3198 #ifdef MOMENT
3199       double precision scal_el /1.0d0/
3200 #else
3201       double precision scal_el /0.5d0/
3202 #endif
3203 C 12/13/98
3204 C 13-go grudnia roku pamietnego...
3205       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3206      &                   0.0d0,1.0d0,0.0d0,
3207      &                   0.0d0,0.0d0,1.0d0/
3208 c          time00=MPI_Wtime()
3209 cd      write (iout,*) "eelecij",i,j
3210 c          ind=ind+1
3211           iteli=itel(i)
3212           itelj=itel(j)
3213           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3214           aaa=app(iteli,itelj)
3215           bbb=bpp(iteli,itelj)
3216           ael6i=ael6(iteli,itelj)
3217           ael3i=ael3(iteli,itelj)
3218           dxj=dc(1,j)
3219           dyj=dc(2,j)
3220           dzj=dc(3,j)
3221           dx_normj=dc_norm(1,j)
3222           dy_normj=dc_norm(2,j)
3223           dz_normj=dc_norm(3,j)
3224           xj=c(1,j)+0.5D0*dxj-xmedi
3225           yj=c(2,j)+0.5D0*dyj-ymedi
3226           zj=c(3,j)+0.5D0*dzj-zmedi
3227           rij=xj*xj+yj*yj+zj*zj
3228           rrmij=1.0D0/rij
3229           rij=dsqrt(rij)
3230           rmij=1.0D0/rij
3231           r3ij=rrmij*rmij
3232           r6ij=r3ij*r3ij
3233           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3234           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3235           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3236           fac=cosa-3.0D0*cosb*cosg
3237           ev1=aaa*r6ij*r6ij
3238 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3239           if (j.eq.i+2) ev1=scal_el*ev1
3240           ev2=bbb*r6ij
3241           fac3=ael6i*r6ij
3242           fac4=ael3i*r3ij
3243           evdwij=ev1+ev2
3244           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3245           el2=fac4*fac
3246           eesij=el1+el2
3247 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3248           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3249           ees=ees+eesij
3250           evdw1=evdw1+evdwij
3251 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3252 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3253 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3254 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3255
3256           if (energy_dec) then
3257               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3258               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3259           endif
3260
3261 C
3262 C Calculate contributions to the Cartesian gradient.
3263 C
3264 #ifdef SPLITELE
3265           facvdw=-6*rrmij*(ev1+evdwij)
3266           facel=-3*rrmij*(el1+eesij)
3267           fac1=fac
3268           erij(1)=xj*rmij
3269           erij(2)=yj*rmij
3270           erij(3)=zj*rmij
3271 *
3272 * Radial derivatives. First process both termini of the fragment (i,j)
3273 *
3274           ggg(1)=facel*xj
3275           ggg(2)=facel*yj
3276           ggg(3)=facel*zj
3277 c          do k=1,3
3278 c            ghalf=0.5D0*ggg(k)
3279 c            gelc(k,i)=gelc(k,i)+ghalf
3280 c            gelc(k,j)=gelc(k,j)+ghalf
3281 c          enddo
3282 c 9/28/08 AL Gradient compotents will be summed only at the end
3283           do k=1,3
3284             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3285             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3286           enddo
3287 *
3288 * Loop over residues i+1 thru j-1.
3289 *
3290 cgrad          do k=i+1,j-1
3291 cgrad            do l=1,3
3292 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3293 cgrad            enddo
3294 cgrad          enddo
3295           ggg(1)=facvdw*xj
3296           ggg(2)=facvdw*yj
3297           ggg(3)=facvdw*zj
3298 c          do k=1,3
3299 c            ghalf=0.5D0*ggg(k)
3300 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3301 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3302 c          enddo
3303 c 9/28/08 AL Gradient compotents will be summed only at the end
3304           do k=1,3
3305             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3306             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3307           enddo
3308 *
3309 * Loop over residues i+1 thru j-1.
3310 *
3311 cgrad          do k=i+1,j-1
3312 cgrad            do l=1,3
3313 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3314 cgrad            enddo
3315 cgrad          enddo
3316 #else
3317           facvdw=ev1+evdwij
3318           facel=el1+eesij
3319           fac1=fac
3320           fac=-3*rrmij*(facvdw+facvdw+facel)
3321           erij(1)=xj*rmij
3322           erij(2)=yj*rmij
3323           erij(3)=zj*rmij
3324 *
3325 * Radial derivatives. First process both termini of the fragment (i,j)
3326 *
3327           ggg(1)=fac*xj
3328           ggg(2)=fac*yj
3329           ggg(3)=fac*zj
3330 c          do k=1,3
3331 c            ghalf=0.5D0*ggg(k)
3332 c            gelc(k,i)=gelc(k,i)+ghalf
3333 c            gelc(k,j)=gelc(k,j)+ghalf
3334 c          enddo
3335 c 9/28/08 AL Gradient compotents will be summed only at the end
3336           do k=1,3
3337             gelc_long(k,j)=gelc(k,j)+ggg(k)
3338             gelc_long(k,i)=gelc(k,i)-ggg(k)
3339           enddo
3340 *
3341 * Loop over residues i+1 thru j-1.
3342 *
3343 cgrad          do k=i+1,j-1
3344 cgrad            do l=1,3
3345 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3346 cgrad            enddo
3347 cgrad          enddo
3348 c 9/28/08 AL Gradient compotents will be summed only at the end
3349           ggg(1)=facvdw*xj
3350           ggg(2)=facvdw*yj
3351           ggg(3)=facvdw*zj
3352           do k=1,3
3353             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3354             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3355           enddo
3356 #endif
3357 *
3358 * Angular part
3359 *
3360           ecosa=2.0D0*fac3*fac1+fac4
3361           fac4=-3.0D0*fac4
3362           fac3=-6.0D0*fac3
3363           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3364           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3365           do k=1,3
3366             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3367             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3368           enddo
3369 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3370 cd   &          (dcosg(k),k=1,3)
3371           do k=1,3
3372             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3373           enddo
3374 c          do k=1,3
3375 c            ghalf=0.5D0*ggg(k)
3376 c            gelc(k,i)=gelc(k,i)+ghalf
3377 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3378 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3379 c            gelc(k,j)=gelc(k,j)+ghalf
3380 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3381 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3382 c          enddo
3383 cgrad          do k=i+1,j-1
3384 cgrad            do l=1,3
3385 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3386 cgrad            enddo
3387 cgrad          enddo
3388           do k=1,3
3389             gelc(k,i)=gelc(k,i)
3390      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3391      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3392             gelc(k,j)=gelc(k,j)
3393      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3394      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3395             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3396             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3397           enddo
3398           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3399      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3400      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3401 C
3402 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3403 C   energy of a peptide unit is assumed in the form of a second-order
3404 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3405 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3406 C   are computed for EVERY pair of non-contiguous peptide groups.
3407 C
3408           if (j.lt.nres-1) then
3409             j1=j+1
3410             j2=j-1
3411           else
3412             j1=j-1
3413             j2=j-2
3414           endif
3415           kkk=0
3416           do k=1,2
3417             do l=1,2
3418               kkk=kkk+1
3419               muij(kkk)=mu(k,i)*mu(l,j)
3420             enddo
3421           enddo
3422 cd         write (iout,*) 'EELEC: i',i,' j',j
3423 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3424 cd          write(iout,*) 'muij',muij
3425           ury=scalar(uy(1,i),erij)
3426           urz=scalar(uz(1,i),erij)
3427           vry=scalar(uy(1,j),erij)
3428           vrz=scalar(uz(1,j),erij)
3429           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3430           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3431           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3432           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3433           fac=dsqrt(-ael6i)*r3ij
3434           a22=a22*fac
3435           a23=a23*fac
3436           a32=a32*fac
3437           a33=a33*fac
3438 cd          write (iout,'(4i5,4f10.5)')
3439 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3440 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3441 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3442 cd     &      uy(:,j),uz(:,j)
3443 cd          write (iout,'(4f10.5)')
3444 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3445 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3446 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3447 cd           write (iout,'(9f10.5/)')
3448 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3449 C Derivatives of the elements of A in virtual-bond vectors
3450           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3451           do k=1,3
3452             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3453             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3454             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3455             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3456             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3457             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3458             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3459             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3460             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3461             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3462             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3463             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3464           enddo
3465 C Compute radial contributions to the gradient
3466           facr=-3.0d0*rrmij
3467           a22der=a22*facr
3468           a23der=a23*facr
3469           a32der=a32*facr
3470           a33der=a33*facr
3471           agg(1,1)=a22der*xj
3472           agg(2,1)=a22der*yj
3473           agg(3,1)=a22der*zj
3474           agg(1,2)=a23der*xj
3475           agg(2,2)=a23der*yj
3476           agg(3,2)=a23der*zj
3477           agg(1,3)=a32der*xj
3478           agg(2,3)=a32der*yj
3479           agg(3,3)=a32der*zj
3480           agg(1,4)=a33der*xj
3481           agg(2,4)=a33der*yj
3482           agg(3,4)=a33der*zj
3483 C Add the contributions coming from er
3484           fac3=-3.0d0*fac
3485           do k=1,3
3486             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3487             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3488             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3489             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3490           enddo
3491           do k=1,3
3492 C Derivatives in DC(i)
3493 cgrad            ghalf1=0.5d0*agg(k,1)
3494 cgrad            ghalf2=0.5d0*agg(k,2)
3495 cgrad            ghalf3=0.5d0*agg(k,3)
3496 cgrad            ghalf4=0.5d0*agg(k,4)
3497             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3498      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3499             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3500      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3501             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3502      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3503             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3504      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3505 C Derivatives in DC(i+1)
3506             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3507      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3508             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3509      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3510             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3511      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3512             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3513      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3514 C Derivatives in DC(j)
3515             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3516      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3517             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3518      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3519             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3520      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3521             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3522      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3523 C Derivatives in DC(j+1) or DC(nres-1)
3524             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3525      &      -3.0d0*vryg(k,3)*ury)
3526             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3527      &      -3.0d0*vrzg(k,3)*ury)
3528             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3529      &      -3.0d0*vryg(k,3)*urz)
3530             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3531      &      -3.0d0*vrzg(k,3)*urz)
3532 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3533 cgrad              do l=1,4
3534 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3535 cgrad              enddo
3536 cgrad            endif
3537           enddo
3538           acipa(1,1)=a22
3539           acipa(1,2)=a23
3540           acipa(2,1)=a32
3541           acipa(2,2)=a33
3542           a22=-a22
3543           a23=-a23
3544           do l=1,2
3545             do k=1,3
3546               agg(k,l)=-agg(k,l)
3547               aggi(k,l)=-aggi(k,l)
3548               aggi1(k,l)=-aggi1(k,l)
3549               aggj(k,l)=-aggj(k,l)
3550               aggj1(k,l)=-aggj1(k,l)
3551             enddo
3552           enddo
3553           if (j.lt.nres-1) then
3554             a22=-a22
3555             a32=-a32
3556             do l=1,3,2
3557               do k=1,3
3558                 agg(k,l)=-agg(k,l)
3559                 aggi(k,l)=-aggi(k,l)
3560                 aggi1(k,l)=-aggi1(k,l)
3561                 aggj(k,l)=-aggj(k,l)
3562                 aggj1(k,l)=-aggj1(k,l)
3563               enddo
3564             enddo
3565           else
3566             a22=-a22
3567             a23=-a23
3568             a32=-a32
3569             a33=-a33
3570             do l=1,4
3571               do k=1,3
3572                 agg(k,l)=-agg(k,l)
3573                 aggi(k,l)=-aggi(k,l)
3574                 aggi1(k,l)=-aggi1(k,l)
3575                 aggj(k,l)=-aggj(k,l)
3576                 aggj1(k,l)=-aggj1(k,l)
3577               enddo
3578             enddo
3579           endif
3580           ENDIF ! WCORR
3581           IF (wel_loc.gt.0.0d0) THEN
3582 C Contribution to the local-electrostatic energy coming from the i-j pair
3583           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3584      &     +a33*muij(4)
3585 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3586
3587           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3588      &            'eelloc',i,j,eel_loc_ij
3589
3590           eel_loc=eel_loc+eel_loc_ij
3591 C Partial derivatives in virtual-bond dihedral angles gamma
3592           if (i.gt.1)
3593      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3594      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3595      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3596           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3597      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3598      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3599 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3600           do l=1,3
3601             ggg(l)=agg(l,1)*muij(1)+
3602      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3603             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3604             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3605 cgrad            ghalf=0.5d0*ggg(l)
3606 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3607 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3608           enddo
3609 cgrad          do k=i+1,j2
3610 cgrad            do l=1,3
3611 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3612 cgrad            enddo
3613 cgrad          enddo
3614 C Remaining derivatives of eello
3615           do l=1,3
3616             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3617      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3618             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3619      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3620             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3621      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3622             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3623      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3624           enddo
3625           ENDIF
3626 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3627 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3628           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3629      &       .and. num_conti.le.maxconts) then
3630 c            write (iout,*) i,j," entered corr"
3631 C
3632 C Calculate the contact function. The ith column of the array JCONT will
3633 C contain the numbers of atoms that make contacts with the atom I (of numbers
3634 C greater than I). The arrays FACONT and GACONT will contain the values of
3635 C the contact function and its derivative.
3636 c           r0ij=1.02D0*rpp(iteli,itelj)
3637 c           r0ij=1.11D0*rpp(iteli,itelj)
3638             r0ij=2.20D0*rpp(iteli,itelj)
3639 c           r0ij=1.55D0*rpp(iteli,itelj)
3640             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3641             if (fcont.gt.0.0D0) then
3642               num_conti=num_conti+1
3643               if (num_conti.gt.maxconts) then
3644                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3645      &                         ' will skip next contacts for this conf.'
3646               else
3647                 jcont_hb(num_conti,i)=j
3648 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3649 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3650                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3651      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3652 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3653 C  terms.
3654                 d_cont(num_conti,i)=rij
3655 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3656 C     --- Electrostatic-interaction matrix ---
3657                 a_chuj(1,1,num_conti,i)=a22
3658                 a_chuj(1,2,num_conti,i)=a23
3659                 a_chuj(2,1,num_conti,i)=a32
3660                 a_chuj(2,2,num_conti,i)=a33
3661 C     --- Gradient of rij
3662                 do kkk=1,3
3663                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3664                 enddo
3665                 kkll=0
3666                 do k=1,2
3667                   do l=1,2
3668                     kkll=kkll+1
3669                     do m=1,3
3670                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3671                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3672                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3673                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3674                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3675                     enddo
3676                   enddo
3677                 enddo
3678                 ENDIF
3679                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3680 C Calculate contact energies
3681                 cosa4=4.0D0*cosa
3682                 wij=cosa-3.0D0*cosb*cosg
3683                 cosbg1=cosb+cosg
3684                 cosbg2=cosb-cosg
3685 c               fac3=dsqrt(-ael6i)/r0ij**3
3686                 fac3=dsqrt(-ael6i)*r3ij
3687 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3688                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3689                 if (ees0tmp.gt.0) then
3690                   ees0pij=dsqrt(ees0tmp)
3691                 else
3692                   ees0pij=0
3693                 endif
3694 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3695                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3696                 if (ees0tmp.gt.0) then
3697                   ees0mij=dsqrt(ees0tmp)
3698                 else
3699                   ees0mij=0
3700                 endif
3701 c               ees0mij=0.0D0
3702                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3703                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3704 C Diagnostics. Comment out or remove after debugging!
3705 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3706 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3707 c               ees0m(num_conti,i)=0.0D0
3708 C End diagnostics.
3709 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3710 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3711 C Angular derivatives of the contact function
3712                 ees0pij1=fac3/ees0pij
3713                 ees0mij1=fac3/ees0mij
3714                 fac3p=-3.0D0*fac3*rrmij
3715                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3716                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3717 c               ees0mij1=0.0D0
3718                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3719                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3720                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3721                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3722                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3723                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3724                 ecosap=ecosa1+ecosa2
3725                 ecosbp=ecosb1+ecosb2
3726                 ecosgp=ecosg1+ecosg2
3727                 ecosam=ecosa1-ecosa2
3728                 ecosbm=ecosb1-ecosb2
3729                 ecosgm=ecosg1-ecosg2
3730 C Diagnostics
3731 c               ecosap=ecosa1
3732 c               ecosbp=ecosb1
3733 c               ecosgp=ecosg1
3734 c               ecosam=0.0D0
3735 c               ecosbm=0.0D0
3736 c               ecosgm=0.0D0
3737 C End diagnostics
3738                 facont_hb(num_conti,i)=fcont
3739                 fprimcont=fprimcont/rij
3740 cd              facont_hb(num_conti,i)=1.0D0
3741 C Following line is for diagnostics.
3742 cd              fprimcont=0.0D0
3743                 do k=1,3
3744                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3745                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3746                 enddo
3747                 do k=1,3
3748                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3749                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3750                 enddo
3751                 gggp(1)=gggp(1)+ees0pijp*xj
3752                 gggp(2)=gggp(2)+ees0pijp*yj
3753                 gggp(3)=gggp(3)+ees0pijp*zj
3754                 gggm(1)=gggm(1)+ees0mijp*xj
3755                 gggm(2)=gggm(2)+ees0mijp*yj
3756                 gggm(3)=gggm(3)+ees0mijp*zj
3757 C Derivatives due to the contact function
3758                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3759                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3760                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3761                 do k=1,3
3762 c
3763 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3764 c          following the change of gradient-summation algorithm.
3765 c
3766 cgrad                  ghalfp=0.5D0*gggp(k)
3767 cgrad                  ghalfm=0.5D0*gggm(k)
3768                   gacontp_hb1(k,num_conti,i)=!ghalfp
3769      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3770      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3771                   gacontp_hb2(k,num_conti,i)=!ghalfp
3772      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3773      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3774                   gacontp_hb3(k,num_conti,i)=gggp(k)
3775                   gacontm_hb1(k,num_conti,i)=!ghalfm
3776      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3777      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3778                   gacontm_hb2(k,num_conti,i)=!ghalfm
3779      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3780      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3781                   gacontm_hb3(k,num_conti,i)=gggm(k)
3782                 enddo
3783 C Diagnostics. Comment out or remove after debugging!
3784 cdiag           do k=1,3
3785 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3786 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3787 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3788 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3789 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3790 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3791 cdiag           enddo
3792               ENDIF ! wcorr
3793               endif  ! num_conti.le.maxconts
3794             endif  ! fcont.gt.0
3795           endif    ! j.gt.i+1
3796           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3797             do k=1,4
3798               do l=1,3
3799                 ghalf=0.5d0*agg(l,k)
3800                 aggi(l,k)=aggi(l,k)+ghalf
3801                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3802                 aggj(l,k)=aggj(l,k)+ghalf
3803               enddo
3804             enddo
3805             if (j.eq.nres-1 .and. i.lt.j-2) then
3806               do k=1,4
3807                 do l=1,3
3808                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3809                 enddo
3810               enddo
3811             endif
3812           endif
3813 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3814       return
3815       end
3816 C-----------------------------------------------------------------------------
3817       subroutine eturn3(i,eello_turn3)
3818 C Third- and fourth-order contributions from turns
3819       implicit real*8 (a-h,o-z)
3820       include 'DIMENSIONS'
3821       include 'COMMON.IOUNITS'
3822       include 'COMMON.GEO'
3823       include 'COMMON.VAR'
3824       include 'COMMON.LOCAL'
3825       include 'COMMON.CHAIN'
3826       include 'COMMON.DERIV'
3827       include 'COMMON.INTERACT'
3828       include 'COMMON.CONTACTS'
3829       include 'COMMON.TORSION'
3830       include 'COMMON.VECTORS'
3831       include 'COMMON.FFIELD'
3832       include 'COMMON.CONTROL'
3833       dimension ggg(3)
3834       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3835      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3836      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3837       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3838      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3839       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3840      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3841      &    num_conti,j1,j2
3842       j=i+2
3843 c      write (iout,*) "eturn3",i,j,j1,j2
3844       a_temp(1,1)=a22
3845       a_temp(1,2)=a23
3846       a_temp(2,1)=a32
3847       a_temp(2,2)=a33
3848 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3849 C
3850 C               Third-order contributions
3851 C
3852 C                 (i+2)o----(i+3)
3853 C                      | |
3854 C                      | |
3855 C                 (i+1)o----i
3856 C
3857 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3858 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3859         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3860         call transpose2(auxmat(1,1),auxmat1(1,1))
3861         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3862         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3863         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3864      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3865 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3866 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3867 cd     &    ' eello_turn3_num',4*eello_turn3_num
3868 C Derivatives in gamma(i)
3869         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3870         call transpose2(auxmat2(1,1),auxmat3(1,1))
3871         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3872         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3873 C Derivatives in gamma(i+1)
3874         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3875         call transpose2(auxmat2(1,1),auxmat3(1,1))
3876         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3877         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3878      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3879 C Cartesian derivatives
3880         do l=1,3
3881 c            ghalf1=0.5d0*agg(l,1)
3882 c            ghalf2=0.5d0*agg(l,2)
3883 c            ghalf3=0.5d0*agg(l,3)
3884 c            ghalf4=0.5d0*agg(l,4)
3885           a_temp(1,1)=aggi(l,1)!+ghalf1
3886           a_temp(1,2)=aggi(l,2)!+ghalf2
3887           a_temp(2,1)=aggi(l,3)!+ghalf3
3888           a_temp(2,2)=aggi(l,4)!+ghalf4
3889           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3890           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3891      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3892           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3893           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3894           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3895           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3896           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3897           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3898      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3899           a_temp(1,1)=aggj(l,1)!+ghalf1
3900           a_temp(1,2)=aggj(l,2)!+ghalf2
3901           a_temp(2,1)=aggj(l,3)!+ghalf3
3902           a_temp(2,2)=aggj(l,4)!+ghalf4
3903           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3904           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3905      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3906           a_temp(1,1)=aggj1(l,1)
3907           a_temp(1,2)=aggj1(l,2)
3908           a_temp(2,1)=aggj1(l,3)
3909           a_temp(2,2)=aggj1(l,4)
3910           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3911           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3912      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3913         enddo
3914       return
3915       end
3916 C-------------------------------------------------------------------------------
3917       subroutine eturn4(i,eello_turn4)
3918 C Third- and fourth-order contributions from turns
3919       implicit real*8 (a-h,o-z)
3920       include 'DIMENSIONS'
3921       include 'COMMON.IOUNITS'
3922       include 'COMMON.GEO'
3923       include 'COMMON.VAR'
3924       include 'COMMON.LOCAL'
3925       include 'COMMON.CHAIN'
3926       include 'COMMON.DERIV'
3927       include 'COMMON.INTERACT'
3928       include 'COMMON.CONTACTS'
3929       include 'COMMON.TORSION'
3930       include 'COMMON.VECTORS'
3931       include 'COMMON.FFIELD'
3932       include 'COMMON.CONTROL'
3933       dimension ggg(3)
3934       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3935      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3936      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3937       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3938      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3939       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3940      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3941      &    num_conti,j1,j2
3942       j=i+3
3943 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3944 C
3945 C               Fourth-order contributions
3946 C
3947 C                 (i+3)o----(i+4)
3948 C                     /  |
3949 C               (i+2)o   |
3950 C                     \  |
3951 C                 (i+1)o----i
3952 C
3953 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3954 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3955 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3956         a_temp(1,1)=a22
3957         a_temp(1,2)=a23
3958         a_temp(2,1)=a32
3959         a_temp(2,2)=a33
3960         iti1=itortyp(itype(i+1))
3961         iti2=itortyp(itype(i+2))
3962         iti3=itortyp(itype(i+3))
3963 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3964         call transpose2(EUg(1,1,i+1),e1t(1,1))
3965         call transpose2(Eug(1,1,i+2),e2t(1,1))
3966         call transpose2(Eug(1,1,i+3),e3t(1,1))
3967         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3968         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3969         s1=scalar2(b1(1,iti2),auxvec(1))
3970         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3971         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3972         s2=scalar2(b1(1,iti1),auxvec(1))
3973         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3974         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3975         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3976         eello_turn4=eello_turn4-(s1+s2+s3)
3977         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3978      &      'eturn4',i,j,-(s1+s2+s3)
3979 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3980 cd     &    ' eello_turn4_num',8*eello_turn4_num
3981 C Derivatives in gamma(i)
3982         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3983         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3984         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3985         s1=scalar2(b1(1,iti2),auxvec(1))
3986         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3987         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3988         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3989 C Derivatives in gamma(i+1)
3990         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3991         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3992         s2=scalar2(b1(1,iti1),auxvec(1))
3993         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3994         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3995         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3996         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3997 C Derivatives in gamma(i+2)
3998         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3999         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4000         s1=scalar2(b1(1,iti2),auxvec(1))
4001         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4002         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4003         s2=scalar2(b1(1,iti1),auxvec(1))
4004         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
4005         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
4006         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4007         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
4008 C Cartesian derivatives
4009 C Derivatives of this turn contributions in DC(i+2)
4010         if (j.lt.nres-1) then
4011           do l=1,3
4012             a_temp(1,1)=agg(l,1)
4013             a_temp(1,2)=agg(l,2)
4014             a_temp(2,1)=agg(l,3)
4015             a_temp(2,2)=agg(l,4)
4016             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4017             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4018             s1=scalar2(b1(1,iti2),auxvec(1))
4019             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4020             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4021             s2=scalar2(b1(1,iti1),auxvec(1))
4022             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4023             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4024             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4025             ggg(l)=-(s1+s2+s3)
4026             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
4027           enddo
4028         endif
4029 C Remaining derivatives of this turn contribution
4030         do l=1,3
4031           a_temp(1,1)=aggi(l,1)
4032           a_temp(1,2)=aggi(l,2)
4033           a_temp(2,1)=aggi(l,3)
4034           a_temp(2,2)=aggi(l,4)
4035           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4036           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4037           s1=scalar2(b1(1,iti2),auxvec(1))
4038           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4039           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4040           s2=scalar2(b1(1,iti1),auxvec(1))
4041           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4042           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4043           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4044           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
4045           a_temp(1,1)=aggi1(l,1)
4046           a_temp(1,2)=aggi1(l,2)
4047           a_temp(2,1)=aggi1(l,3)
4048           a_temp(2,2)=aggi1(l,4)
4049           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4050           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4051           s1=scalar2(b1(1,iti2),auxvec(1))
4052           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4053           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4054           s2=scalar2(b1(1,iti1),auxvec(1))
4055           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4056           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4057           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4058           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
4059           a_temp(1,1)=aggj(l,1)
4060           a_temp(1,2)=aggj(l,2)
4061           a_temp(2,1)=aggj(l,3)
4062           a_temp(2,2)=aggj(l,4)
4063           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4064           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4065           s1=scalar2(b1(1,iti2),auxvec(1))
4066           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4067           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4068           s2=scalar2(b1(1,iti1),auxvec(1))
4069           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4070           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4071           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4072           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
4073           a_temp(1,1)=aggj1(l,1)
4074           a_temp(1,2)=aggj1(l,2)
4075           a_temp(2,1)=aggj1(l,3)
4076           a_temp(2,2)=aggj1(l,4)
4077           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4078           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4079           s1=scalar2(b1(1,iti2),auxvec(1))
4080           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4081           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4082           s2=scalar2(b1(1,iti1),auxvec(1))
4083           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4084           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4085           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4086 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4087           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4088         enddo
4089       return
4090       end
4091 C-----------------------------------------------------------------------------
4092       subroutine vecpr(u,v,w)
4093       implicit real*8(a-h,o-z)
4094       dimension u(3),v(3),w(3)
4095       w(1)=u(2)*v(3)-u(3)*v(2)
4096       w(2)=-u(1)*v(3)+u(3)*v(1)
4097       w(3)=u(1)*v(2)-u(2)*v(1)
4098       return
4099       end
4100 C-----------------------------------------------------------------------------
4101       subroutine unormderiv(u,ugrad,unorm,ungrad)
4102 C This subroutine computes the derivatives of a normalized vector u, given
4103 C the derivatives computed without normalization conditions, ugrad. Returns
4104 C ungrad.
4105       implicit none
4106       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4107       double precision vec(3)
4108       double precision scalar
4109       integer i,j
4110 c      write (2,*) 'ugrad',ugrad
4111 c      write (2,*) 'u',u
4112       do i=1,3
4113         vec(i)=scalar(ugrad(1,i),u(1))
4114       enddo
4115 c      write (2,*) 'vec',vec
4116       do i=1,3
4117         do j=1,3
4118           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4119         enddo
4120       enddo
4121 c      write (2,*) 'ungrad',ungrad
4122       return
4123       end
4124 C-----------------------------------------------------------------------------
4125       subroutine escp_soft_sphere(evdw2,evdw2_14)
4126 C
4127 C This subroutine calculates the excluded-volume interaction energy between
4128 C peptide-group centers and side chains and its gradient in virtual-bond and
4129 C side-chain vectors.
4130 C
4131       implicit real*8 (a-h,o-z)
4132       include 'DIMENSIONS'
4133       include 'COMMON.GEO'
4134       include 'COMMON.VAR'
4135       include 'COMMON.LOCAL'
4136       include 'COMMON.CHAIN'
4137       include 'COMMON.DERIV'
4138       include 'COMMON.INTERACT'
4139       include 'COMMON.FFIELD'
4140       include 'COMMON.IOUNITS'
4141       include 'COMMON.CONTROL'
4142       dimension ggg(3)
4143       evdw2=0.0D0
4144       evdw2_14=0.0d0
4145       r0_scp=4.5d0
4146 cd    print '(a)','Enter ESCP'
4147 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4148       do i=iatscp_s,iatscp_e
4149         iteli=itel(i)
4150         xi=0.5D0*(c(1,i)+c(1,i+1))
4151         yi=0.5D0*(c(2,i)+c(2,i+1))
4152         zi=0.5D0*(c(3,i)+c(3,i+1))
4153
4154         do iint=1,nscp_gr(i)
4155
4156         do j=iscpstart(i,iint),iscpend(i,iint)
4157           itypj=itype(j)
4158 C Uncomment following three lines for SC-p interactions
4159 c         xj=c(1,nres+j)-xi
4160 c         yj=c(2,nres+j)-yi
4161 c         zj=c(3,nres+j)-zi
4162 C Uncomment following three lines for Ca-p interactions
4163           xj=c(1,j)-xi
4164           yj=c(2,j)-yi
4165           zj=c(3,j)-zi
4166           rij=xj*xj+yj*yj+zj*zj
4167           r0ij=r0_scp
4168           r0ijsq=r0ij*r0ij
4169           if (rij.lt.r0ijsq) then
4170             evdwij=0.25d0*(rij-r0ijsq)**2
4171             fac=rij-r0ijsq
4172           else
4173             evdwij=0.0d0
4174             fac=0.0d0
4175           endif
4176           evdw2=evdw2+evdwij
4177 C
4178 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4179 C
4180           ggg(1)=xj*fac
4181           ggg(2)=yj*fac
4182           ggg(3)=zj*fac
4183 cgrad          if (j.lt.i) then
4184 cd          write (iout,*) 'j<i'
4185 C Uncomment following three lines for SC-p interactions
4186 c           do k=1,3
4187 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4188 c           enddo
4189 cgrad          else
4190 cd          write (iout,*) 'j>i'
4191 cgrad            do k=1,3
4192 cgrad              ggg(k)=-ggg(k)
4193 C Uncomment following line for SC-p interactions
4194 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4195 cgrad            enddo
4196 cgrad          endif
4197 cgrad          do k=1,3
4198 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4199 cgrad          enddo
4200 cgrad          kstart=min0(i+1,j)
4201 cgrad          kend=max0(i-1,j-1)
4202 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4203 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4204 cgrad          do k=kstart,kend
4205 cgrad            do l=1,3
4206 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4207 cgrad            enddo
4208 cgrad          enddo
4209           do k=1,3
4210             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4211             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4212           enddo
4213         enddo
4214
4215         enddo ! iint
4216       enddo ! i
4217       return
4218       end
4219 C-----------------------------------------------------------------------------
4220       subroutine escp(evdw2,evdw2_14)
4221 C
4222 C This subroutine calculates the excluded-volume interaction energy between
4223 C peptide-group centers and side chains and its gradient in virtual-bond and
4224 C side-chain vectors.
4225 C
4226       implicit real*8 (a-h,o-z)
4227       include 'DIMENSIONS'
4228       include 'COMMON.GEO'
4229       include 'COMMON.VAR'
4230       include 'COMMON.LOCAL'
4231       include 'COMMON.CHAIN'
4232       include 'COMMON.DERIV'
4233       include 'COMMON.INTERACT'
4234       include 'COMMON.FFIELD'
4235       include 'COMMON.IOUNITS'
4236       include 'COMMON.CONTROL'
4237       dimension ggg(3)
4238       evdw2=0.0D0
4239       evdw2_14=0.0d0
4240 cd    print '(a)','Enter ESCP'
4241 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4242       do i=iatscp_s,iatscp_e
4243         iteli=itel(i)
4244         xi=0.5D0*(c(1,i)+c(1,i+1))
4245         yi=0.5D0*(c(2,i)+c(2,i+1))
4246         zi=0.5D0*(c(3,i)+c(3,i+1))
4247
4248         do iint=1,nscp_gr(i)
4249
4250         do j=iscpstart(i,iint),iscpend(i,iint)
4251           itypj=itype(j)
4252 C Uncomment following three lines for SC-p interactions
4253 c         xj=c(1,nres+j)-xi
4254 c         yj=c(2,nres+j)-yi
4255 c         zj=c(3,nres+j)-zi
4256 C Uncomment following three lines for Ca-p interactions
4257           xj=c(1,j)-xi
4258           yj=c(2,j)-yi
4259           zj=c(3,j)-zi
4260           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4261           fac=rrij**expon2
4262           e1=fac*fac*aad(itypj,iteli)
4263           e2=fac*bad(itypj,iteli)
4264           if (iabs(j-i) .le. 2) then
4265             e1=scal14*e1
4266             e2=scal14*e2
4267             evdw2_14=evdw2_14+e1+e2
4268           endif
4269           evdwij=e1+e2
4270           evdw2=evdw2+evdwij
4271           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4272      &        'evdw2',i,j,evdwij
4273 C
4274 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4275 C
4276           fac=-(evdwij+e1)*rrij
4277           ggg(1)=xj*fac
4278           ggg(2)=yj*fac
4279           ggg(3)=zj*fac
4280 cgrad          if (j.lt.i) then
4281 cd          write (iout,*) 'j<i'
4282 C Uncomment following three lines for SC-p interactions
4283 c           do k=1,3
4284 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4285 c           enddo
4286 cgrad          else
4287 cd          write (iout,*) 'j>i'
4288 cgrad            do k=1,3
4289 cgrad              ggg(k)=-ggg(k)
4290 C Uncomment following line for SC-p interactions
4291 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4292 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4293 cgrad            enddo
4294 cgrad          endif
4295 cgrad          do k=1,3
4296 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4297 cgrad          enddo
4298 cgrad          kstart=min0(i+1,j)
4299 cgrad          kend=max0(i-1,j-1)
4300 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4301 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4302 cgrad          do k=kstart,kend
4303 cgrad            do l=1,3
4304 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4305 cgrad            enddo
4306 cgrad          enddo
4307           do k=1,3
4308             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4309             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4310           enddo
4311         enddo
4312
4313         enddo ! iint
4314       enddo ! i
4315       do i=1,nct
4316         do j=1,3
4317           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4318           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4319           gradx_scp(j,i)=expon*gradx_scp(j,i)
4320         enddo
4321       enddo
4322 C******************************************************************************
4323 C
4324 C                              N O T E !!!
4325 C
4326 C To save time the factor EXPON has been extracted from ALL components
4327 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4328 C use!
4329 C
4330 C******************************************************************************
4331       return
4332       end
4333 C--------------------------------------------------------------------------
4334       subroutine edis(ehpb)
4335 C
4336 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4337 C
4338       implicit real*8 (a-h,o-z)
4339       include 'DIMENSIONS'
4340       include 'COMMON.SBRIDGE'
4341       include 'COMMON.CHAIN'
4342       include 'COMMON.DERIV'
4343       include 'COMMON.VAR'
4344       include 'COMMON.INTERACT'
4345       include 'COMMON.IOUNITS'
4346       dimension ggg(3)
4347       ehpb=0.0D0
4348 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4349 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4350       if (link_end.eq.0) return
4351       do i=link_start,link_end
4352 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4353 C CA-CA distance used in regularization of structure.
4354         ii=ihpb(i)
4355         jj=jhpb(i)
4356 C iii and jjj point to the residues for which the distance is assigned.
4357         if (ii.gt.nres) then
4358           iii=ii-nres
4359           jjj=jj-nres
4360         else
4361           iii=ii
4362           jjj=jj
4363         endif
4364 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4365 c     &    dhpb(i),dhpb1(i),forcon(i)
4366 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4367 C    distance and angle dependent SS bond potential.
4368 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4369 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4370         if (.not.dyn_ss .and. i.le.nss) then
4371 C 15/02/13 CC dynamic SSbond - additional check
4372          if (ii.gt.nres
4373      &       .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4374           call ssbond_ene(iii,jjj,eij)
4375           ehpb=ehpb+2*eij
4376          endif
4377 cd          write (iout,*) "eij",eij
4378         else if (ii.gt.nres .and. jj.gt.nres) then
4379 c Restraints from contact prediction
4380           dd=dist(ii,jj)
4381           if (dhpb1(i).gt.0.0d0) then
4382             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4383             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4384 c            write (iout,*) "beta nmr",
4385 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4386           else
4387             dd=dist(ii,jj)
4388             rdis=dd-dhpb(i)
4389 C Get the force constant corresponding to this distance.
4390             waga=forcon(i)
4391 C Calculate the contribution to energy.
4392             ehpb=ehpb+waga*rdis*rdis
4393 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
4394 C
4395 C Evaluate gradient.
4396 C
4397             fac=waga*rdis/dd
4398           endif
4399           do j=1,3
4400             ggg(j)=fac*(c(j,jj)-c(j,ii))
4401           enddo
4402           do j=1,3
4403             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4404             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4405           enddo
4406           do k=1,3
4407             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4408             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4409           enddo
4410         else
4411 C Calculate the distance between the two points and its difference from the
4412 C target distance.
4413           dd=dist(ii,jj)
4414           if (dhpb1(i).gt.0.0d0) then
4415             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4416             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4417 c            write (iout,*) "alph nmr",
4418 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4419           else
4420             rdis=dd-dhpb(i)
4421 C Get the force constant corresponding to this distance.
4422             waga=forcon(i)
4423 C Calculate the contribution to energy.
4424             ehpb=ehpb+waga*rdis*rdis
4425 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
4426 C
4427 C Evaluate gradient.
4428 C
4429             fac=waga*rdis/dd
4430           endif
4431 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4432 cd   &   ' waga=',waga,' fac=',fac
4433             do j=1,3
4434               ggg(j)=fac*(c(j,jj)-c(j,ii))
4435             enddo
4436 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4437 C If this is a SC-SC distance, we need to calculate the contributions to the
4438 C Cartesian gradient in the SC vectors (ghpbx).
4439           if (iii.lt.ii) then
4440           do j=1,3
4441             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4442             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4443           enddo
4444           endif
4445 cgrad        do j=iii,jjj-1
4446 cgrad          do k=1,3
4447 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4448 cgrad          enddo
4449 cgrad        enddo
4450           do k=1,3
4451             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4452             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4453           enddo
4454         endif
4455       enddo
4456       ehpb=0.5D0*ehpb
4457       return
4458       end
4459 C--------------------------------------------------------------------------
4460       subroutine ssbond_ene(i,j,eij)
4461 C
4462 C Calculate the distance and angle dependent SS-bond potential energy
4463 C using a free-energy function derived based on RHF/6-31G** ab initio
4464 C calculations of diethyl disulfide.
4465 C
4466 C A. Liwo and U. Kozlowska, 11/24/03
4467 C
4468       implicit real*8 (a-h,o-z)
4469       include 'DIMENSIONS'
4470       include 'COMMON.SBRIDGE'
4471       include 'COMMON.CHAIN'
4472       include 'COMMON.DERIV'
4473       include 'COMMON.LOCAL'
4474       include 'COMMON.INTERACT'
4475       include 'COMMON.VAR'
4476       include 'COMMON.IOUNITS'
4477       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4478       itypi=itype(i)
4479       xi=c(1,nres+i)
4480       yi=c(2,nres+i)
4481       zi=c(3,nres+i)
4482       dxi=dc_norm(1,nres+i)
4483       dyi=dc_norm(2,nres+i)
4484       dzi=dc_norm(3,nres+i)
4485 c      dsci_inv=dsc_inv(itypi)
4486       dsci_inv=vbld_inv(nres+i)
4487       itypj=itype(j)
4488 c      dscj_inv=dsc_inv(itypj)
4489       dscj_inv=vbld_inv(nres+j)
4490       xj=c(1,nres+j)-xi
4491       yj=c(2,nres+j)-yi
4492       zj=c(3,nres+j)-zi
4493       dxj=dc_norm(1,nres+j)
4494       dyj=dc_norm(2,nres+j)
4495       dzj=dc_norm(3,nres+j)
4496       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4497       rij=dsqrt(rrij)
4498       erij(1)=xj*rij
4499       erij(2)=yj*rij
4500       erij(3)=zj*rij
4501       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4502       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4503       om12=dxi*dxj+dyi*dyj+dzi*dzj
4504       do k=1,3
4505         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4506         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4507       enddo
4508       rij=1.0d0/rij
4509       deltad=rij-d0cm
4510       deltat1=1.0d0-om1
4511       deltat2=1.0d0+om2
4512       deltat12=om2-om1+2.0d0
4513       cosphi=om12-om1*om2
4514       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4515      &  +akct*deltad*deltat12+ebr
4516      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4517 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4518 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4519 c     &  " deltat12",deltat12," eij",eij
4520       ed=2*akcm*deltad+akct*deltat12
4521       pom1=akct*deltad
4522       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4523       eom1=-2*akth*deltat1-pom1-om2*pom2
4524       eom2= 2*akth*deltat2+pom1-om1*pom2
4525       eom12=pom2
4526       do k=1,3
4527         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4528         ghpbx(k,i)=ghpbx(k,i)-ggk
4529      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4530      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4531         ghpbx(k,j)=ghpbx(k,j)+ggk
4532      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4533      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4534         ghpbc(k,i)=ghpbc(k,i)-ggk
4535         ghpbc(k,j)=ghpbc(k,j)+ggk
4536       enddo
4537 C
4538 C Calculate the components of the gradient in DC and X
4539 C
4540 cgrad      do k=i,j-1
4541 cgrad        do l=1,3
4542 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4543 cgrad        enddo
4544 cgrad      enddo
4545       return
4546       end
4547 C--------------------------------------------------------------------------
4548       subroutine ebond(estr)
4549 c
4550 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4551 c
4552       implicit real*8 (a-h,o-z)
4553       include 'DIMENSIONS'
4554       include 'COMMON.LOCAL'
4555       include 'COMMON.GEO'
4556       include 'COMMON.INTERACT'
4557       include 'COMMON.DERIV'
4558       include 'COMMON.VAR'
4559       include 'COMMON.CHAIN'
4560       include 'COMMON.IOUNITS'
4561       include 'COMMON.NAMES'
4562       include 'COMMON.FFIELD'
4563       include 'COMMON.CONTROL'
4564       include 'COMMON.SETUP'
4565       double precision u(3),ud(3)
4566       estr=0.0d0
4567       do i=ibondp_start,ibondp_end
4568         diff = vbld(i)-vbldp0
4569 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4570         estr=estr+diff*diff
4571         do j=1,3
4572           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4573         enddo
4574 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4575       enddo
4576       estr=0.5d0*AKP*estr
4577 c
4578 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4579 c
4580       do i=ibond_start,ibond_end
4581         iti=itype(i)
4582         if (iti.ne.10) then
4583           nbi=nbondterm(iti)
4584           if (nbi.eq.1) then
4585             diff=vbld(i+nres)-vbldsc0(1,iti)
4586 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4587 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4588             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4589             do j=1,3
4590               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4591             enddo
4592           else
4593             do j=1,nbi
4594               diff=vbld(i+nres)-vbldsc0(j,iti)
4595               ud(j)=aksc(j,iti)*diff
4596               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4597             enddo
4598             uprod=u(1)
4599             do j=2,nbi
4600               uprod=uprod*u(j)
4601             enddo
4602             usum=0.0d0
4603             usumsqder=0.0d0
4604             do j=1,nbi
4605               uprod1=1.0d0
4606               uprod2=1.0d0
4607               do k=1,nbi
4608                 if (k.ne.j) then
4609                   uprod1=uprod1*u(k)
4610                   uprod2=uprod2*u(k)*u(k)
4611                 endif
4612               enddo
4613               usum=usum+uprod1
4614               usumsqder=usumsqder+ud(j)*uprod2
4615             enddo
4616             estr=estr+uprod/usum
4617             do j=1,3
4618              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4619             enddo
4620           endif
4621         endif
4622       enddo
4623       return
4624       end
4625 #ifdef CRYST_THETA
4626 C--------------------------------------------------------------------------
4627       subroutine ebend(etheta)
4628 C
4629 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4630 C angles gamma and its derivatives in consecutive thetas and gammas.
4631 C
4632       implicit real*8 (a-h,o-z)
4633       include 'DIMENSIONS'
4634       include 'COMMON.LOCAL'
4635       include 'COMMON.GEO'
4636       include 'COMMON.INTERACT'
4637       include 'COMMON.DERIV'
4638       include 'COMMON.VAR'
4639       include 'COMMON.CHAIN'
4640       include 'COMMON.IOUNITS'
4641       include 'COMMON.NAMES'
4642       include 'COMMON.FFIELD'
4643       include 'COMMON.CONTROL'
4644       common /calcthet/ term1,term2,termm,diffak,ratak,
4645      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4646      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4647       double precision y(2),z(2)
4648       delta=0.02d0*pi
4649 c      time11=dexp(-2*time)
4650 c      time12=1.0d0
4651       etheta=0.0D0
4652 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4653       do i=ithet_start,ithet_end
4654 C Zero the energy function and its derivative at 0 or pi.
4655         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4656         it=itype(i-1)
4657         if (i.gt.3) then
4658 #ifdef OSF
4659           phii=phi(i)
4660           if (phii.ne.phii) phii=150.0
4661 #else
4662           phii=phi(i)
4663 #endif
4664           y(1)=dcos(phii)
4665           y(2)=dsin(phii)
4666         else
4667           y(1)=0.0D0
4668           y(2)=0.0D0
4669         endif
4670         if (i.lt.nres) then
4671 #ifdef OSF
4672           phii1=phi(i+1)
4673           if (phii1.ne.phii1) phii1=150.0
4674           phii1=pinorm(phii1)
4675           z(1)=cos(phii1)
4676 #else
4677           phii1=phi(i+1)
4678           z(1)=dcos(phii1)
4679 #endif
4680           z(2)=dsin(phii1)
4681         else
4682           z(1)=0.0D0
4683           z(2)=0.0D0
4684         endif
4685 C Calculate the "mean" value of theta from the part of the distribution
4686 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4687 C In following comments this theta will be referred to as t_c.
4688         thet_pred_mean=0.0d0
4689         do k=1,2
4690           athetk=athet(k,it)
4691           bthetk=bthet(k,it)
4692           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4693         enddo
4694         dthett=thet_pred_mean*ssd
4695         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4696 C Derivatives of the "mean" values in gamma1 and gamma2.
4697         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
4698         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
4699         if (theta(i).gt.pi-delta) then
4700           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4701      &         E_tc0)
4702           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4703           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4704           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4705      &        E_theta)
4706           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4707      &        E_tc)
4708         else if (theta(i).lt.delta) then
4709           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4710           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4711           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4712      &        E_theta)
4713           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4714           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4715      &        E_tc)
4716         else
4717           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4718      &        E_theta,E_tc)
4719         endif
4720         etheta=etheta+ethetai
4721         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4722      &      'ebend',i,ethetai
4723         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4724         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4725         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
4726       enddo
4727 C Ufff.... We've done all this!!!
4728       return
4729       end
4730 C---------------------------------------------------------------------------
4731       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4732      &     E_tc)
4733       implicit real*8 (a-h,o-z)
4734       include 'DIMENSIONS'
4735       include 'COMMON.LOCAL'
4736       include 'COMMON.IOUNITS'
4737       common /calcthet/ term1,term2,termm,diffak,ratak,
4738      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4739      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4740 C Calculate the contributions to both Gaussian lobes.
4741 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4742 C The "polynomial part" of the "standard deviation" of this part of
4743 C the distribution.
4744         sig=polthet(3,it)
4745         do j=2,0,-1
4746           sig=sig*thet_pred_mean+polthet(j,it)
4747         enddo
4748 C Derivative of the "interior part" of the "standard deviation of the"
4749 C gamma-dependent Gaussian lobe in t_c.
4750         sigtc=3*polthet(3,it)
4751         do j=2,1,-1
4752           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4753         enddo
4754         sigtc=sig*sigtc
4755 C Set the parameters of both Gaussian lobes of the distribution.
4756 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4757         fac=sig*sig+sigc0(it)
4758         sigcsq=fac+fac
4759         sigc=1.0D0/sigcsq
4760 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4761         sigsqtc=-4.0D0*sigcsq*sigtc
4762 c       print *,i,sig,sigtc,sigsqtc
4763 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4764         sigtc=-sigtc/(fac*fac)
4765 C Following variable is sigma(t_c)**(-2)
4766         sigcsq=sigcsq*sigcsq
4767         sig0i=sig0(it)
4768         sig0inv=1.0D0/sig0i**2
4769         delthec=thetai-thet_pred_mean
4770         delthe0=thetai-theta0i
4771         term1=-0.5D0*sigcsq*delthec*delthec
4772         term2=-0.5D0*sig0inv*delthe0*delthe0
4773 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4774 C NaNs in taking the logarithm. We extract the largest exponent which is added
4775 C to the energy (this being the log of the distribution) at the end of energy
4776 C term evaluation for this virtual-bond angle.
4777         if (term1.gt.term2) then
4778           termm=term1
4779           term2=dexp(term2-termm)
4780           term1=1.0d0
4781         else
4782           termm=term2
4783           term1=dexp(term1-termm)
4784           term2=1.0d0
4785         endif
4786 C The ratio between the gamma-independent and gamma-dependent lobes of
4787 C the distribution is a Gaussian function of thet_pred_mean too.
4788         diffak=gthet(2,it)-thet_pred_mean
4789         ratak=diffak/gthet(3,it)**2
4790         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4791 C Let's differentiate it in thet_pred_mean NOW.
4792         aktc=ak*ratak
4793 C Now put together the distribution terms to make complete distribution.
4794         termexp=term1+ak*term2
4795         termpre=sigc+ak*sig0i
4796 C Contribution of the bending energy from this theta is just the -log of
4797 C the sum of the contributions from the two lobes and the pre-exponential
4798 C factor. Simple enough, isn't it?
4799         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4800 C NOW the derivatives!!!
4801 C 6/6/97 Take into account the deformation.
4802         E_theta=(delthec*sigcsq*term1
4803      &       +ak*delthe0*sig0inv*term2)/termexp
4804         E_tc=((sigtc+aktc*sig0i)/termpre
4805      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4806      &       aktc*term2)/termexp)
4807       return
4808       end
4809 c-----------------------------------------------------------------------------
4810       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4811       implicit real*8 (a-h,o-z)
4812       include 'DIMENSIONS'
4813       include 'COMMON.LOCAL'
4814       include 'COMMON.IOUNITS'
4815       common /calcthet/ term1,term2,termm,diffak,ratak,
4816      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4817      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4818       delthec=thetai-thet_pred_mean
4819       delthe0=thetai-theta0i
4820 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4821       t3 = thetai-thet_pred_mean
4822       t6 = t3**2
4823       t9 = term1
4824       t12 = t3*sigcsq
4825       t14 = t12+t6*sigsqtc
4826       t16 = 1.0d0
4827       t21 = thetai-theta0i
4828       t23 = t21**2
4829       t26 = term2
4830       t27 = t21*t26
4831       t32 = termexp
4832       t40 = t32**2
4833       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4834      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4835      & *(-t12*t9-ak*sig0inv*t27)
4836       return
4837       end
4838 #else
4839 C--------------------------------------------------------------------------
4840       subroutine ebend(etheta)
4841 C
4842 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4843 C angles gamma and its derivatives in consecutive thetas and gammas.
4844 C ab initio-derived potentials from
4845 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4846 C
4847       implicit real*8 (a-h,o-z)
4848       include 'DIMENSIONS'
4849       include 'COMMON.LOCAL'
4850       include 'COMMON.GEO'
4851       include 'COMMON.INTERACT'
4852       include 'COMMON.DERIV'
4853       include 'COMMON.VAR'
4854       include 'COMMON.CHAIN'
4855       include 'COMMON.IOUNITS'
4856       include 'COMMON.NAMES'
4857       include 'COMMON.FFIELD'
4858       include 'COMMON.CONTROL'
4859       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4860      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4861      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4862      & sinph1ph2(maxdouble,maxdouble)
4863       logical lprn /.false./, lprn1 /.false./
4864       etheta=0.0D0
4865 c      write (iout,*) "EBEND ithet_start",ithet_start,
4866 c     &     " ithet_end",ithet_end
4867       do i=ithet_start,ithet_end
4868         if ((itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
4869      &(itype(i).eq.ntyp1)) cycle
4870         dethetai=0.0d0
4871         dephii=0.0d0
4872         dephii1=0.0d0
4873         theti2=0.5d0*theta(i)
4874         ityp2=ithetyp(itype(i-1))
4875         do k=1,nntheterm
4876           coskt(k)=dcos(k*theti2)
4877           sinkt(k)=dsin(k*theti2)
4878         enddo
4879 C        if (i.gt.3) then
4880          if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4881 #ifdef OSF
4882           phii=phi(i)
4883           if (phii.ne.phii) phii=150.0
4884 #else
4885           phii=phi(i)
4886 #endif
4887           ityp1=ithetyp(itype(i-2))
4888           do k=1,nsingle
4889             cosph1(k)=dcos(k*phii)
4890             sinph1(k)=dsin(k*phii)
4891           enddo
4892         else
4893           phii=0.0d0
4894           ityp1=ithetyp(itype(i-2))
4895           do k=1,nsingle
4896             cosph1(k)=0.0d0
4897             sinph1(k)=0.0d0
4898           enddo
4899         endif
4900         if ((i.lt.nres).and. itype(i+1).ne.ntyp1) then
4901 #ifdef OSF
4902           phii1=phi(i+1)
4903           if (phii1.ne.phii1) phii1=150.0
4904           phii1=pinorm(phii1)
4905 #else
4906           phii1=phi(i+1)
4907 #endif
4908           ityp3=ithetyp(itype(i))
4909           do k=1,nsingle
4910             cosph2(k)=dcos(k*phii1)
4911             sinph2(k)=dsin(k*phii1)
4912           enddo
4913         else
4914           phii1=0.0d0
4915           ityp3=ithetyp(itype(i))
4916           do k=1,nsingle
4917             cosph2(k)=0.0d0
4918             sinph2(k)=0.0d0
4919           enddo
4920         endif
4921         ethetai=aa0thet(ityp1,ityp2,ityp3)
4922         do k=1,ndouble
4923           do l=1,k-1
4924             ccl=cosph1(l)*cosph2(k-l)
4925             ssl=sinph1(l)*sinph2(k-l)
4926             scl=sinph1(l)*cosph2(k-l)
4927             csl=cosph1(l)*sinph2(k-l)
4928             cosph1ph2(l,k)=ccl-ssl
4929             cosph1ph2(k,l)=ccl+ssl
4930             sinph1ph2(l,k)=scl+csl
4931             sinph1ph2(k,l)=scl-csl
4932           enddo
4933         enddo
4934         if (lprn) then
4935         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4936      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4937         write (iout,*) "coskt and sinkt"
4938         do k=1,nntheterm
4939           write (iout,*) k,coskt(k),sinkt(k)
4940         enddo
4941         endif
4942         do k=1,ntheterm
4943           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4944           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4945      &      *coskt(k)
4946           if (lprn)
4947      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4948      &     " ethetai",ethetai
4949         enddo
4950         if (lprn) then
4951         write (iout,*) "cosph and sinph"
4952         do k=1,nsingle
4953           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4954         enddo
4955         write (iout,*) "cosph1ph2 and sinph2ph2"
4956         do k=2,ndouble
4957           do l=1,k-1
4958             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4959      &         sinph1ph2(l,k),sinph1ph2(k,l)
4960           enddo
4961         enddo
4962         write(iout,*) "ethetai",ethetai
4963         endif
4964         do m=1,ntheterm2
4965           do k=1,nsingle
4966             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4967      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4968      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4969      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4970             ethetai=ethetai+sinkt(m)*aux
4971             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4972             dephii=dephii+k*sinkt(m)*(
4973      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4974      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4975             dephii1=dephii1+k*sinkt(m)*(
4976      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4977      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4978             if (lprn)
4979      &      write (iout,*) "m",m," k",k," bbthet",
4980      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4981      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4982      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4983      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4984           enddo
4985         enddo
4986         if (lprn)
4987      &  write(iout,*) "ethetai",ethetai
4988         do m=1,ntheterm3
4989           do k=2,ndouble
4990             do l=1,k-1
4991               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4992      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4993      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4994      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4995               ethetai=ethetai+sinkt(m)*aux
4996               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4997               dephii=dephii+l*sinkt(m)*(
4998      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4999      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
5000      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
5001      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
5002               dephii1=dephii1+(k-l)*sinkt(m)*(
5003      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
5004      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
5005      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
5006      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
5007               if (lprn) then
5008               write (iout,*) "m",m," k",k," l",l," ffthet",
5009      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
5010      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
5011      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
5012      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
5013               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5014      &            cosph1ph2(k,l)*sinkt(m),
5015      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5016               endif
5017             enddo
5018           enddo
5019         enddo
5020 10      continue
5021 c        lprn1=.true.
5022         if (lprn1) write (iout,'(a4,i2,3f8.1,9h ethetai ,f10.5)')
5023      &  'ebe', i,theta(i)*rad2deg,phii*rad2deg,
5024      &   phii1*rad2deg,ethetai
5025 c        lprn1=.false.
5026         etheta=etheta+ethetai
5027         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5028         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5029         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
5030       enddo
5031       return
5032       end
5033 #endif
5034 #ifdef CRYST_SC
5035 c-----------------------------------------------------------------------------
5036       subroutine esc(escloc)
5037 C Calculate the local energy of a side chain and its derivatives in the
5038 C corresponding virtual-bond valence angles THETA and the spherical angles
5039 C ALPHA and OMEGA.
5040       implicit real*8 (a-h,o-z)
5041       include 'DIMENSIONS'
5042       include 'COMMON.GEO'
5043       include 'COMMON.LOCAL'
5044       include 'COMMON.VAR'
5045       include 'COMMON.INTERACT'
5046       include 'COMMON.DERIV'
5047       include 'COMMON.CHAIN'
5048       include 'COMMON.IOUNITS'
5049       include 'COMMON.NAMES'
5050       include 'COMMON.FFIELD'
5051       include 'COMMON.CONTROL'
5052       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5053      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5054       common /sccalc/ time11,time12,time112,theti,it,nlobit
5055       delta=0.02d0*pi
5056       escloc=0.0D0
5057 c     write (iout,'(a)') 'ESC'
5058       do i=loc_start,loc_end
5059         it=itype(i)
5060         if (it.eq.10) goto 1
5061         nlobit=nlob(it)
5062 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5063 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5064         theti=theta(i+1)-pipol
5065         x(1)=dtan(theti)
5066         x(2)=alph(i)
5067         x(3)=omeg(i)
5068
5069         if (x(2).gt.pi-delta) then
5070           xtemp(1)=x(1)
5071           xtemp(2)=pi-delta
5072           xtemp(3)=x(3)
5073           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5074           xtemp(2)=pi
5075           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5076           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5077      &        escloci,dersc(2))
5078           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5079      &        ddersc0(1),dersc(1))
5080           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5081      &        ddersc0(3),dersc(3))
5082           xtemp(2)=pi-delta
5083           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5084           xtemp(2)=pi
5085           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5086           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5087      &            dersc0(2),esclocbi,dersc02)
5088           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5089      &            dersc12,dersc01)
5090           call splinthet(x(2),0.5d0*delta,ss,ssd)
5091           dersc0(1)=dersc01
5092           dersc0(2)=dersc02
5093           dersc0(3)=0.0d0
5094           do k=1,3
5095             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5096           enddo
5097           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5098 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5099 c    &             esclocbi,ss,ssd
5100           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5101 c         escloci=esclocbi
5102 c         write (iout,*) escloci
5103         else if (x(2).lt.delta) then
5104           xtemp(1)=x(1)
5105           xtemp(2)=delta
5106           xtemp(3)=x(3)
5107           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5108           xtemp(2)=0.0d0
5109           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5110           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5111      &        escloci,dersc(2))
5112           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5113      &        ddersc0(1),dersc(1))
5114           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5115      &        ddersc0(3),dersc(3))
5116           xtemp(2)=delta
5117           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5118           xtemp(2)=0.0d0
5119           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5120           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5121      &            dersc0(2),esclocbi,dersc02)
5122           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5123      &            dersc12,dersc01)
5124           dersc0(1)=dersc01
5125           dersc0(2)=dersc02
5126           dersc0(3)=0.0d0
5127           call splinthet(x(2),0.5d0*delta,ss,ssd)
5128           do k=1,3
5129             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5130           enddo
5131           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5132 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5133 c    &             esclocbi,ss,ssd
5134           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5135 c         write (iout,*) escloci
5136         else
5137           call enesc(x,escloci,dersc,ddummy,.false.)
5138         endif
5139
5140         escloc=escloc+escloci
5141         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5142      &     'escloc',i,escloci
5143 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5144
5145         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5146      &   wscloc*dersc(1)
5147         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5148         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5149     1   continue
5150       enddo
5151       return
5152       end
5153 C---------------------------------------------------------------------------
5154       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5155       implicit real*8 (a-h,o-z)
5156       include 'DIMENSIONS'
5157       include 'COMMON.GEO'
5158       include 'COMMON.LOCAL'
5159       include 'COMMON.IOUNITS'
5160       common /sccalc/ time11,time12,time112,theti,it,nlobit
5161       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5162       double precision contr(maxlob,-1:1)
5163       logical mixed
5164 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5165         escloc_i=0.0D0
5166         do j=1,3
5167           dersc(j)=0.0D0
5168           if (mixed) ddersc(j)=0.0d0
5169         enddo
5170         x3=x(3)
5171
5172 C Because of periodicity of the dependence of the SC energy in omega we have
5173 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5174 C To avoid underflows, first compute & store the exponents.
5175
5176         do iii=-1,1
5177
5178           x(3)=x3+iii*dwapi
5179
5180           do j=1,nlobit
5181             do k=1,3
5182               z(k)=x(k)-censc(k,j,it)
5183             enddo
5184             do k=1,3
5185               Axk=0.0D0
5186               do l=1,3
5187                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5188               enddo
5189               Ax(k,j,iii)=Axk
5190             enddo
5191             expfac=0.0D0
5192             do k=1,3
5193               expfac=expfac+Ax(k,j,iii)*z(k)
5194             enddo
5195             contr(j,iii)=expfac
5196           enddo ! j
5197
5198         enddo ! iii
5199
5200         x(3)=x3
5201 C As in the case of ebend, we want to avoid underflows in exponentiation and
5202 C subsequent NaNs and INFs in energy calculation.
5203 C Find the largest exponent
5204         emin=contr(1,-1)
5205         do iii=-1,1
5206           do j=1,nlobit
5207             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5208           enddo
5209         enddo
5210         emin=0.5D0*emin
5211 cd      print *,'it=',it,' emin=',emin
5212
5213 C Compute the contribution to SC energy and derivatives
5214         do iii=-1,1
5215
5216           do j=1,nlobit
5217 #ifdef OSF
5218             adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin
5219             if(adexp.ne.adexp) adexp=1.0
5220             expfac=dexp(adexp)
5221 #else
5222             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
5223 #endif
5224 cd          print *,'j=',j,' expfac=',expfac
5225             escloc_i=escloc_i+expfac
5226             do k=1,3
5227               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5228             enddo
5229             if (mixed) then
5230               do k=1,3,2
5231                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5232      &            +gaussc(k,2,j,it))*expfac
5233               enddo
5234             endif
5235           enddo
5236
5237         enddo ! iii
5238
5239         dersc(1)=dersc(1)/cos(theti)**2
5240         ddersc(1)=ddersc(1)/cos(theti)**2
5241         ddersc(3)=ddersc(3)
5242
5243         escloci=-(dlog(escloc_i)-emin)
5244         do j=1,3
5245           dersc(j)=dersc(j)/escloc_i
5246         enddo
5247         if (mixed) then
5248           do j=1,3,2
5249             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5250           enddo
5251         endif
5252       return
5253       end
5254 C------------------------------------------------------------------------------
5255       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5256       implicit real*8 (a-h,o-z)
5257       include 'DIMENSIONS'
5258       include 'COMMON.GEO'
5259       include 'COMMON.LOCAL'
5260       include 'COMMON.IOUNITS'
5261       common /sccalc/ time11,time12,time112,theti,it,nlobit
5262       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5263       double precision contr(maxlob)
5264       logical mixed
5265
5266       escloc_i=0.0D0
5267
5268       do j=1,3
5269         dersc(j)=0.0D0
5270       enddo
5271
5272       do j=1,nlobit
5273         do k=1,2
5274           z(k)=x(k)-censc(k,j,it)
5275         enddo
5276         z(3)=dwapi
5277         do k=1,3
5278           Axk=0.0D0
5279           do l=1,3
5280             Axk=Axk+gaussc(l,k,j,it)*z(l)
5281           enddo
5282           Ax(k,j)=Axk
5283         enddo
5284         expfac=0.0D0
5285         do k=1,3
5286           expfac=expfac+Ax(k,j)*z(k)
5287         enddo
5288         contr(j)=expfac
5289       enddo ! j
5290
5291 C As in the case of ebend, we want to avoid underflows in exponentiation and
5292 C subsequent NaNs and INFs in energy calculation.
5293 C Find the largest exponent
5294       emin=contr(1)
5295       do j=1,nlobit
5296         if (emin.gt.contr(j)) emin=contr(j)
5297       enddo
5298       emin=0.5D0*emin
5299
5300 C Compute the contribution to SC energy and derivatives
5301
5302       dersc12=0.0d0
5303       do j=1,nlobit
5304         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
5305         escloc_i=escloc_i+expfac
5306         do k=1,2
5307           dersc(k)=dersc(k)+Ax(k,j)*expfac
5308         enddo
5309         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5310      &            +gaussc(1,2,j,it))*expfac
5311         dersc(3)=0.0d0
5312       enddo
5313
5314       dersc(1)=dersc(1)/cos(theti)**2
5315       dersc12=dersc12/cos(theti)**2
5316       escloci=-(dlog(escloc_i)-emin)
5317       do j=1,2
5318         dersc(j)=dersc(j)/escloc_i
5319       enddo
5320       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5321       return
5322       end
5323 #else
5324 c----------------------------------------------------------------------------------
5325       subroutine esc(escloc)
5326 C Calculate the local energy of a side chain and its derivatives in the
5327 C corresponding virtual-bond valence angles THETA and the spherical angles
5328 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5329 C added by Urszula Kozlowska. 07/11/2007
5330 C
5331       implicit real*8 (a-h,o-z)
5332       include 'DIMENSIONS'
5333       include 'COMMON.GEO'
5334       include 'COMMON.LOCAL'
5335       include 'COMMON.VAR'
5336       include 'COMMON.SCROT'
5337       include 'COMMON.INTERACT'
5338       include 'COMMON.DERIV'
5339       include 'COMMON.CHAIN'
5340       include 'COMMON.IOUNITS'
5341       include 'COMMON.NAMES'
5342       include 'COMMON.FFIELD'
5343       include 'COMMON.CONTROL'
5344       include 'COMMON.VECTORS'
5345       double precision x_prime(3),y_prime(3),z_prime(3)
5346      &    , sumene,dsc_i,dp2_i,x(65),
5347      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5348      &    de_dxx,de_dyy,de_dzz,de_dt
5349       double precision s1_t,s1_6_t,s2_t,s2_6_t
5350       double precision
5351      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5352      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5353      & dt_dCi(3),dt_dCi1(3)
5354       common /sccalc/ time11,time12,time112,theti,it,nlobit
5355       delta=0.02d0*pi
5356       escloc=0.0D0
5357 c      write(iout,*) "ESC: loc_start",loc_start," loc_end",loc_end
5358       do i=loc_start,loc_end
5359         costtab(i+1) =dcos(theta(i+1))
5360         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5361         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5362         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5363         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5364         cosfac=dsqrt(cosfac2)
5365         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5366         sinfac=dsqrt(sinfac2)
5367         it=itype(i)
5368         if (it.eq.10) goto 1
5369 c
5370 C  Compute the axes of tghe local cartesian coordinates system; store in
5371 c   x_prime, y_prime and z_prime
5372 c
5373         do j=1,3
5374           x_prime(j) = 0.00
5375           y_prime(j) = 0.00
5376           z_prime(j) = 0.00
5377         enddo
5378 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5379 C     &   dc_norm(3,i+nres)
5380         do j = 1,3
5381           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5382           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5383         enddo
5384         do j = 1,3
5385           z_prime(j) = -uz(j,i-1)
5386         enddo
5387 c       write (2,*) "i",i
5388 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5389 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5390 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5391 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5392 c      & " xy",scalar(x_prime(1),y_prime(1)),
5393 c      & " xz",scalar(x_prime(1),z_prime(1)),
5394 c      & " yy",scalar(y_prime(1),y_prime(1)),
5395 c      & " yz",scalar(y_prime(1),z_prime(1)),
5396 c      & " zz",scalar(z_prime(1),z_prime(1))
5397 c
5398 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5399 C to local coordinate system. Store in xx, yy, zz.
5400 c
5401         xx=0.0d0
5402         yy=0.0d0
5403         zz=0.0d0
5404         do j = 1,3
5405           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5406           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5407           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5408         enddo
5409
5410         xxtab(i)=xx
5411         yytab(i)=yy
5412         zztab(i)=zz
5413 C
5414 C Compute the energy of the ith side cbain
5415 C
5416 c        write (2,*) "xx",xx," yy",yy," zz",zz
5417         it=itype(i)
5418         do j = 1,65
5419           x(j) = sc_parmin(j,it)
5420         enddo
5421 #ifdef CHECK_COORD
5422 Cc diagnostics - remove later
5423         xx1 = dcos(alph(2))
5424         yy1 = dsin(alph(2))*dcos(omeg(2))
5425         zz1 = -dsin(alph(2))*dsin(omeg(2))
5426         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5427      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5428      &    xx1,yy1,zz1
5429 C,"  --- ", xx_w,yy_w,zz_w
5430 c end diagnostics
5431 #endif
5432         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5433      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5434      &   + x(10)*yy*zz
5435         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5436      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5437      & + x(20)*yy*zz
5438         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5439      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5440      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5441      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5442      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5443      &  +x(40)*xx*yy*zz
5444         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5445      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5446      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5447      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5448      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5449      &  +x(60)*xx*yy*zz
5450         dsc_i   = 0.743d0+x(61)
5451         dp2_i   = 1.9d0+x(62)
5452         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5453      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5454         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5455      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5456         s1=(1+x(63))/(0.1d0 + dscp1)
5457         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5458         s2=(1+x(65))/(0.1d0 + dscp2)
5459         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5460         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5461      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5462 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5463 c     &   sumene4,
5464 c     &   dscp1,dscp2,sumene
5465 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5466         escloc = escloc + sumene
5467 c        write (2,*) "i",i," escloc",sumene,escloc
5468 #ifdef DEBUG
5469 C
5470 C This section to check the numerical derivatives of the energy of ith side
5471 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5472 C #define DEBUG in the code to turn it on.
5473 C
5474         write (2,*) "sumene               =",sumene
5475         aincr=1.0d-7
5476         xxsave=xx
5477         xx=xx+aincr
5478         write (2,*) xx,yy,zz
5479         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5480         de_dxx_num=(sumenep-sumene)/aincr
5481         xx=xxsave
5482         write (2,*) "xx+ sumene from enesc=",sumenep
5483         yysave=yy
5484         yy=yy+aincr
5485         write (2,*) xx,yy,zz
5486         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5487         de_dyy_num=(sumenep-sumene)/aincr
5488         yy=yysave
5489         write (2,*) "yy+ sumene from enesc=",sumenep
5490         zzsave=zz
5491         zz=zz+aincr
5492         write (2,*) xx,yy,zz
5493         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5494         de_dzz_num=(sumenep-sumene)/aincr
5495         zz=zzsave
5496         write (2,*) "zz+ sumene from enesc=",sumenep
5497         costsave=cost2tab(i+1)
5498         sintsave=sint2tab(i+1)
5499         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5500         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5501         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5502         de_dt_num=(sumenep-sumene)/aincr
5503         write (2,*) " t+ sumene from enesc=",sumenep
5504         cost2tab(i+1)=costsave
5505         sint2tab(i+1)=sintsave
5506 C End of diagnostics section.
5507 #endif
5508 C
5509 C Compute the gradient of esc
5510 C
5511         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5512         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5513         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5514         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5515         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5516         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5517         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5518         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5519         pom1=(sumene3*sint2tab(i+1)+sumene1)
5520      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5521         pom2=(sumene4*cost2tab(i+1)+sumene2)
5522      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5523         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5524         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5525      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5526      &  +x(40)*yy*zz
5527         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5528         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5529      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5530      &  +x(60)*yy*zz
5531         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5532      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5533      &        +(pom1+pom2)*pom_dx
5534 #ifdef DEBUG
5535         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5536 #endif
5537 C
5538         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5539         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5540      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5541      &  +x(40)*xx*zz
5542         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5543         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5544      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5545      &  +x(59)*zz**2 +x(60)*xx*zz
5546         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5547      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5548      &        +(pom1-pom2)*pom_dy
5549 #ifdef DEBUG
5550         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5551 #endif
5552 C
5553         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5554      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5555      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5556      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5557      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5558      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5559      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5560      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5561 #ifdef DEBUG
5562         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5563 #endif
5564 C
5565         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5566      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5567      &  +pom1*pom_dt1+pom2*pom_dt2
5568 #ifdef DEBUG
5569         write(2,*), "de_dt = ", de_dt,de_dt_num
5570 #endif
5571 c
5572 C
5573        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5574        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5575        cosfac2xx=cosfac2*xx
5576        sinfac2yy=sinfac2*yy
5577        do k = 1,3
5578          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5579      &      vbld_inv(i+1)
5580          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5581      &      vbld_inv(i)
5582          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5583          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5584 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5585 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5586 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5587 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5588          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5589          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5590          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5591          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5592          dZZ_Ci1(k)=0.0d0
5593          dZZ_Ci(k)=0.0d0
5594          do j=1,3
5595            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5596            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5597          enddo
5598
5599          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5600          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5601          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5602 c
5603          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5604          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5605        enddo
5606
5607        do k=1,3
5608          dXX_Ctab(k,i)=dXX_Ci(k)
5609          dXX_C1tab(k,i)=dXX_Ci1(k)
5610          dYY_Ctab(k,i)=dYY_Ci(k)
5611          dYY_C1tab(k,i)=dYY_Ci1(k)
5612          dZZ_Ctab(k,i)=dZZ_Ci(k)
5613          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5614          dXX_XYZtab(k,i)=dXX_XYZ(k)
5615          dYY_XYZtab(k,i)=dYY_XYZ(k)
5616          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5617        enddo
5618
5619        do k = 1,3
5620 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5621 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5622 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5623 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5624 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5625 c     &    dt_dci(k)
5626 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5627 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5628          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5629      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5630          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5631      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5632          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5633      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5634        enddo
5635 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5636 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5637
5638 C to check gradient call subroutine check_grad
5639
5640     1 continue
5641       enddo
5642       return
5643       end
5644 c------------------------------------------------------------------------------
5645       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5646       implicit none
5647       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5648      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5649       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5650      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5651      &   + x(10)*yy*zz
5652       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5653      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5654      & + x(20)*yy*zz
5655       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5656      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5657      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5658      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5659      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5660      &  +x(40)*xx*yy*zz
5661       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5662      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5663      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5664      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5665      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5666      &  +x(60)*xx*yy*zz
5667       dsc_i   = 0.743d0+x(61)
5668       dp2_i   = 1.9d0+x(62)
5669       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5670      &          *(xx*cost2+yy*sint2))
5671       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5672      &          *(xx*cost2-yy*sint2))
5673       s1=(1+x(63))/(0.1d0 + dscp1)
5674       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5675       s2=(1+x(65))/(0.1d0 + dscp2)
5676       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5677       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5678      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5679       enesc=sumene
5680       return
5681       end
5682 #endif
5683 c------------------------------------------------------------------------------
5684       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5685 C
5686 C This procedure calculates two-body contact function g(rij) and its derivative:
5687 C
5688 C           eps0ij                                     !       x < -1
5689 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5690 C            0                                         !       x > 1
5691 C
5692 C where x=(rij-r0ij)/delta
5693 C
5694 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5695 C
5696       implicit none
5697       double precision rij,r0ij,eps0ij,fcont,fprimcont
5698       double precision x,x2,x4,delta
5699 c     delta=0.02D0*r0ij
5700 c      delta=0.2D0*r0ij
5701       x=(rij-r0ij)/delta
5702       if (x.lt.-1.0D0) then
5703         fcont=eps0ij
5704         fprimcont=0.0D0
5705       else if (x.le.1.0D0) then
5706         x2=x*x
5707         x4=x2*x2
5708         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5709         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5710       else
5711         fcont=0.0D0
5712         fprimcont=0.0D0
5713       endif
5714       return
5715       end
5716 c------------------------------------------------------------------------------
5717       subroutine splinthet(theti,delta,ss,ssder)
5718       implicit real*8 (a-h,o-z)
5719       include 'DIMENSIONS'
5720       include 'COMMON.VAR'
5721       include 'COMMON.GEO'
5722       thetup=pi-delta
5723       thetlow=delta
5724       if (theti.gt.pipol) then
5725         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5726       else
5727         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5728         ssder=-ssder
5729       endif
5730       return
5731       end
5732 c------------------------------------------------------------------------------
5733       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5734       implicit none
5735       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5736       double precision ksi,ksi2,ksi3,a1,a2,a3
5737       a1=fprim0*delta/(f1-f0)
5738       a2=3.0d0-2.0d0*a1
5739       a3=a1-2.0d0
5740       ksi=(x-x0)/delta
5741       ksi2=ksi*ksi
5742       ksi3=ksi2*ksi
5743       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5744       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5745       return
5746       end
5747 c------------------------------------------------------------------------------
5748       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5749       implicit none
5750       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5751       double precision ksi,ksi2,ksi3,a1,a2,a3
5752       ksi=(x-x0)/delta
5753       ksi2=ksi*ksi
5754       ksi3=ksi2*ksi
5755       a1=fprim0x*delta
5756       a2=3*(f1x-f0x)-2*fprim0x*delta
5757       a3=fprim0x*delta-2*(f1x-f0x)
5758       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5759       return
5760       end
5761 C-----------------------------------------------------------------------------
5762 #ifdef CRYST_TOR
5763 C-----------------------------------------------------------------------------
5764       subroutine etor(etors,edihcnstr)
5765       implicit real*8 (a-h,o-z)
5766       include 'DIMENSIONS'
5767       include 'COMMON.VAR'
5768       include 'COMMON.GEO'
5769       include 'COMMON.LOCAL'
5770       include 'COMMON.TORSION'
5771       include 'COMMON.INTERACT'
5772       include 'COMMON.DERIV'
5773       include 'COMMON.CHAIN'
5774       include 'COMMON.NAMES'
5775       include 'COMMON.IOUNITS'
5776       include 'COMMON.FFIELD'
5777       include 'COMMON.TORCNSTR'
5778       include 'COMMON.CONTROL'
5779       logical lprn
5780 C Set lprn=.true. for debugging
5781       lprn=.false.
5782 c      lprn=.true.
5783       etors=0.0D0
5784       do i=iphi_start,iphi_end
5785       etors_ii=0.0D0
5786         itori=itortyp(itype(i-2))
5787         itori1=itortyp(itype(i-1))
5788         phii=phi(i)
5789         gloci=0.0D0
5790 C Proline-Proline pair is a special case...
5791         if (itori.eq.3 .and. itori1.eq.3) then
5792           if (phii.gt.-dwapi3) then
5793             cosphi=dcos(3*phii)
5794             fac=1.0D0/(1.0D0-cosphi)
5795             etorsi=v1(1,3,3)*fac
5796             etorsi=etorsi+etorsi
5797             etors=etors+etorsi-v1(1,3,3)
5798             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5799             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5800           endif
5801           do j=1,3
5802             v1ij=v1(j+1,itori,itori1)
5803             v2ij=v2(j+1,itori,itori1)
5804             cosphi=dcos(j*phii)
5805             sinphi=dsin(j*phii)
5806             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5807             if (energy_dec) etors_ii=etors_ii+
5808      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5809             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5810           enddo
5811         else
5812           do j=1,nterm_old
5813             v1ij=v1(j,itori,itori1)
5814             v2ij=v2(j,itori,itori1)
5815             cosphi=dcos(j*phii)
5816             sinphi=dsin(j*phii)
5817             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5818             if (energy_dec) etors_ii=etors_ii+
5819      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5820             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5821           enddo
5822         endif
5823         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5824      &        'etor',i,etors_ii
5825         if (lprn)
5826      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5827      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5828      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5829         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5830         write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5831       enddo
5832 ! 6/20/98 - dihedral angle constraints
5833       edihcnstr=0.0d0
5834       do i=1,ndih_constr
5835         itori=idih_constr(i)
5836         phii=phi(itori)
5837         difi=phii-phi0(i)
5838         if (difi.gt.drange(i)) then
5839           difi=difi-drange(i)
5840           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5841           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5842         else if (difi.lt.-drange(i)) then
5843           difi=difi+drange(i)
5844           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5845           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5846         endif
5847 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5848 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5849       enddo
5850 !      write (iout,*) 'edihcnstr',edihcnstr
5851       return
5852       end
5853 c------------------------------------------------------------------------------
5854 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
5855       subroutine e_modeller(ehomology_constr)
5856       ehomology_constr=0.0d0
5857       write (iout,*) "!!!!!UWAGA, JESTEM W DZIWNEJ PETLI, TEST!!!!!"
5858       return
5859       end
5860 C !!!!!!!! NIE CZYTANE !!!!!!!!!!!
5861
5862 c------------------------------------------------------------------------------
5863       subroutine etor_d(etors_d)
5864       etors_d=0.0d0
5865       return
5866       end
5867 c----------------------------------------------------------------------------
5868 #else
5869       subroutine etor(etors,edihcnstr)
5870       implicit real*8 (a-h,o-z)
5871       include 'DIMENSIONS'
5872       include 'COMMON.VAR'
5873       include 'COMMON.GEO'
5874       include 'COMMON.LOCAL'
5875       include 'COMMON.TORSION'
5876       include 'COMMON.INTERACT'
5877       include 'COMMON.DERIV'
5878       include 'COMMON.CHAIN'
5879       include 'COMMON.NAMES'
5880       include 'COMMON.IOUNITS'
5881       include 'COMMON.FFIELD'
5882       include 'COMMON.TORCNSTR'
5883       include 'COMMON.CONTROL'
5884       logical lprn
5885 C Set lprn=.true. for debugging
5886       lprn=.false.
5887 c     lprn=.true.
5888       etors=0.0D0
5889       do i=iphi_start,iphi_end
5890       etors_ii=0.0D0
5891         itori=itortyp(itype(i-2))
5892         itori1=itortyp(itype(i-1))
5893         phii=phi(i)
5894         gloci=0.0D0
5895 C Regular cosine and sine terms
5896         do j=1,nterm(itori,itori1)
5897           v1ij=v1(j,itori,itori1)
5898           v2ij=v2(j,itori,itori1)
5899           cosphi=dcos(j*phii)
5900           sinphi=dsin(j*phii)
5901           etors=etors+v1ij*cosphi+v2ij*sinphi
5902           if (energy_dec) etors_ii=etors_ii+
5903      &                v1ij*cosphi+v2ij*sinphi
5904           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5905         enddo
5906 C Lorentz terms
5907 C                         v1
5908 C  E = SUM ----------------------------------- - v1
5909 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5910 C
5911         cosphi=dcos(0.5d0*phii)
5912         sinphi=dsin(0.5d0*phii)
5913         do j=1,nlor(itori,itori1)
5914           vl1ij=vlor1(j,itori,itori1)
5915           vl2ij=vlor2(j,itori,itori1)
5916           vl3ij=vlor3(j,itori,itori1)
5917           pom=vl2ij*cosphi+vl3ij*sinphi
5918           pom1=1.0d0/(pom*pom+1.0d0)
5919           etors=etors+vl1ij*pom1
5920           if (energy_dec) etors_ii=etors_ii+
5921      &                vl1ij*pom1
5922           pom=-pom*pom1*pom1
5923           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5924         enddo
5925 C Subtract the constant term
5926         etors=etors-v0(itori,itori1)
5927           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5928      &         'etor',i,etors_ii-v0(itori,itori1)
5929         if (lprn)
5930      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5931      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5932      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5933         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5934 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5935       enddo
5936 ! 6/20/98 - dihedral angle constraints
5937       edihcnstr=0.0d0
5938 c      do i=1,ndih_constr
5939       do i=idihconstr_start,idihconstr_end
5940         itori=idih_constr(i)
5941         phii=phi(itori)
5942         difi=pinorm(phii-phi0(i))
5943         if (difi.gt.drange(i)) then
5944           difi=difi-drange(i)
5945           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5946           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5947         else if (difi.lt.-drange(i)) then
5948           difi=difi+drange(i)
5949           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5950           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5951         else
5952           difi=0.0
5953         endif
5954 c        write (iout,*) "gloci", gloc(i-3,icg)
5955 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5956 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5957 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5958       enddo
5959 cd       write (iout,*) 'edihcnstr',edihcnstr
5960       return
5961       end
5962 c----------------------------------------------------------------------------
5963 c MODELLER restraint function
5964       subroutine e_modeller(ehomology_constr)
5965       implicit real*8 (a-h,o-z)
5966       include 'DIMENSIONS'
5967
5968       integer nnn, i, j, k, ki, irec, l
5969       integer katy, odleglosci, test7
5970       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
5971       real*8 Eval,Erot
5972       real*8 distance(max_template),distancek(max_template),
5973      &    min_odl,godl(max_template),dih_diff(max_template)
5974
5975 c
5976 c     FP - 30/10/2014 Temporary specifications for homology restraints
5977 c
5978       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
5979      &                 sgtheta
5980       double precision, dimension (maxres) :: guscdiff,usc_diff
5981       double precision, dimension (max_template) ::
5982      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
5983      &           theta_diff
5984 c
5985
5986       include 'COMMON.SBRIDGE'
5987       include 'COMMON.CHAIN'
5988       include 'COMMON.GEO'
5989       include 'COMMON.DERIV'
5990       include 'COMMON.LOCAL'
5991       include 'COMMON.INTERACT'
5992       include 'COMMON.VAR'
5993       include 'COMMON.IOUNITS'
5994       include 'COMMON.MD'
5995       include 'COMMON.CONTROL'
5996 c
5997 c     From subroutine Econstr_back
5998 c
5999       include 'COMMON.NAMES'
6000       include 'COMMON.TIME1'
6001 c
6002
6003
6004       do i=1,19
6005         distancek(i)=9999999.9
6006       enddo
6007
6008
6009       odleg=0.0d0
6010
6011 c Pseudo-energy and gradient from homology restraints (MODELLER-like
6012 c function)
6013 C AL 5/2/14 - Introduce list of restraints
6014 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
6015 #ifdef DEBUG
6016       write(iout,*) "------- dist restrs start -------"
6017 #endif
6018       do ii = link_start_homo,link_end_homo
6019          i = ires_homo(ii)
6020          j = jres_homo(ii)
6021          dij=dist(i,j)
6022 c        write (iout,*) "dij(",i,j,") =",dij
6023          do k=1,constr_homology
6024            distance(k)=odl(k,ii)-dij
6025 c          write (iout,*) "distance(",k,") =",distance(k)
6026 c
6027 c          For Gaussian-type Urestr
6028 c
6029            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
6030 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
6031 c          write (iout,*) "distancek(",k,") =",distancek(k)
6032 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
6033 c
6034 c          For Lorentzian-type Urestr
6035 c
6036            if (waga_dist.lt.0.0d0) then
6037               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
6038               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
6039      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
6040            endif
6041          enddo
6042
6043          min_odl=minval(distancek)
6044 c        write (iout,* )"min_odl",min_odl
6045 #ifdef DEBUG
6046          write (iout,*) "ij dij",i,j,dij
6047          write (iout,*) "distance",(distance(k),k=1,constr_homology)
6048          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
6049          write (iout,* )"min_odl",min_odl
6050 #endif
6051          odleg2=0.0d0
6052          do k=1,constr_homology
6053 c Nie wiem po co to liczycie jeszcze raz!
6054 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
6055 c     &              (2*(sigma_odl(i,j,k))**2))
6056            if (waga_dist.ge.0.0d0) then
6057 c
6058 c          For Gaussian-type Urestr
6059 c
6060             godl(k)=dexp(-distancek(k)+min_odl)
6061             odleg2=odleg2+godl(k)
6062 c
6063 c          For Lorentzian-type Urestr
6064 c
6065            else
6066             odleg2=odleg2+distancek(k)
6067            endif
6068
6069 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
6070 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
6071 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
6072 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
6073
6074          enddo
6075 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
6076 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
6077 #ifdef DEBUG
6078          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
6079          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
6080 #endif
6081            if (waga_dist.ge.0.0d0) then
6082 c
6083 c          For Gaussian-type Urestr
6084 c
6085               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
6086 c
6087 c          For Lorentzian-type Urestr
6088 c
6089            else
6090               odleg=odleg+odleg2/constr_homology
6091            endif
6092 c
6093 c        write (iout,*) "odleg",odleg ! sum of -ln-s
6094 c Gradient
6095 c
6096 c          For Gaussian-type Urestr
6097 c
6098          if (waga_dist.ge.0.0d0) sum_godl=odleg2
6099          sum_sgodl=0.0d0
6100          do k=1,constr_homology
6101 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
6102 c     &           *waga_dist)+min_odl
6103 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
6104 c
6105          if (waga_dist.ge.0.0d0) then
6106 c          For Gaussian-type Urestr
6107 c
6108            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
6109 c
6110 c          For Lorentzian-type Urestr
6111 c
6112          else
6113            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
6114      &           sigma_odlir(k,ii)**2)**2)
6115          endif
6116            sum_sgodl=sum_sgodl+sgodl
6117
6118 c            sgodl2=sgodl2+sgodl
6119 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
6120 c      write(iout,*) "constr_homology=",constr_homology
6121 c      write(iout,*) i, j, k, "TEST K"
6122          enddo
6123          if (waga_dist.ge.0.0d0) then
6124 c
6125 c          For Gaussian-type Urestr
6126 c
6127             grad_odl3=waga_homology(iset)*waga_dist
6128      &                *sum_sgodl/(sum_godl*dij)
6129 c
6130 c          For Lorentzian-type Urestr
6131 c
6132          else
6133 c Original grad expr modified by analogy w Gaussian-type Urestr grad
6134 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
6135             grad_odl3=-waga_homology(iset)*waga_dist*
6136      &                sum_sgodl/(constr_homology*dij)
6137          endif
6138 c
6139 c        grad_odl3=sum_sgodl/(sum_godl*dij)
6140
6141
6142 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
6143 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
6144 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
6145
6146 ccc      write(iout,*) godl, sgodl, grad_odl3
6147
6148 c          grad_odl=grad_odl+grad_odl3
6149
6150          do jik=1,3
6151             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
6152 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
6153 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
6154 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
6155             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
6156             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
6157 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
6158 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
6159 c         if (i.eq.25.and.j.eq.27) then
6160 c         write(iout,*) "jik",jik,"i",i,"j",j
6161 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
6162 c         write(iout,*) "grad_odl3",grad_odl3
6163 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
6164 c         write(iout,*) "ggodl",ggodl
6165 c         write(iout,*) "ghpbc(",jik,i,")",
6166 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
6167 c     &                 ghpbc(jik,j)
6168 c         endif
6169          enddo
6170 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
6171 ccc     & dLOG(odleg2),"-odleg=", -odleg
6172
6173       enddo ! ii-loop for dist
6174 #ifdef DEBUG
6175       write(iout,*) "------- dist restrs end -------"
6176 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
6177 c    &     waga_d.eq.1.0d0) call sum_gradient
6178 #endif
6179 c Pseudo-energy and gradient from dihedral-angle restraints from
6180 c homology templates
6181 c      write (iout,*) "End of distance loop"
6182 c      call flush(iout)
6183       kat=0.0d0
6184 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
6185 #ifdef DEBUG
6186       write(iout,*) "------- dih restrs start -------"
6187       do i=idihconstr_start_homo,idihconstr_end_homo
6188         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
6189       enddo
6190 #endif
6191       do i=idihconstr_start_homo,idihconstr_end_homo
6192         kat2=0.0d0
6193 c        betai=beta(i,i+1,i+2,i+3)
6194         betai = phi(i+3)
6195 c       write (iout,*) "betai =",betai
6196         do k=1,constr_homology
6197           dih_diff(k)=pinorm(dih(k,i)-betai)
6198 c         write (iout,*) "dih_diff(",k,") =",dih_diff(k)
6199 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
6200 c     &                                   -(6.28318-dih_diff(i,k))
6201 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
6202 c     &                                   6.28318+dih_diff(i,k)
6203
6204           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
6205 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
6206           gdih(k)=dexp(kat3)
6207           kat2=kat2+gdih(k)
6208 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
6209 c          write(*,*)""
6210         enddo
6211 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
6212 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
6213 #ifdef DEBUG
6214         write (iout,*) "i",i," betai",betai," kat2",kat2
6215         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
6216 #endif
6217         if (kat2.le.1.0d-14) cycle
6218         kat=kat-dLOG(kat2/constr_homology)
6219 c       write (iout,*) "kat",kat ! sum of -ln-s
6220
6221 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
6222 ccc     & dLOG(kat2), "-kat=", -kat
6223
6224 c ----------------------------------------------------------------------
6225 c Gradient
6226 c ----------------------------------------------------------------------
6227
6228         sum_gdih=kat2
6229         sum_sgdih=0.0d0
6230         do k=1,constr_homology
6231           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
6232 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
6233           sum_sgdih=sum_sgdih+sgdih
6234         enddo
6235 c       grad_dih3=sum_sgdih/sum_gdih
6236         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
6237
6238 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
6239 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
6240 ccc     & gloc(nphi+i-3,icg)
6241         gloc(i,icg)=gloc(i,icg)+grad_dih3
6242 c        if (i.eq.25) then
6243 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
6244 c        endif
6245 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
6246 ccc     & gloc(nphi+i-3,icg)
6247
6248       enddo ! i-loop for dih
6249 #ifdef DEBUG
6250       write(iout,*) "------- dih restrs end -------"
6251 #endif
6252
6253 c Pseudo-energy and gradient for theta angle restraints from
6254 c homology templates
6255 c FP 01/15 - inserted from econstr_local_test.F, loop structure
6256 c adapted
6257
6258 c
6259 c     For constr_homology reference structures (FP)
6260 c
6261 c     Uconst_back_tot=0.0d0
6262       Eval=0.0d0
6263       Erot=0.0d0
6264 c     Econstr_back legacy
6265       do i=1,nres
6266 c     do i=ithet_start,ithet_end
6267        dutheta(i)=0.0d0
6268 c     enddo
6269 c     do i=loc_start,loc_end
6270         do j=1,3
6271           duscdiff(j,i)=0.0d0
6272           duscdiffx(j,i)=0.0d0
6273         enddo
6274       enddo
6275 c
6276 c     do iref=1,nref
6277 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
6278 c     write (iout,*) "waga_theta",waga_theta
6279       if (waga_theta.gt.0.0d0) then
6280 #ifdef DEBUG
6281       write (iout,*) "usampl",usampl
6282       write(iout,*) "------- theta restrs start -------"
6283 c     do i=ithet_start,ithet_end
6284 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
6285 c     enddo
6286 #endif
6287 c     write (iout,*) "maxres",maxres,"nres",nres
6288
6289       do i=ithet_start,ithet_end
6290 c
6291 c     do i=1,nfrag_back
6292 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
6293 c
6294 c Deviation of theta angles wrt constr_homology ref structures
6295 c
6296         utheta_i=0.0d0 ! argument of Gaussian for single k
6297         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
6298 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
6299 c       over residues in a fragment
6300 c       write (iout,*) "theta(",i,")=",theta(i)
6301         do k=1,constr_homology
6302 c
6303 c         dtheta_i=theta(j)-thetaref(j,iref)
6304 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
6305           theta_diff(k)=thetatpl(k,i)-theta(i)
6306 c
6307           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
6308 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
6309           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
6310           gutheta_i=gutheta_i+dexp(utheta_i)   ! Sum of Gaussians (pk)
6311 c         Gradient for single Gaussian restraint in subr Econstr_back
6312 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
6313 c
6314         enddo
6315 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
6316 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
6317
6318 c
6319 c         Gradient for multiple Gaussian restraint
6320         sum_gtheta=gutheta_i
6321         sum_sgtheta=0.0d0
6322         do k=1,constr_homology
6323 c        New generalized expr for multiple Gaussian from Econstr_back
6324          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
6325 c
6326 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
6327           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
6328         enddo
6329 c       grad_theta3=sum_sgtheta/sum_gtheta 1/*theta(i)? s. line below
6330 c       grad_theta3=sum_sgtheta/sum_gtheta
6331 c
6332 c       Final value of gradient using same var as in Econstr_back
6333         dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
6334      &               *waga_homology(iset)
6335 c       dutheta(i)=sum_sgtheta/sum_gtheta
6336 c
6337 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
6338         Eval=Eval-dLOG(gutheta_i/constr_homology)
6339 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
6340 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
6341 c       Uconst_back=Uconst_back+utheta(i)
6342       enddo ! (i-loop for theta)
6343 #ifdef DEBUG
6344       write(iout,*) "------- theta restrs end -------"
6345 #endif
6346       endif
6347 c
6348 c Deviation of local SC geometry
6349 c
6350 c Separation of two i-loops (instructed by AL - 11/3/2014)
6351 c
6352 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
6353 c     write (iout,*) "waga_d",waga_d
6354
6355 #ifdef DEBUG
6356       write(iout,*) "------- SC restrs start -------"
6357       write (iout,*) "Initial duscdiff,duscdiffx"
6358       do i=loc_start,loc_end
6359         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
6360      &                 (duscdiffx(jik,i),jik=1,3)
6361       enddo
6362 #endif
6363       do i=loc_start,loc_end
6364         usc_diff_i=0.0d0 ! argument of Gaussian for single k
6365         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
6366 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
6367 c       write(iout,*) "xxtab, yytab, zztab"
6368 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
6369         do k=1,constr_homology
6370 c
6371           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
6372 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
6373           dyy=-yytpl(k,i)+yytab(i) ! ibid y
6374           dzz=-zztpl(k,i)+zztab(i) ! ibid z
6375 c         write(iout,*) "dxx, dyy, dzz"
6376 c         write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
6377 c
6378           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
6379 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
6380 c         uscdiffk(k)=usc_diff(i)
6381           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
6382           guscdiff(i)=guscdiff(i)+dexp(usc_diff_i)   !Sum of Gaussians (pk)
6383 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
6384 c     &      xxref(j),yyref(j),zzref(j)
6385         enddo
6386 c
6387 c       Gradient
6388 c
6389 c       Generalized expression for multiple Gaussian acc to that for a single
6390 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
6391 c
6392 c       Original implementation
6393 c       sum_guscdiff=guscdiff(i)
6394 c
6395 c       sum_sguscdiff=0.0d0
6396 c       do k=1,constr_homology
6397 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
6398 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
6399 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
6400 c       enddo
6401 c
6402 c       Implementation of new expressions for gradient (Jan. 2015)
6403 c
6404 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
6405         do k=1,constr_homology
6406 c
6407 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
6408 c       before. Now the drivatives should be correct
6409 c
6410           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
6411 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
6412           dyy=-yytpl(k,i)+yytab(i) ! ibid y
6413           dzz=-zztpl(k,i)+zztab(i) ! ibid z
6414 c
6415 c         New implementation
6416 c
6417           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
6418      &                 sigma_d(k,i) ! for the grad wrt r'
6419 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
6420 c
6421 c
6422 c        New implementation
6423          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
6424          do jik=1,3
6425             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
6426      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
6427      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
6428             duscdiff(jik,i)=duscdiff(jik,i)+
6429      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
6430      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
6431             duscdiffx(jik,i)=duscdiffx(jik,i)+
6432      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
6433      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
6434 c
6435 #ifdef DEBUG
6436              write(iout,*) "jik",jik,"i",i
6437              write(iout,*) "dxx, dyy, dzz"
6438              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
6439              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
6440 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
6441 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
6442 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
6443 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
6444 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
6445 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
6446 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
6447 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
6448 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
6449 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
6450 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
6451 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
6452 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
6453 c            endif
6454 #endif
6455          enddo
6456         enddo
6457 c
6458 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
6459 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
6460 c
6461 c        write (iout,*) i," uscdiff",uscdiff(i)
6462 c
6463 c Put together deviations from local geometry
6464
6465 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
6466 c      &            wfrag_back(3,i,iset)*uscdiff(i)
6467         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
6468 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
6469 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
6470 c       Uconst_back=Uconst_back+usc_diff(i)
6471 c
6472 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
6473 c
6474 c     New implment: multiplied by sum_sguscdiff
6475 c
6476
6477       enddo ! (i-loop for dscdiff)
6478
6479 c      endif
6480
6481 #ifdef DEBUG
6482       write(iout,*) "------- SC restrs end -------"
6483         write (iout,*) "------ After SC loop in e_modeller ------"
6484         do i=loc_start,loc_end
6485          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
6486          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
6487         enddo
6488       if (waga_theta.eq.1.0d0) then
6489       write (iout,*) "in e_modeller after SC restr end: dutheta"
6490       do i=ithet_start,ithet_end
6491         write (iout,*) i,dutheta(i)
6492       enddo
6493       endif
6494       if (waga_d.eq.1.0d0) then
6495       write (iout,*) "e_modeller after SC loop: duscdiff/x"
6496       do i=1,nres
6497         write (iout,*) i,(duscdiff(j,i),j=1,3)
6498         write (iout,*) i,(duscdiffx(j,i),j=1,3)
6499       enddo
6500       endif
6501 #endif
6502
6503 c Total energy from homology restraints
6504 #ifdef DEBUG
6505       write (iout,*) "odleg",odleg," kat",kat
6506 #endif
6507 c
6508 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
6509 c
6510 c     ehomology_constr=odleg+kat
6511 c
6512 c     For Lorentzian-type Urestr
6513 c
6514
6515       if (waga_dist.ge.0.0d0) then
6516 c
6517 c          For Gaussian-type Urestr
6518 c
6519         ehomology_constr=(waga_dist*odleg+waga_angle*kat+
6520      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
6521 c     write (iout,*) "ehomology_constr=",ehomology_constr
6522       else
6523 c
6524 c          For Lorentzian-type Urestr
6525 c
6526         ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
6527      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
6528 c     write (iout,*) "ehomology_constr=",ehomology_constr
6529       endif
6530 #ifdef DEBUG
6531       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
6532      & "Eval",waga_theta,eval,
6533      &   "Erot",waga_d,Erot
6534       write (iout,*) "ehomology_constr",ehomology_constr
6535 #endif
6536       return
6537 c
6538 c FP 01/15 end
6539 c
6540   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
6541   747 format(a12,i4,i4,i4,f8.3,f8.3)
6542   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
6543   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
6544   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
6545      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
6546       end
6547
6548 c------------------------------------------------------------------------------
6549       subroutine etor_d(etors_d)
6550 C 6/23/01 Compute double torsional energy
6551       implicit real*8 (a-h,o-z)
6552       include 'DIMENSIONS'
6553       include 'COMMON.VAR'
6554       include 'COMMON.GEO'
6555       include 'COMMON.LOCAL'
6556       include 'COMMON.TORSION'
6557       include 'COMMON.INTERACT'
6558       include 'COMMON.DERIV'
6559       include 'COMMON.CHAIN'
6560       include 'COMMON.NAMES'
6561       include 'COMMON.IOUNITS'
6562       include 'COMMON.FFIELD'
6563       include 'COMMON.TORCNSTR'
6564       logical lprn
6565 C Set lprn=.true. for debugging
6566       lprn=.false.
6567 c     lprn=.true.
6568       etors_d=0.0D0
6569       do i=iphid_start,iphid_end
6570         itori=itortyp(itype(i-2))
6571         itori1=itortyp(itype(i-1))
6572         itori2=itortyp(itype(i))
6573         phii=phi(i)
6574         phii1=phi(i+1)
6575         gloci1=0.0D0
6576         gloci2=0.0D0
6577         do j=1,ntermd_1(itori,itori1,itori2)
6578           v1cij=v1c(1,j,itori,itori1,itori2)
6579           v1sij=v1s(1,j,itori,itori1,itori2)
6580           v2cij=v1c(2,j,itori,itori1,itori2)
6581           v2sij=v1s(2,j,itori,itori1,itori2)
6582           cosphi1=dcos(j*phii)
6583           sinphi1=dsin(j*phii)
6584           cosphi2=dcos(j*phii1)
6585           sinphi2=dsin(j*phii1)
6586           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
6587      &     v2cij*cosphi2+v2sij*sinphi2
6588           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6589           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6590         enddo
6591         do k=2,ntermd_2(itori,itori1,itori2)
6592           do l=1,k-1
6593             v1cdij = v2c(k,l,itori,itori1,itori2)
6594             v2cdij = v2c(l,k,itori,itori1,itori2)
6595             v1sdij = v2s(k,l,itori,itori1,itori2)
6596             v2sdij = v2s(l,k,itori,itori1,itori2)
6597             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6598             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6599             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6600             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6601             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6602      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6603             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
6604      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6605             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
6606      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6607           enddo
6608         enddo
6609         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
6610         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
6611 c        write (iout,*) "gloci", gloc(i-3,icg)
6612       enddo
6613       return
6614       end
6615 #endif
6616 c------------------------------------------------------------------------------
6617       subroutine eback_sc_corr(esccor)
6618 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6619 c        conformational states; temporarily implemented as differences
6620 c        between UNRES torsional potentials (dependent on three types of
6621 c        residues) and the torsional potentials dependent on all 20 types
6622 c        of residues computed from AM1  energy surfaces of terminally-blocked
6623 c        amino-acid residues.
6624       implicit real*8 (a-h,o-z)
6625       include 'DIMENSIONS'
6626       include 'COMMON.VAR'
6627       include 'COMMON.GEO'
6628       include 'COMMON.LOCAL'
6629       include 'COMMON.TORSION'
6630       include 'COMMON.SCCOR'
6631       include 'COMMON.INTERACT'
6632       include 'COMMON.DERIV'
6633       include 'COMMON.CHAIN'
6634       include 'COMMON.NAMES'
6635       include 'COMMON.IOUNITS'
6636       include 'COMMON.FFIELD'
6637       include 'COMMON.CONTROL'
6638       logical lprn
6639 C Set lprn=.true. for debugging
6640       lprn=.false.
6641 c      lprn=.true.
6642 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
6643       esccor=0.0D0
6644       do i=itau_start,itau_end
6645         esccor_ii=0.0D0
6646         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6647         isccori=isccortyp(itype(i-2))
6648         isccori1=isccortyp(itype(i-1))
6649         phii=phi(i)
6650 cccc  Added 9 May 2012
6651 cc Tauangle is torsional engle depending on the value of first digit
6652 c(see comment below)
6653 cc Omicron is flat angle depending on the value of first digit
6654 c(see comment below)
6655
6656
6657         do intertyp=1,3 !intertyp
6658 cc Added 09 May 2012 (Adasko)
6659 cc  Intertyp means interaction type of backbone mainchain correlation:
6660 c   1 = SC...Ca...Ca...Ca
6661 c   2 = Ca...Ca...Ca...SC
6662 c   3 = SC...Ca...Ca...SCi
6663         gloci=0.0D0
6664         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6665      &      (itype(i-1).eq.10).or.(itype(i-2).eq.21).or.
6666      &      (itype(i-1).eq.21)))
6667      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6668      &     .or.(itype(i-2).eq.21)))
6669      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6670      &      (itype(i-1).eq.21)))) cycle
6671         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle
6672         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21))
6673      & cycle
6674         do j=1,nterm_sccor(isccori,isccori1)
6675           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6676           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6677           cosphi=dcos(j*tauangle(intertyp,i))
6678           sinphi=dsin(j*tauangle(intertyp,i))
6679           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6680           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6681         enddo
6682         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6683 c        write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
6684 c     &gloc_sc(intertyp,i-3,icg)
6685         if (lprn)
6686      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6687      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6688      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
6689      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
6690         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6691        enddo !intertyp
6692       enddo
6693 c        do i=1,nres
6694 c        write (iout,*) "W@T@F",  gloc_sc(1,i,icg),gloc(i,icg)
6695 c        enddo
6696       return
6697       end
6698 c----------------------------------------------------------------------------
6699       subroutine multibody(ecorr)
6700 C This subroutine calculates multi-body contributions to energy following
6701 C the idea of Skolnick et al. If side chains I and J make a contact and
6702 C at the same time side chains I+1 and J+1 make a contact, an extra
6703 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6704       implicit real*8 (a-h,o-z)
6705       include 'DIMENSIONS'
6706       include 'COMMON.IOUNITS'
6707       include 'COMMON.DERIV'
6708       include 'COMMON.INTERACT'
6709       include 'COMMON.CONTACTS'
6710       double precision gx(3),gx1(3)
6711       logical lprn
6712
6713 C Set lprn=.true. for debugging
6714       lprn=.false.
6715
6716       if (lprn) then
6717         write (iout,'(a)') 'Contact function values:'
6718         do i=nnt,nct-2
6719           write (iout,'(i2,20(1x,i2,f10.5))')
6720      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6721         enddo
6722       endif
6723       ecorr=0.0D0
6724       do i=nnt,nct
6725         do j=1,3
6726           gradcorr(j,i)=0.0D0
6727           gradxorr(j,i)=0.0D0
6728         enddo
6729       enddo
6730       do i=nnt,nct-2
6731
6732         DO ISHIFT = 3,4
6733
6734         i1=i+ishift
6735         num_conti=num_cont(i)
6736         num_conti1=num_cont(i1)
6737         do jj=1,num_conti
6738           j=jcont(jj,i)
6739           do kk=1,num_conti1
6740             j1=jcont(kk,i1)
6741             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6742 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6743 cd   &                   ' ishift=',ishift
6744 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6745 C The system gains extra energy.
6746               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6747             endif   ! j1==j+-ishift
6748           enddo     ! kk
6749         enddo       ! jj
6750
6751         ENDDO ! ISHIFT
6752
6753       enddo         ! i
6754       return
6755       end
6756 c------------------------------------------------------------------------------
6757       double precision function esccorr(i,j,k,l,jj,kk)
6758       implicit real*8 (a-h,o-z)
6759       include 'DIMENSIONS'
6760       include 'COMMON.IOUNITS'
6761       include 'COMMON.DERIV'
6762       include 'COMMON.INTERACT'
6763       include 'COMMON.CONTACTS'
6764       double precision gx(3),gx1(3)
6765       logical lprn
6766       lprn=.false.
6767       eij=facont(jj,i)
6768       ekl=facont(kk,k)
6769 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6770 C Calculate the multi-body contribution to energy.
6771 C Calculate multi-body contributions to the gradient.
6772 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6773 cd   & k,l,(gacont(m,kk,k),m=1,3)
6774       do m=1,3
6775         gx(m) =ekl*gacont(m,jj,i)
6776         gx1(m)=eij*gacont(m,kk,k)
6777         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6778         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6779         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6780         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6781       enddo
6782       do m=i,j-1
6783         do ll=1,3
6784           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6785         enddo
6786       enddo
6787       do m=k,l-1
6788         do ll=1,3
6789           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6790         enddo
6791       enddo
6792       esccorr=-eij*ekl
6793       return
6794       end
6795 c------------------------------------------------------------------------------
6796       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6797 C This subroutine calculates multi-body contributions to hydrogen-bonding
6798       implicit real*8 (a-h,o-z)
6799       include 'DIMENSIONS'
6800       include 'COMMON.IOUNITS'
6801 #ifdef MPI
6802       include "mpif.h"
6803       parameter (max_cont=maxconts)
6804       parameter (max_dim=26)
6805       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6806       double precision zapas(max_dim,maxconts,max_fg_procs),
6807      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6808       common /przechowalnia/ zapas
6809       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6810      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6811 #endif
6812       include 'COMMON.SETUP'
6813       include 'COMMON.FFIELD'
6814       include 'COMMON.DERIV'
6815       include 'COMMON.INTERACT'
6816       include 'COMMON.CONTACTS'
6817       include 'COMMON.CONTROL'
6818       include 'COMMON.LOCAL'
6819       double precision gx(3),gx1(3),time00
6820       logical lprn,ldone
6821
6822 C Set lprn=.true. for debugging
6823       lprn=.false.
6824 #ifdef MPI
6825       n_corr=0
6826       n_corr1=0
6827       if (nfgtasks.le.1) goto 30
6828       if (lprn) then
6829         write (iout,'(a)') 'Contact function values before RECEIVE:'
6830         do i=nnt,nct-2
6831           write (iout,'(2i3,50(1x,i2,f5.2))')
6832      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6833      &    j=1,num_cont_hb(i))
6834         enddo
6835       endif
6836       call flush(iout)
6837       do i=1,ntask_cont_from
6838         ncont_recv(i)=0
6839       enddo
6840       do i=1,ntask_cont_to
6841         ncont_sent(i)=0
6842       enddo
6843 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6844 c     & ntask_cont_to
6845 C Make the list of contacts to send to send to other procesors
6846 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6847 c      call flush(iout)
6848       do i=iturn3_start,iturn3_end
6849 c        write (iout,*) "make contact list turn3",i," num_cont",
6850 c     &    num_cont_hb(i)
6851         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6852       enddo
6853       do i=iturn4_start,iturn4_end
6854 c        write (iout,*) "make contact list turn4",i," num_cont",
6855 c     &   num_cont_hb(i)
6856         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6857       enddo
6858       do ii=1,nat_sent
6859         i=iat_sent(ii)
6860 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6861 c     &    num_cont_hb(i)
6862         do j=1,num_cont_hb(i)
6863         do k=1,4
6864           jjc=jcont_hb(j,i)
6865           iproc=iint_sent_local(k,jjc,ii)
6866 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6867           if (iproc.gt.0) then
6868             ncont_sent(iproc)=ncont_sent(iproc)+1
6869             nn=ncont_sent(iproc)
6870             zapas(1,nn,iproc)=i
6871             zapas(2,nn,iproc)=jjc
6872             zapas(3,nn,iproc)=facont_hb(j,i)
6873             zapas(4,nn,iproc)=ees0p(j,i)
6874             zapas(5,nn,iproc)=ees0m(j,i)
6875             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6876             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6877             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6878             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6879             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6880             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6881             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6882             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6883             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6884             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6885             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6886             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6887             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6888             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6889             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6890             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6891             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6892             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6893             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6894             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6895             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6896           endif
6897         enddo
6898         enddo
6899       enddo
6900       if (lprn) then
6901       write (iout,*)
6902      &  "Numbers of contacts to be sent to other processors",
6903      &  (ncont_sent(i),i=1,ntask_cont_to)
6904       write (iout,*) "Contacts sent"
6905       do ii=1,ntask_cont_to
6906         nn=ncont_sent(ii)
6907         iproc=itask_cont_to(ii)
6908         write (iout,*) nn," contacts to processor",iproc,
6909      &   " of CONT_TO_COMM group"
6910         do i=1,nn
6911           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6912         enddo
6913       enddo
6914       call flush(iout)
6915       endif
6916       CorrelType=477
6917       CorrelID=fg_rank+1
6918       CorrelType1=478
6919       CorrelID1=nfgtasks+fg_rank+1
6920       ireq=0
6921 C Receive the numbers of needed contacts from other processors
6922       do ii=1,ntask_cont_from
6923         iproc=itask_cont_from(ii)
6924         ireq=ireq+1
6925         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6926      &    FG_COMM,req(ireq),IERR)
6927       enddo
6928 c      write (iout,*) "IRECV ended"
6929 c      call flush(iout)
6930 C Send the number of contacts needed by other processors
6931       do ii=1,ntask_cont_to
6932         iproc=itask_cont_to(ii)
6933         ireq=ireq+1
6934         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6935      &    FG_COMM,req(ireq),IERR)
6936       enddo
6937 c      write (iout,*) "ISEND ended"
6938 c      write (iout,*) "number of requests (nn)",ireq
6939       call flush(iout)
6940       if (ireq.gt.0)
6941      &  call MPI_Waitall(ireq,req,status_array,ierr)
6942 c      write (iout,*)
6943 c     &  "Numbers of contacts to be received from other processors",
6944 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6945 c      call flush(iout)
6946 C Receive contacts
6947       ireq=0
6948       do ii=1,ntask_cont_from
6949         iproc=itask_cont_from(ii)
6950         nn=ncont_recv(ii)
6951 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6952 c     &   " of CONT_TO_COMM group"
6953         call flush(iout)
6954         if (nn.gt.0) then
6955           ireq=ireq+1
6956           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6957      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6958 c          write (iout,*) "ireq,req",ireq,req(ireq)
6959         endif
6960       enddo
6961 C Send the contacts to processors that need them
6962       do ii=1,ntask_cont_to
6963         iproc=itask_cont_to(ii)
6964         nn=ncont_sent(ii)
6965 c        write (iout,*) nn," contacts to processor",iproc,
6966 c     &   " of CONT_TO_COMM group"
6967         if (nn.gt.0) then
6968           ireq=ireq+1
6969           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6970      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6971 c          write (iout,*) "ireq,req",ireq,req(ireq)
6972 c          do i=1,nn
6973 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6974 c          enddo
6975         endif
6976       enddo
6977 c      write (iout,*) "number of requests (contacts)",ireq
6978 c      write (iout,*) "req",(req(i),i=1,4)
6979 c      call flush(iout)
6980       if (ireq.gt.0)
6981      & call MPI_Waitall(ireq,req,status_array,ierr)
6982       do iii=1,ntask_cont_from
6983         iproc=itask_cont_from(iii)
6984         nn=ncont_recv(iii)
6985         if (lprn) then
6986         write (iout,*) "Received",nn," contacts from processor",iproc,
6987      &   " of CONT_FROM_COMM group"
6988         call flush(iout)
6989         do i=1,nn
6990           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6991         enddo
6992         call flush(iout)
6993         endif
6994         do i=1,nn
6995           ii=zapas_recv(1,i,iii)
6996 c Flag the received contacts to prevent double-counting
6997           jj=-zapas_recv(2,i,iii)
6998 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6999 c          call flush(iout)
7000           nnn=num_cont_hb(ii)+1
7001           num_cont_hb(ii)=nnn
7002           jcont_hb(nnn,ii)=jj
7003           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
7004           ees0p(nnn,ii)=zapas_recv(4,i,iii)
7005           ees0m(nnn,ii)=zapas_recv(5,i,iii)
7006           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
7007           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
7008           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
7009           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
7010           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
7011           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
7012           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
7013           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
7014           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
7015           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
7016           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
7017           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
7018           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
7019           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
7020           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
7021           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
7022           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
7023           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
7024           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
7025           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
7026           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
7027         enddo
7028       enddo
7029       call flush(iout)
7030       if (lprn) then
7031         write (iout,'(a)') 'Contact function values after receive:'
7032         do i=nnt,nct-2
7033           write (iout,'(2i3,50(1x,i3,f5.2))')
7034      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7035      &    j=1,num_cont_hb(i))
7036         enddo
7037         call flush(iout)
7038       endif
7039    30 continue
7040 #endif
7041       if (lprn) then
7042         write (iout,'(a)') 'Contact function values:'
7043         do i=nnt,nct-2
7044           write (iout,'(2i3,50(1x,i3,f5.2))')
7045      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7046      &    j=1,num_cont_hb(i))
7047         enddo
7048       endif
7049       ecorr=0.0D0
7050 C Remove the loop below after debugging !!!
7051       do i=nnt,nct
7052         do j=1,3
7053           gradcorr(j,i)=0.0D0
7054           gradxorr(j,i)=0.0D0
7055         enddo
7056       enddo
7057 C Calculate the local-electrostatic correlation terms
7058       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
7059         i1=i+1
7060         num_conti=num_cont_hb(i)
7061         num_conti1=num_cont_hb(i+1)
7062         do jj=1,num_conti
7063           j=jcont_hb(jj,i)
7064           jp=iabs(j)
7065           do kk=1,num_conti1
7066             j1=jcont_hb(kk,i1)
7067             jp1=iabs(j1)
7068 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7069 c     &         ' jj=',jj,' kk=',kk
7070             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7071      &          .or. j.lt.0 .and. j1.gt.0) .and.
7072      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7073 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7074 C The system gains extra energy.
7075               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7076               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
7077      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
7078               n_corr=n_corr+1
7079             else if (j1.eq.j) then
7080 C Contacts I-J and I-(J+1) occur simultaneously.
7081 C The system loses extra energy.
7082 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7083             endif
7084           enddo ! kk
7085           do kk=1,num_conti
7086             j1=jcont_hb(kk,i)
7087 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7088 c    &         ' jj=',jj,' kk=',kk
7089             if (j1.eq.j+1) then
7090 C Contacts I-J and (I+1)-J occur simultaneously.
7091 C The system loses extra energy.
7092 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7093             endif ! j1==j+1
7094           enddo ! kk
7095         enddo ! jj
7096       enddo ! i
7097       return
7098       end
7099 c------------------------------------------------------------------------------
7100       subroutine add_hb_contact(ii,jj,itask)
7101       implicit real*8 (a-h,o-z)
7102       include "DIMENSIONS"
7103       include "COMMON.IOUNITS"
7104       integer max_cont
7105       integer max_dim
7106       parameter (max_cont=maxconts)
7107       parameter (max_dim=26)
7108       include "COMMON.CONTACTS"
7109       double precision zapas(max_dim,maxconts,max_fg_procs),
7110      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7111       common /przechowalnia/ zapas
7112       integer i,j,ii,jj,iproc,itask(4),nn
7113 c      write (iout,*) "itask",itask
7114       do i=1,2
7115         iproc=itask(i)
7116         if (iproc.gt.0) then
7117           do j=1,num_cont_hb(ii)
7118             jjc=jcont_hb(j,ii)
7119 c            write (iout,*) "i",ii," j",jj," jjc",jjc
7120             if (jjc.eq.jj) then
7121               ncont_sent(iproc)=ncont_sent(iproc)+1
7122               nn=ncont_sent(iproc)
7123               zapas(1,nn,iproc)=ii
7124               zapas(2,nn,iproc)=jjc
7125               zapas(3,nn,iproc)=facont_hb(j,ii)
7126               zapas(4,nn,iproc)=ees0p(j,ii)
7127               zapas(5,nn,iproc)=ees0m(j,ii)
7128               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
7129               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
7130               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
7131               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
7132               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
7133               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
7134               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
7135               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
7136               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
7137               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
7138               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
7139               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
7140               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
7141               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
7142               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
7143               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
7144               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
7145               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
7146               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
7147               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
7148               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
7149               exit
7150             endif
7151           enddo
7152         endif
7153       enddo
7154       return
7155       end
7156 c------------------------------------------------------------------------------
7157       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
7158      &  n_corr1)
7159 C This subroutine calculates multi-body contributions to hydrogen-bonding
7160       implicit real*8 (a-h,o-z)
7161       include 'DIMENSIONS'
7162       include 'COMMON.IOUNITS'
7163 #ifdef MPI
7164       include "mpif.h"
7165       parameter (max_cont=maxconts)
7166       parameter (max_dim=70)
7167       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7168       double precision zapas(max_dim,maxconts,max_fg_procs),
7169      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7170       common /przechowalnia/ zapas
7171       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7172      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7173 #endif
7174       include 'COMMON.SETUP'
7175       include 'COMMON.FFIELD'
7176       include 'COMMON.DERIV'
7177       include 'COMMON.LOCAL'
7178       include 'COMMON.INTERACT'
7179       include 'COMMON.CONTACTS'
7180       include 'COMMON.CHAIN'
7181       include 'COMMON.CONTROL'
7182       double precision gx(3),gx1(3)
7183       integer num_cont_hb_old(maxres)
7184       logical lprn,ldone
7185       double precision eello4,eello5,eelo6,eello_turn6
7186       external eello4,eello5,eello6,eello_turn6
7187 C Set lprn=.true. for debugging
7188       lprn=.false.
7189       eturn6=0.0d0
7190 #ifdef MPI
7191       do i=1,nres
7192         num_cont_hb_old(i)=num_cont_hb(i)
7193       enddo
7194       n_corr=0
7195       n_corr1=0
7196       if (nfgtasks.le.1) goto 30
7197       if (lprn) then
7198         write (iout,'(a)') 'Contact function values before RECEIVE:'
7199         do i=nnt,nct-2
7200           write (iout,'(2i3,50(1x,i2,f5.2))')
7201      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7202      &    j=1,num_cont_hb(i))
7203         enddo
7204       endif
7205       call flush(iout)
7206       do i=1,ntask_cont_from
7207         ncont_recv(i)=0
7208       enddo
7209       do i=1,ntask_cont_to
7210         ncont_sent(i)=0
7211       enddo
7212 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7213 c     & ntask_cont_to
7214 C Make the list of contacts to send to send to other procesors
7215       do i=iturn3_start,iturn3_end
7216 c        write (iout,*) "make contact list turn3",i," num_cont",
7217 c     &    num_cont_hb(i)
7218         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
7219       enddo
7220       do i=iturn4_start,iturn4_end
7221 c        write (iout,*) "make contact list turn4",i," num_cont",
7222 c     &   num_cont_hb(i)
7223         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
7224       enddo
7225       do ii=1,nat_sent
7226         i=iat_sent(ii)
7227 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7228 c     &    num_cont_hb(i)
7229         do j=1,num_cont_hb(i)
7230         do k=1,4
7231           jjc=jcont_hb(j,i)
7232           iproc=iint_sent_local(k,jjc,ii)
7233 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7234           if (iproc.ne.0) then
7235             ncont_sent(iproc)=ncont_sent(iproc)+1
7236             nn=ncont_sent(iproc)
7237             zapas(1,nn,iproc)=i
7238             zapas(2,nn,iproc)=jjc
7239             zapas(3,nn,iproc)=d_cont(j,i)
7240             ind=3
7241             do kk=1,3
7242               ind=ind+1
7243               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
7244             enddo
7245             do kk=1,2
7246               do ll=1,2
7247                 ind=ind+1
7248                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
7249               enddo
7250             enddo
7251             do jj=1,5
7252               do kk=1,3
7253                 do ll=1,2
7254                   do mm=1,2
7255                     ind=ind+1
7256                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
7257                   enddo
7258                 enddo
7259               enddo
7260             enddo
7261           endif
7262         enddo
7263         enddo
7264       enddo
7265       if (lprn) then
7266       write (iout,*)
7267      &  "Numbers of contacts to be sent to other processors",
7268      &  (ncont_sent(i),i=1,ntask_cont_to)
7269       write (iout,*) "Contacts sent"
7270       do ii=1,ntask_cont_to
7271         nn=ncont_sent(ii)
7272         iproc=itask_cont_to(ii)
7273         write (iout,*) nn," contacts to processor",iproc,
7274      &   " of CONT_TO_COMM group"
7275         do i=1,nn
7276           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
7277         enddo
7278       enddo
7279       call flush(iout)
7280       endif
7281       CorrelType=477
7282       CorrelID=fg_rank+1
7283       CorrelType1=478
7284       CorrelID1=nfgtasks+fg_rank+1
7285       ireq=0
7286 C Receive the numbers of needed contacts from other processors
7287       do ii=1,ntask_cont_from
7288         iproc=itask_cont_from(ii)
7289         ireq=ireq+1
7290         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7291      &    FG_COMM,req(ireq),IERR)
7292       enddo
7293 c      write (iout,*) "IRECV ended"
7294 c      call flush(iout)
7295 C Send the number of contacts needed by other processors
7296       do ii=1,ntask_cont_to
7297         iproc=itask_cont_to(ii)
7298         ireq=ireq+1
7299         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7300      &    FG_COMM,req(ireq),IERR)
7301       enddo
7302 c      write (iout,*) "ISEND ended"
7303 c      write (iout,*) "number of requests (nn)",ireq
7304       call flush(iout)
7305       if (ireq.gt.0)
7306      &  call MPI_Waitall(ireq,req,status_array,ierr)
7307 c      write (iout,*)
7308 c     &  "Numbers of contacts to be received from other processors",
7309 c     &  (ncont_recv(i),i=1,ntask_cont_from)
7310 c      call flush(iout)
7311 C Receive contacts
7312       ireq=0
7313       do ii=1,ntask_cont_from
7314         iproc=itask_cont_from(ii)
7315         nn=ncont_recv(ii)
7316 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7317 c     &   " of CONT_TO_COMM group"
7318         call flush(iout)
7319         if (nn.gt.0) then
7320           ireq=ireq+1
7321           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
7322      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7323 c          write (iout,*) "ireq,req",ireq,req(ireq)
7324         endif
7325       enddo
7326 C Send the contacts to processors that need them
7327       do ii=1,ntask_cont_to
7328         iproc=itask_cont_to(ii)
7329         nn=ncont_sent(ii)
7330 c        write (iout,*) nn," contacts to processor",iproc,
7331 c     &   " of CONT_TO_COMM group"
7332         if (nn.gt.0) then
7333           ireq=ireq+1
7334           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
7335      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7336 c          write (iout,*) "ireq,req",ireq,req(ireq)
7337 c          do i=1,nn
7338 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7339 c          enddo
7340         endif
7341       enddo
7342 c      write (iout,*) "number of requests (contacts)",ireq
7343 c      write (iout,*) "req",(req(i),i=1,4)
7344 c      call flush(iout)
7345       if (ireq.gt.0)
7346      & call MPI_Waitall(ireq,req,status_array,ierr)
7347       do iii=1,ntask_cont_from
7348         iproc=itask_cont_from(iii)
7349         nn=ncont_recv(iii)
7350         if (lprn) then
7351         write (iout,*) "Received",nn," contacts from processor",iproc,
7352      &   " of CONT_FROM_COMM group"
7353         call flush(iout)
7354         do i=1,nn
7355           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
7356         enddo
7357         call flush(iout)
7358         endif
7359         do i=1,nn
7360           ii=zapas_recv(1,i,iii)
7361 c Flag the received contacts to prevent double-counting
7362           jj=-zapas_recv(2,i,iii)
7363 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7364 c          call flush(iout)
7365           nnn=num_cont_hb(ii)+1
7366           num_cont_hb(ii)=nnn
7367           jcont_hb(nnn,ii)=jj
7368           d_cont(nnn,ii)=zapas_recv(3,i,iii)
7369           ind=3
7370           do kk=1,3
7371             ind=ind+1
7372             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
7373           enddo
7374           do kk=1,2
7375             do ll=1,2
7376               ind=ind+1
7377               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
7378             enddo
7379           enddo
7380           do jj=1,5
7381             do kk=1,3
7382               do ll=1,2
7383                 do mm=1,2
7384                   ind=ind+1
7385                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
7386                 enddo
7387               enddo
7388             enddo
7389           enddo
7390         enddo
7391       enddo
7392       call flush(iout)
7393       if (lprn) then
7394         write (iout,'(a)') 'Contact function values after receive:'
7395         do i=nnt,nct-2
7396           write (iout,'(2i3,50(1x,i3,5f6.3))')
7397      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7398      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7399         enddo
7400         call flush(iout)
7401       endif
7402    30 continue
7403 #endif
7404       if (lprn) then
7405         write (iout,'(a)') 'Contact function values:'
7406         do i=nnt,nct-2
7407           write (iout,'(2i3,50(1x,i2,5f6.3))')
7408      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7409      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7410         enddo
7411       endif
7412       ecorr=0.0D0
7413       ecorr5=0.0d0
7414       ecorr6=0.0d0
7415 C Remove the loop below after debugging !!!
7416       do i=nnt,nct
7417         do j=1,3
7418           gradcorr(j,i)=0.0D0
7419           gradxorr(j,i)=0.0D0
7420         enddo
7421       enddo
7422 C Calculate the dipole-dipole interaction energies
7423       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7424       do i=iatel_s,iatel_e+1
7425         num_conti=num_cont_hb(i)
7426         do jj=1,num_conti
7427           j=jcont_hb(jj,i)
7428 #ifdef MOMENT
7429           call dipole(i,j,jj)
7430 #endif
7431         enddo
7432       enddo
7433       endif
7434 C Calculate the local-electrostatic correlation terms
7435 c                write (iout,*) "gradcorr5 in eello5 before loop"
7436 c                do iii=1,nres
7437 c                  write (iout,'(i5,3f10.5)')
7438 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7439 c                enddo
7440       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7441 c        write (iout,*) "corr loop i",i
7442         i1=i+1
7443         num_conti=num_cont_hb(i)
7444         num_conti1=num_cont_hb(i+1)
7445         do jj=1,num_conti
7446           j=jcont_hb(jj,i)
7447           jp=iabs(j)
7448           do kk=1,num_conti1
7449             j1=jcont_hb(kk,i1)
7450             jp1=iabs(j1)
7451 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7452 c     &         ' jj=',jj,' kk=',kk
7453 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
7454             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7455      &          .or. j.lt.0 .and. j1.gt.0) .and.
7456      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7457 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7458 C The system gains extra energy.
7459               n_corr=n_corr+1
7460               sqd1=dsqrt(d_cont(jj,i))
7461               sqd2=dsqrt(d_cont(kk,i1))
7462               sred_geom = sqd1*sqd2
7463               IF (sred_geom.lt.cutoff_corr) THEN
7464                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
7465      &            ekont,fprimcont)
7466 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7467 cd     &         ' jj=',jj,' kk=',kk
7468                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7469                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7470                 do l=1,3
7471                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7472                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7473                 enddo
7474                 n_corr1=n_corr1+1
7475 cd               write (iout,*) 'sred_geom=',sred_geom,
7476 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
7477 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7478 cd               write (iout,*) "g_contij",g_contij
7479 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7480 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7481                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7482                 if (wcorr4.gt.0.0d0)
7483      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7484                   if (energy_dec.and.wcorr4.gt.0.0d0)
7485      1                 write (iout,'(a6,4i5,0pf7.3)')
7486      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7487 c                write (iout,*) "gradcorr5 before eello5"
7488 c                do iii=1,nres
7489 c                  write (iout,'(i5,3f10.5)')
7490 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7491 c                enddo
7492                 if (wcorr5.gt.0.0d0)
7493      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7494 c                write (iout,*) "gradcorr5 after eello5"
7495 c                do iii=1,nres
7496 c                  write (iout,'(i5,3f10.5)')
7497 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7498 c                enddo
7499                   if (energy_dec.and.wcorr5.gt.0.0d0)
7500      1                 write (iout,'(a6,4i5,0pf7.3)')
7501      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7502 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7503 cd                write(2,*)'ijkl',i,jp,i+1,jp1
7504                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
7505      &               .or. wturn6.eq.0.0d0))then
7506 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7507                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7508                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7509      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7510 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7511 cd     &            'ecorr6=',ecorr6
7512 cd                write (iout,'(4e15.5)') sred_geom,
7513 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7514 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7515 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7516                 else if (wturn6.gt.0.0d0
7517      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7518 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7519                   eturn6=eturn6+eello_turn6(i,jj,kk)
7520                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7521      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7522 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
7523                 endif
7524               ENDIF
7525 1111          continue
7526             endif
7527           enddo ! kk
7528         enddo ! jj
7529       enddo ! i
7530       do i=1,nres
7531         num_cont_hb(i)=num_cont_hb_old(i)
7532       enddo
7533 c                write (iout,*) "gradcorr5 in eello5"
7534 c                do iii=1,nres
7535 c                  write (iout,'(i5,3f10.5)')
7536 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7537 c                enddo
7538       return
7539       end
7540 c------------------------------------------------------------------------------
7541       subroutine add_hb_contact_eello(ii,jj,itask)
7542       implicit real*8 (a-h,o-z)
7543       include "DIMENSIONS"
7544       include "COMMON.IOUNITS"
7545       integer max_cont
7546       integer max_dim
7547       parameter (max_cont=maxconts)
7548       parameter (max_dim=70)
7549       include "COMMON.CONTACTS"
7550       double precision zapas(max_dim,maxconts,max_fg_procs),
7551      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7552       common /przechowalnia/ zapas
7553       integer i,j,ii,jj,iproc,itask(4),nn
7554 c      write (iout,*) "itask",itask
7555       do i=1,2
7556         iproc=itask(i)
7557         if (iproc.gt.0) then
7558           do j=1,num_cont_hb(ii)
7559             jjc=jcont_hb(j,ii)
7560 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
7561             if (jjc.eq.jj) then
7562               ncont_sent(iproc)=ncont_sent(iproc)+1
7563               nn=ncont_sent(iproc)
7564               zapas(1,nn,iproc)=ii
7565               zapas(2,nn,iproc)=jjc
7566               zapas(3,nn,iproc)=d_cont(j,ii)
7567               ind=3
7568               do kk=1,3
7569                 ind=ind+1
7570                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
7571               enddo
7572               do kk=1,2
7573                 do ll=1,2
7574                   ind=ind+1
7575                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
7576                 enddo
7577               enddo
7578               do jj=1,5
7579                 do kk=1,3
7580                   do ll=1,2
7581                     do mm=1,2
7582                       ind=ind+1
7583                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
7584                     enddo
7585                   enddo
7586                 enddo
7587               enddo
7588               exit
7589             endif
7590           enddo
7591         endif
7592       enddo
7593       return
7594       end
7595 c------------------------------------------------------------------------------
7596       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7597       implicit real*8 (a-h,o-z)
7598       include 'DIMENSIONS'
7599       include 'COMMON.IOUNITS'
7600       include 'COMMON.DERIV'
7601       include 'COMMON.INTERACT'
7602       include 'COMMON.CONTACTS'
7603       double precision gx(3),gx1(3)
7604       logical lprn
7605       lprn=.false.
7606       eij=facont_hb(jj,i)
7607       ekl=facont_hb(kk,k)
7608       ees0pij=ees0p(jj,i)
7609       ees0pkl=ees0p(kk,k)
7610       ees0mij=ees0m(jj,i)
7611       ees0mkl=ees0m(kk,k)
7612       ekont=eij*ekl
7613       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7614 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7615 C Following 4 lines for diagnostics.
7616 cd    ees0pkl=0.0D0
7617 cd    ees0pij=1.0D0
7618 cd    ees0mkl=0.0D0
7619 cd    ees0mij=1.0D0
7620 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7621 c     & 'Contacts ',i,j,
7622 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7623 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7624 c     & 'gradcorr_long'
7625 C Calculate the multi-body contribution to energy.
7626 c      ecorr=ecorr+ekont*ees
7627 C Calculate multi-body contributions to the gradient.
7628       coeffpees0pij=coeffp*ees0pij
7629       coeffmees0mij=coeffm*ees0mij
7630       coeffpees0pkl=coeffp*ees0pkl
7631       coeffmees0mkl=coeffm*ees0mkl
7632       do ll=1,3
7633 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7634         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
7635      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
7636      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
7637         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
7638      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
7639      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
7640 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7641         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
7642      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
7643      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
7644         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
7645      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
7646      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
7647         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
7648      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
7649      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
7650         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7651         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7652         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
7653      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
7654      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
7655         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7656         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7657 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7658       enddo
7659 c      write (iout,*)
7660 cgrad      do m=i+1,j-1
7661 cgrad        do ll=1,3
7662 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7663 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7664 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7665 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7666 cgrad        enddo
7667 cgrad      enddo
7668 cgrad      do m=k+1,l-1
7669 cgrad        do ll=1,3
7670 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7671 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7672 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7673 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7674 cgrad        enddo
7675 cgrad      enddo
7676 c      write (iout,*) "ehbcorr",ekont*ees
7677       ehbcorr=ekont*ees
7678       return
7679       end
7680 #ifdef MOMENT
7681 C---------------------------------------------------------------------------
7682       subroutine dipole(i,j,jj)
7683       implicit real*8 (a-h,o-z)
7684       include 'DIMENSIONS'
7685       include 'COMMON.IOUNITS'
7686       include 'COMMON.CHAIN'
7687       include 'COMMON.FFIELD'
7688       include 'COMMON.DERIV'
7689       include 'COMMON.INTERACT'
7690       include 'COMMON.CONTACTS'
7691       include 'COMMON.TORSION'
7692       include 'COMMON.VAR'
7693       include 'COMMON.GEO'
7694       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7695      &  auxmat(2,2)
7696       iti1 = itortyp(itype(i+1))
7697       if (j.lt.nres-1) then
7698         itj1 = itortyp(itype(j+1))
7699       else
7700         itj1=ntortyp+1
7701       endif
7702       do iii=1,2
7703         dipi(iii,1)=Ub2(iii,i)
7704         dipderi(iii)=Ub2der(iii,i)
7705         dipi(iii,2)=b1(iii,iti1)
7706         dipj(iii,1)=Ub2(iii,j)
7707         dipderj(iii)=Ub2der(iii,j)
7708         dipj(iii,2)=b1(iii,itj1)
7709       enddo
7710       kkk=0
7711       do iii=1,2
7712         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7713         do jjj=1,2
7714           kkk=kkk+1
7715           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7716         enddo
7717       enddo
7718       do kkk=1,5
7719         do lll=1,3
7720           mmm=0
7721           do iii=1,2
7722             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7723      &        auxvec(1))
7724             do jjj=1,2
7725               mmm=mmm+1
7726               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7727             enddo
7728           enddo
7729         enddo
7730       enddo
7731       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7732       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7733       do iii=1,2
7734         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7735       enddo
7736       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7737       do iii=1,2
7738         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7739       enddo
7740       return
7741       end
7742 #endif
7743 C---------------------------------------------------------------------------
7744       subroutine calc_eello(i,j,k,l,jj,kk)
7745 C
7746 C This subroutine computes matrices and vectors needed to calculate
7747 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7748 C
7749       implicit real*8 (a-h,o-z)
7750       include 'DIMENSIONS'
7751       include 'COMMON.IOUNITS'
7752       include 'COMMON.CHAIN'
7753       include 'COMMON.DERIV'
7754       include 'COMMON.INTERACT'
7755       include 'COMMON.CONTACTS'
7756       include 'COMMON.TORSION'
7757       include 'COMMON.VAR'
7758       include 'COMMON.GEO'
7759       include 'COMMON.FFIELD'
7760       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7761      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7762       logical lprn
7763       common /kutas/ lprn
7764 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7765 cd     & ' jj=',jj,' kk=',kk
7766 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7767 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7768 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7769       do iii=1,2
7770         do jjj=1,2
7771           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7772           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7773         enddo
7774       enddo
7775       call transpose2(aa1(1,1),aa1t(1,1))
7776       call transpose2(aa2(1,1),aa2t(1,1))
7777       do kkk=1,5
7778         do lll=1,3
7779           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7780      &      aa1tder(1,1,lll,kkk))
7781           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7782      &      aa2tder(1,1,lll,kkk))
7783         enddo
7784       enddo
7785       if (l.eq.j+1) then
7786 C parallel orientation of the two CA-CA-CA frames.
7787         if (i.gt.1) then
7788           iti=itortyp(itype(i))
7789         else
7790           iti=ntortyp+1
7791         endif
7792         itk1=itortyp(itype(k+1))
7793         itj=itortyp(itype(j))
7794         if (l.lt.nres-1) then
7795           itl1=itortyp(itype(l+1))
7796         else
7797           itl1=ntortyp+1
7798         endif
7799 C A1 kernel(j+1) A2T
7800 cd        do iii=1,2
7801 cd          write (iout,'(3f10.5,5x,3f10.5)')
7802 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7803 cd        enddo
7804         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7805      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7806      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7807 C Following matrices are needed only for 6-th order cumulants
7808         IF (wcorr6.gt.0.0d0) THEN
7809         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7810      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7811      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7812         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7813      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7814      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7815      &   ADtEAderx(1,1,1,1,1,1))
7816         lprn=.false.
7817         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7818      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7819      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7820      &   ADtEA1derx(1,1,1,1,1,1))
7821         ENDIF
7822 C End 6-th order cumulants
7823 cd        lprn=.false.
7824 cd        if (lprn) then
7825 cd        write (2,*) 'In calc_eello6'
7826 cd        do iii=1,2
7827 cd          write (2,*) 'iii=',iii
7828 cd          do kkk=1,5
7829 cd            write (2,*) 'kkk=',kkk
7830 cd            do jjj=1,2
7831 cd              write (2,'(3(2f10.5),5x)')
7832 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7833 cd            enddo
7834 cd          enddo
7835 cd        enddo
7836 cd        endif
7837         call transpose2(EUgder(1,1,k),auxmat(1,1))
7838         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7839         call transpose2(EUg(1,1,k),auxmat(1,1))
7840         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7841         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7842         do iii=1,2
7843           do kkk=1,5
7844             do lll=1,3
7845               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7846      &          EAEAderx(1,1,lll,kkk,iii,1))
7847             enddo
7848           enddo
7849         enddo
7850 C A1T kernel(i+1) A2
7851         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7852      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7853      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7854 C Following matrices are needed only for 6-th order cumulants
7855         IF (wcorr6.gt.0.0d0) THEN
7856         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7857      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7858      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7859         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7860      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7861      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7862      &   ADtEAderx(1,1,1,1,1,2))
7863         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7864      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7865      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7866      &   ADtEA1derx(1,1,1,1,1,2))
7867         ENDIF
7868 C End 6-th order cumulants
7869         call transpose2(EUgder(1,1,l),auxmat(1,1))
7870         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7871         call transpose2(EUg(1,1,l),auxmat(1,1))
7872         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7873         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7874         do iii=1,2
7875           do kkk=1,5
7876             do lll=1,3
7877               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7878      &          EAEAderx(1,1,lll,kkk,iii,2))
7879             enddo
7880           enddo
7881         enddo
7882 C AEAb1 and AEAb2
7883 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7884 C They are needed only when the fifth- or the sixth-order cumulants are
7885 C indluded.
7886         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7887         call transpose2(AEA(1,1,1),auxmat(1,1))
7888         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7889         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7890         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7891         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7892         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7893         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7894         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7895         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7896         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7897         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7898         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7899         call transpose2(AEA(1,1,2),auxmat(1,1))
7900         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7901         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7902         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7903         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7904         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7905         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7906         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7907         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7908         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7909         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7910         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7911 C Calculate the Cartesian derivatives of the vectors.
7912         do iii=1,2
7913           do kkk=1,5
7914             do lll=1,3
7915               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7916               call matvec2(auxmat(1,1),b1(1,iti),
7917      &          AEAb1derx(1,lll,kkk,iii,1,1))
7918               call matvec2(auxmat(1,1),Ub2(1,i),
7919      &          AEAb2derx(1,lll,kkk,iii,1,1))
7920               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7921      &          AEAb1derx(1,lll,kkk,iii,2,1))
7922               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7923      &          AEAb2derx(1,lll,kkk,iii,2,1))
7924               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7925               call matvec2(auxmat(1,1),b1(1,itj),
7926      &          AEAb1derx(1,lll,kkk,iii,1,2))
7927               call matvec2(auxmat(1,1),Ub2(1,j),
7928      &          AEAb2derx(1,lll,kkk,iii,1,2))
7929               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7930      &          AEAb1derx(1,lll,kkk,iii,2,2))
7931               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7932      &          AEAb2derx(1,lll,kkk,iii,2,2))
7933             enddo
7934           enddo
7935         enddo
7936         ENDIF
7937 C End vectors
7938       else
7939 C Antiparallel orientation of the two CA-CA-CA frames.
7940         if (i.gt.1) then
7941           iti=itortyp(itype(i))
7942         else
7943           iti=ntortyp+1
7944         endif
7945         itk1=itortyp(itype(k+1))
7946         itl=itortyp(itype(l))
7947         itj=itortyp(itype(j))
7948         if (j.lt.nres-1) then
7949           itj1=itortyp(itype(j+1))
7950         else
7951           itj1=ntortyp+1
7952         endif
7953 C A2 kernel(j-1)T A1T
7954         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7955      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7956      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7957 C Following matrices are needed only for 6-th order cumulants
7958         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7959      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7960         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7961      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7962      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7963         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7964      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7965      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7966      &   ADtEAderx(1,1,1,1,1,1))
7967         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7968      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7969      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7970      &   ADtEA1derx(1,1,1,1,1,1))
7971         ENDIF
7972 C End 6-th order cumulants
7973         call transpose2(EUgder(1,1,k),auxmat(1,1))
7974         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7975         call transpose2(EUg(1,1,k),auxmat(1,1))
7976         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7977         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7978         do iii=1,2
7979           do kkk=1,5
7980             do lll=1,3
7981               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7982      &          EAEAderx(1,1,lll,kkk,iii,1))
7983             enddo
7984           enddo
7985         enddo
7986 C A2T kernel(i+1)T A1
7987         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7988      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7989      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7990 C Following matrices are needed only for 6-th order cumulants
7991         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7992      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7993         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7994      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7995      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7996         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7997      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7998      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7999      &   ADtEAderx(1,1,1,1,1,2))
8000         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8001      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
8002      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8003      &   ADtEA1derx(1,1,1,1,1,2))
8004         ENDIF
8005 C End 6-th order cumulants
8006         call transpose2(EUgder(1,1,j),auxmat(1,1))
8007         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
8008         call transpose2(EUg(1,1,j),auxmat(1,1))
8009         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8010         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8011         do iii=1,2
8012           do kkk=1,5
8013             do lll=1,3
8014               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8015      &          EAEAderx(1,1,lll,kkk,iii,2))
8016             enddo
8017           enddo
8018         enddo
8019 C AEAb1 and AEAb2
8020 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8021 C They are needed only when the fifth- or the sixth-order cumulants are
8022 C indluded.
8023         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
8024      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
8025         call transpose2(AEA(1,1,1),auxmat(1,1))
8026         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
8027         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8028         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8029         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8030         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
8031         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8032         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
8033         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
8034         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8035         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8036         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8037         call transpose2(AEA(1,1,2),auxmat(1,1))
8038         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
8039         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
8040         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
8041         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8042         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
8043         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
8044         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
8045         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
8046         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
8047         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
8048         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
8049 C Calculate the Cartesian derivatives of the vectors.
8050         do iii=1,2
8051           do kkk=1,5
8052             do lll=1,3
8053               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8054               call matvec2(auxmat(1,1),b1(1,iti),
8055      &          AEAb1derx(1,lll,kkk,iii,1,1))
8056               call matvec2(auxmat(1,1),Ub2(1,i),
8057      &          AEAb2derx(1,lll,kkk,iii,1,1))
8058               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8059      &          AEAb1derx(1,lll,kkk,iii,2,1))
8060               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8061      &          AEAb2derx(1,lll,kkk,iii,2,1))
8062               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8063               call matvec2(auxmat(1,1),b1(1,itl),
8064      &          AEAb1derx(1,lll,kkk,iii,1,2))
8065               call matvec2(auxmat(1,1),Ub2(1,l),
8066      &          AEAb2derx(1,lll,kkk,iii,1,2))
8067               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
8068      &          AEAb1derx(1,lll,kkk,iii,2,2))
8069               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
8070      &          AEAb2derx(1,lll,kkk,iii,2,2))
8071             enddo
8072           enddo
8073         enddo
8074         ENDIF
8075 C End vectors
8076       endif
8077       return
8078       end
8079 C---------------------------------------------------------------------------
8080       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
8081      &  KK,KKderg,AKA,AKAderg,AKAderx)
8082       implicit none
8083       integer nderg
8084       logical transp
8085       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
8086      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
8087      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
8088       integer iii,kkk,lll
8089       integer jjj,mmm
8090       logical lprn
8091       common /kutas/ lprn
8092       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
8093       do iii=1,nderg
8094         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
8095      &    AKAderg(1,1,iii))
8096       enddo
8097 cd      if (lprn) write (2,*) 'In kernel'
8098       do kkk=1,5
8099 cd        if (lprn) write (2,*) 'kkk=',kkk
8100         do lll=1,3
8101           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
8102      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
8103 cd          if (lprn) then
8104 cd            write (2,*) 'lll=',lll
8105 cd            write (2,*) 'iii=1'
8106 cd            do jjj=1,2
8107 cd              write (2,'(3(2f10.5),5x)')
8108 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
8109 cd            enddo
8110 cd          endif
8111           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
8112      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
8113 cd          if (lprn) then
8114 cd            write (2,*) 'lll=',lll
8115 cd            write (2,*) 'iii=2'
8116 cd            do jjj=1,2
8117 cd              write (2,'(3(2f10.5),5x)')
8118 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
8119 cd            enddo
8120 cd          endif
8121         enddo
8122       enddo
8123       return
8124       end
8125 C---------------------------------------------------------------------------
8126       double precision function eello4(i,j,k,l,jj,kk)
8127       implicit real*8 (a-h,o-z)
8128       include 'DIMENSIONS'
8129       include 'COMMON.IOUNITS'
8130       include 'COMMON.CHAIN'
8131       include 'COMMON.DERIV'
8132       include 'COMMON.INTERACT'
8133       include 'COMMON.CONTACTS'
8134       include 'COMMON.TORSION'
8135       include 'COMMON.VAR'
8136       include 'COMMON.GEO'
8137       double precision pizda(2,2),ggg1(3),ggg2(3)
8138 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8139 cd        eello4=0.0d0
8140 cd        return
8141 cd      endif
8142 cd      print *,'eello4:',i,j,k,l,jj,kk
8143 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
8144 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
8145 cold      eij=facont_hb(jj,i)
8146 cold      ekl=facont_hb(kk,k)
8147 cold      ekont=eij*ekl
8148       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8149 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8150       gcorr_loc(k-1)=gcorr_loc(k-1)
8151      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8152       if (l.eq.j+1) then
8153         gcorr_loc(l-1)=gcorr_loc(l-1)
8154      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8155       else
8156         gcorr_loc(j-1)=gcorr_loc(j-1)
8157      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8158       endif
8159       do iii=1,2
8160         do kkk=1,5
8161           do lll=1,3
8162             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
8163      &                        -EAEAderx(2,2,lll,kkk,iii,1)
8164 cd            derx(lll,kkk,iii)=0.0d0
8165           enddo
8166         enddo
8167       enddo
8168 cd      gcorr_loc(l-1)=0.0d0
8169 cd      gcorr_loc(j-1)=0.0d0
8170 cd      gcorr_loc(k-1)=0.0d0
8171 cd      eel4=1.0d0
8172 cd      write (iout,*)'Contacts have occurred for peptide groups',
8173 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
8174 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8175       if (j.lt.nres-1) then
8176         j1=j+1
8177         j2=j-1
8178       else
8179         j1=j-1
8180         j2=j-2
8181       endif
8182       if (l.lt.nres-1) then
8183         l1=l+1
8184         l2=l-1
8185       else
8186         l1=l-1
8187         l2=l-2
8188       endif
8189       do ll=1,3
8190 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
8191 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
8192         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8193         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8194 cgrad        ghalf=0.5d0*ggg1(ll)
8195         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8196         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8197         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8198         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8199         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8200         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8201 cgrad        ghalf=0.5d0*ggg2(ll)
8202         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8203         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8204         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8205         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8206         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8207         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8208       enddo
8209 cgrad      do m=i+1,j-1
8210 cgrad        do ll=1,3
8211 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
8212 cgrad        enddo
8213 cgrad      enddo
8214 cgrad      do m=k+1,l-1
8215 cgrad        do ll=1,3
8216 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
8217 cgrad        enddo
8218 cgrad      enddo
8219 cgrad      do m=i+2,j2
8220 cgrad        do ll=1,3
8221 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8222 cgrad        enddo
8223 cgrad      enddo
8224 cgrad      do m=k+2,l2
8225 cgrad        do ll=1,3
8226 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8227 cgrad        enddo
8228 cgrad      enddo
8229 cd      do iii=1,nres-3
8230 cd        write (2,*) iii,gcorr_loc(iii)
8231 cd      enddo
8232       eello4=ekont*eel4
8233 cd      write (2,*) 'ekont',ekont
8234 cd      write (iout,*) 'eello4',ekont*eel4
8235       return
8236       end
8237 C---------------------------------------------------------------------------
8238       double precision function eello5(i,j,k,l,jj,kk)
8239       implicit real*8 (a-h,o-z)
8240       include 'DIMENSIONS'
8241       include 'COMMON.IOUNITS'
8242       include 'COMMON.CHAIN'
8243       include 'COMMON.DERIV'
8244       include 'COMMON.INTERACT'
8245       include 'COMMON.CONTACTS'
8246       include 'COMMON.TORSION'
8247       include 'COMMON.VAR'
8248       include 'COMMON.GEO'
8249       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
8250       double precision ggg1(3),ggg2(3)
8251 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8252 C                                                                              C
8253 C                            Parallel chains                                   C
8254 C                                                                              C
8255 C          o             o                   o             o                   C
8256 C         /l\           / \             \   / \           / \   /              C
8257 C        /   \         /   \             \ /   \         /   \ /               C
8258 C       j| o |l1       | o |              o| o |         | o |o                C
8259 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8260 C      \i/   \         /   \ /             /   \         /   \                 C
8261 C       o    k1             o                                                  C
8262 C         (I)          (II)                (III)          (IV)                 C
8263 C                                                                              C
8264 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8265 C                                                                              C
8266 C                            Antiparallel chains                               C
8267 C                                                                              C
8268 C          o             o                   o             o                   C
8269 C         /j\           / \             \   / \           / \   /              C
8270 C        /   \         /   \             \ /   \         /   \ /               C
8271 C      j1| o |l        | o |              o| o |         | o |o                C
8272 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8273 C      \i/   \         /   \ /             /   \         /   \                 C
8274 C       o     k1            o                                                  C
8275 C         (I)          (II)                (III)          (IV)                 C
8276 C                                                                              C
8277 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8278 C                                                                              C
8279 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
8280 C                                                                              C
8281 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8282 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8283 cd        eello5=0.0d0
8284 cd        return
8285 cd      endif
8286 cd      write (iout,*)
8287 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8288 cd     &   ' and',k,l
8289       itk=itortyp(itype(k))
8290       itl=itortyp(itype(l))
8291       itj=itortyp(itype(j))
8292       eello5_1=0.0d0
8293       eello5_2=0.0d0
8294       eello5_3=0.0d0
8295       eello5_4=0.0d0
8296 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8297 cd     &   eel5_3_num,eel5_4_num)
8298       do iii=1,2
8299         do kkk=1,5
8300           do lll=1,3
8301             derx(lll,kkk,iii)=0.0d0
8302           enddo
8303         enddo
8304       enddo
8305 cd      eij=facont_hb(jj,i)
8306 cd      ekl=facont_hb(kk,k)
8307 cd      ekont=eij*ekl
8308 cd      write (iout,*)'Contacts have occurred for peptide groups',
8309 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
8310 cd      goto 1111
8311 C Contribution from the graph I.
8312 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8313 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8314       call transpose2(EUg(1,1,k),auxmat(1,1))
8315       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8316       vv(1)=pizda(1,1)-pizda(2,2)
8317       vv(2)=pizda(1,2)+pizda(2,1)
8318       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
8319      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8320 C Explicit gradient in virtual-dihedral angles.
8321       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
8322      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
8323      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8324       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8325       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8326       vv(1)=pizda(1,1)-pizda(2,2)
8327       vv(2)=pizda(1,2)+pizda(2,1)
8328       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8329      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
8330      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8331       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8332       vv(1)=pizda(1,1)-pizda(2,2)
8333       vv(2)=pizda(1,2)+pizda(2,1)
8334       if (l.eq.j+1) then
8335         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
8336      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8337      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8338       else
8339         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
8340      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8341      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8342       endif
8343 C Cartesian gradient
8344       do iii=1,2
8345         do kkk=1,5
8346           do lll=1,3
8347             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
8348      &        pizda(1,1))
8349             vv(1)=pizda(1,1)-pizda(2,2)
8350             vv(2)=pizda(1,2)+pizda(2,1)
8351             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8352      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
8353      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8354           enddo
8355         enddo
8356       enddo
8357 c      goto 1112
8358 c1111  continue
8359 C Contribution from graph II
8360       call transpose2(EE(1,1,itk),auxmat(1,1))
8361       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8362       vv(1)=pizda(1,1)+pizda(2,2)
8363       vv(2)=pizda(2,1)-pizda(1,2)
8364       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
8365      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
8366 C Explicit gradient in virtual-dihedral angles.
8367       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8368      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8369       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8370       vv(1)=pizda(1,1)+pizda(2,2)
8371       vv(2)=pizda(2,1)-pizda(1,2)
8372       if (l.eq.j+1) then
8373         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8374      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
8375      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8376       else
8377         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8378      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
8379      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8380       endif
8381 C Cartesian gradient
8382       do iii=1,2
8383         do kkk=1,5
8384           do lll=1,3
8385             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8386      &        pizda(1,1))
8387             vv(1)=pizda(1,1)+pizda(2,2)
8388             vv(2)=pizda(2,1)-pizda(1,2)
8389             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8390      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
8391      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
8392           enddo
8393         enddo
8394       enddo
8395 cd      goto 1112
8396 cd1111  continue
8397       if (l.eq.j+1) then
8398 cd        goto 1110
8399 C Parallel orientation
8400 C Contribution from graph III
8401         call transpose2(EUg(1,1,l),auxmat(1,1))
8402         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8403         vv(1)=pizda(1,1)-pizda(2,2)
8404         vv(2)=pizda(1,2)+pizda(2,1)
8405         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
8406      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8407 C Explicit gradient in virtual-dihedral angles.
8408         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8409      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
8410      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8411         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8412         vv(1)=pizda(1,1)-pizda(2,2)
8413         vv(2)=pizda(1,2)+pizda(2,1)
8414         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8415      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
8416      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8417         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8418         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8419         vv(1)=pizda(1,1)-pizda(2,2)
8420         vv(2)=pizda(1,2)+pizda(2,1)
8421         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8422      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
8423      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8424 C Cartesian gradient
8425         do iii=1,2
8426           do kkk=1,5
8427             do lll=1,3
8428               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8429      &          pizda(1,1))
8430               vv(1)=pizda(1,1)-pizda(2,2)
8431               vv(2)=pizda(1,2)+pizda(2,1)
8432               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8433      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
8434      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8435             enddo
8436           enddo
8437         enddo
8438 cd        goto 1112
8439 C Contribution from graph IV
8440 cd1110    continue
8441         call transpose2(EE(1,1,itl),auxmat(1,1))
8442         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8443         vv(1)=pizda(1,1)+pizda(2,2)
8444         vv(2)=pizda(2,1)-pizda(1,2)
8445         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
8446      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
8447 C Explicit gradient in virtual-dihedral angles.
8448         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8449      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8450         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8451         vv(1)=pizda(1,1)+pizda(2,2)
8452         vv(2)=pizda(2,1)-pizda(1,2)
8453         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8454      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
8455      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8456 C Cartesian gradient
8457         do iii=1,2
8458           do kkk=1,5
8459             do lll=1,3
8460               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8461      &          pizda(1,1))
8462               vv(1)=pizda(1,1)+pizda(2,2)
8463               vv(2)=pizda(2,1)-pizda(1,2)
8464               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8465      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
8466      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
8467             enddo
8468           enddo
8469         enddo
8470       else
8471 C Antiparallel orientation
8472 C Contribution from graph III
8473 c        goto 1110
8474         call transpose2(EUg(1,1,j),auxmat(1,1))
8475         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8476         vv(1)=pizda(1,1)-pizda(2,2)
8477         vv(2)=pizda(1,2)+pizda(2,1)
8478         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
8479      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8480 C Explicit gradient in virtual-dihedral angles.
8481         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8482      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
8483      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8484         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8485         vv(1)=pizda(1,1)-pizda(2,2)
8486         vv(2)=pizda(1,2)+pizda(2,1)
8487         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8488      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
8489      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8490         call transpose2(EUgder(1,1,j),auxmat1(1,1))
8491         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8492         vv(1)=pizda(1,1)-pizda(2,2)
8493         vv(2)=pizda(1,2)+pizda(2,1)
8494         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8495      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
8496      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8497 C Cartesian gradient
8498         do iii=1,2
8499           do kkk=1,5
8500             do lll=1,3
8501               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8502      &          pizda(1,1))
8503               vv(1)=pizda(1,1)-pizda(2,2)
8504               vv(2)=pizda(1,2)+pizda(2,1)
8505               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8506      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
8507      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8508             enddo
8509           enddo
8510         enddo
8511 cd        goto 1112
8512 C Contribution from graph IV
8513 1110    continue
8514         call transpose2(EE(1,1,itj),auxmat(1,1))
8515         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8516         vv(1)=pizda(1,1)+pizda(2,2)
8517         vv(2)=pizda(2,1)-pizda(1,2)
8518         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
8519      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
8520 C Explicit gradient in virtual-dihedral angles.
8521         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8522      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
8523         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8524         vv(1)=pizda(1,1)+pizda(2,2)
8525         vv(2)=pizda(2,1)-pizda(1,2)
8526         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8527      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
8528      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
8529 C Cartesian gradient
8530         do iii=1,2
8531           do kkk=1,5
8532             do lll=1,3
8533               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8534      &          pizda(1,1))
8535               vv(1)=pizda(1,1)+pizda(2,2)
8536               vv(2)=pizda(2,1)-pizda(1,2)
8537               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8538      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
8539      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
8540             enddo
8541           enddo
8542         enddo
8543       endif
8544 1112  continue
8545       eel5=eello5_1+eello5_2+eello5_3+eello5_4
8546 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
8547 cd        write (2,*) 'ijkl',i,j,k,l
8548 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
8549 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
8550 cd      endif
8551 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
8552 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
8553 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
8554 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
8555       if (j.lt.nres-1) then
8556         j1=j+1
8557         j2=j-1
8558       else
8559         j1=j-1
8560         j2=j-2
8561       endif
8562       if (l.lt.nres-1) then
8563         l1=l+1
8564         l2=l-1
8565       else
8566         l1=l-1
8567         l2=l-2
8568       endif
8569 cd      eij=1.0d0
8570 cd      ekl=1.0d0
8571 cd      ekont=1.0d0
8572 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
8573 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
8574 C        summed up outside the subrouine as for the other subroutines
8575 C        handling long-range interactions. The old code is commented out
8576 C        with "cgrad" to keep track of changes.
8577       do ll=1,3
8578 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
8579 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
8580         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
8581         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
8582 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
8583 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
8584 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
8585 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
8586 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
8587 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
8588 c     &   gradcorr5ij,
8589 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
8590 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
8591 cgrad        ghalf=0.5d0*ggg1(ll)
8592 cd        ghalf=0.0d0
8593         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
8594         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
8595         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
8596         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
8597         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
8598         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
8599 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
8600 cgrad        ghalf=0.5d0*ggg2(ll)
8601 cd        ghalf=0.0d0
8602         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
8603         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
8604         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
8605         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
8606         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
8607         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
8608       enddo
8609 cd      goto 1112
8610 cgrad      do m=i+1,j-1
8611 cgrad        do ll=1,3
8612 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
8613 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
8614 cgrad        enddo
8615 cgrad      enddo
8616 cgrad      do m=k+1,l-1
8617 cgrad        do ll=1,3
8618 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
8619 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
8620 cgrad        enddo
8621 cgrad      enddo
8622 c1112  continue
8623 cgrad      do m=i+2,j2
8624 cgrad        do ll=1,3
8625 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
8626 cgrad        enddo
8627 cgrad      enddo
8628 cgrad      do m=k+2,l2
8629 cgrad        do ll=1,3
8630 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
8631 cgrad        enddo
8632 cgrad      enddo
8633 cd      do iii=1,nres-3
8634 cd        write (2,*) iii,g_corr5_loc(iii)
8635 cd      enddo
8636       eello5=ekont*eel5
8637 cd      write (2,*) 'ekont',ekont
8638 cd      write (iout,*) 'eello5',ekont*eel5
8639       return
8640       end
8641 c--------------------------------------------------------------------------
8642       double precision function eello6(i,j,k,l,jj,kk)
8643       implicit real*8 (a-h,o-z)
8644       include 'DIMENSIONS'
8645       include 'COMMON.IOUNITS'
8646       include 'COMMON.CHAIN'
8647       include 'COMMON.DERIV'
8648       include 'COMMON.INTERACT'
8649       include 'COMMON.CONTACTS'
8650       include 'COMMON.TORSION'
8651       include 'COMMON.VAR'
8652       include 'COMMON.GEO'
8653       include 'COMMON.FFIELD'
8654       double precision ggg1(3),ggg2(3)
8655 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8656 cd        eello6=0.0d0
8657 cd        return
8658 cd      endif
8659 cd      write (iout,*)
8660 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8661 cd     &   ' and',k,l
8662       eello6_1=0.0d0
8663       eello6_2=0.0d0
8664       eello6_3=0.0d0
8665       eello6_4=0.0d0
8666       eello6_5=0.0d0
8667       eello6_6=0.0d0
8668 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8669 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8670       do iii=1,2
8671         do kkk=1,5
8672           do lll=1,3
8673             derx(lll,kkk,iii)=0.0d0
8674           enddo
8675         enddo
8676       enddo
8677 cd      eij=facont_hb(jj,i)
8678 cd      ekl=facont_hb(kk,k)
8679 cd      ekont=eij*ekl
8680 cd      eij=1.0d0
8681 cd      ekl=1.0d0
8682 cd      ekont=1.0d0
8683       if (l.eq.j+1) then
8684         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8685         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8686         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8687         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8688         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8689         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8690       else
8691         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8692         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8693         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8694         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8695         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8696           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8697         else
8698           eello6_5=0.0d0
8699         endif
8700         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8701       endif
8702 C If turn contributions are considered, they will be handled separately.
8703       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8704 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8705 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8706 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8707 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8708 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8709 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8710 cd      goto 1112
8711       if (j.lt.nres-1) then
8712         j1=j+1
8713         j2=j-1
8714       else
8715         j1=j-1
8716         j2=j-2
8717       endif
8718       if (l.lt.nres-1) then
8719         l1=l+1
8720         l2=l-1
8721       else
8722         l1=l-1
8723         l2=l-2
8724       endif
8725       do ll=1,3
8726 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8727 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8728 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8729 cgrad        ghalf=0.5d0*ggg1(ll)
8730 cd        ghalf=0.0d0
8731         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8732         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8733         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8734         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8735         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8736         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8737         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8738         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8739 cgrad        ghalf=0.5d0*ggg2(ll)
8740 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8741 cd        ghalf=0.0d0
8742         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8743         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8744         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8745         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8746         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8747         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8748       enddo
8749 cd      goto 1112
8750 cgrad      do m=i+1,j-1
8751 cgrad        do ll=1,3
8752 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8753 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8754 cgrad        enddo
8755 cgrad      enddo
8756 cgrad      do m=k+1,l-1
8757 cgrad        do ll=1,3
8758 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8759 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8760 cgrad        enddo
8761 cgrad      enddo
8762 cgrad1112  continue
8763 cgrad      do m=i+2,j2
8764 cgrad        do ll=1,3
8765 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8766 cgrad        enddo
8767 cgrad      enddo
8768 cgrad      do m=k+2,l2
8769 cgrad        do ll=1,3
8770 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8771 cgrad        enddo
8772 cgrad      enddo
8773 cd      do iii=1,nres-3
8774 cd        write (2,*) iii,g_corr6_loc(iii)
8775 cd      enddo
8776       eello6=ekont*eel6
8777 cd      write (2,*) 'ekont',ekont
8778 cd      write (iout,*) 'eello6',ekont*eel6
8779       return
8780       end
8781 c--------------------------------------------------------------------------
8782       double precision function eello6_graph1(i,j,k,l,imat,swap)
8783       implicit real*8 (a-h,o-z)
8784       include 'DIMENSIONS'
8785       include 'COMMON.IOUNITS'
8786       include 'COMMON.CHAIN'
8787       include 'COMMON.DERIV'
8788       include 'COMMON.INTERACT'
8789       include 'COMMON.CONTACTS'
8790       include 'COMMON.TORSION'
8791       include 'COMMON.VAR'
8792       include 'COMMON.GEO'
8793       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8794       logical swap
8795       logical lprn
8796       common /kutas/ lprn
8797 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8798 C
8799 C      Parallel       Antiparallel
8800 C
8801 C          o             o
8802 C         /l\           /j\
8803 C        /   \         /   \
8804 C       /| o |         | o |\
8805 C     \ j|/k\|  /   \  |/k\|l /
8806 C      \ /   \ /     \ /   \ /
8807 C       o     o       o     o
8808 C       i             i
8809 C
8810 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8811       itk=itortyp(itype(k))
8812       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8813       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8814       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8815       call transpose2(EUgC(1,1,k),auxmat(1,1))
8816       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8817       vv1(1)=pizda1(1,1)-pizda1(2,2)
8818       vv1(2)=pizda1(1,2)+pizda1(2,1)
8819       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8820       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8821       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8822       s5=scalar2(vv(1),Dtobr2(1,i))
8823 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8824       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8825       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8826      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8827      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8828      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8829      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8830      & +scalar2(vv(1),Dtobr2der(1,i)))
8831       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8832       vv1(1)=pizda1(1,1)-pizda1(2,2)
8833       vv1(2)=pizda1(1,2)+pizda1(2,1)
8834       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8835       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8836       if (l.eq.j+1) then
8837         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8838      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8839      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8840      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8841      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8842       else
8843         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8844      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8845      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8846      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8847      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8848       endif
8849       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8850       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8851       vv1(1)=pizda1(1,1)-pizda1(2,2)
8852       vv1(2)=pizda1(1,2)+pizda1(2,1)
8853       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8854      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8855      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8856      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8857       do iii=1,2
8858         if (swap) then
8859           ind=3-iii
8860         else
8861           ind=iii
8862         endif
8863         do kkk=1,5
8864           do lll=1,3
8865             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8866             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8867             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8868             call transpose2(EUgC(1,1,k),auxmat(1,1))
8869             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8870      &        pizda1(1,1))
8871             vv1(1)=pizda1(1,1)-pizda1(2,2)
8872             vv1(2)=pizda1(1,2)+pizda1(2,1)
8873             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8874             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8875      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8876             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8877      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8878             s5=scalar2(vv(1),Dtobr2(1,i))
8879             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8880           enddo
8881         enddo
8882       enddo
8883       return
8884       end
8885 c----------------------------------------------------------------------------
8886       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8887       implicit real*8 (a-h,o-z)
8888       include 'DIMENSIONS'
8889       include 'COMMON.IOUNITS'
8890       include 'COMMON.CHAIN'
8891       include 'COMMON.DERIV'
8892       include 'COMMON.INTERACT'
8893       include 'COMMON.CONTACTS'
8894       include 'COMMON.TORSION'
8895       include 'COMMON.VAR'
8896       include 'COMMON.GEO'
8897       logical swap
8898       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8899      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8900       logical lprn
8901       common /kutas/ lprn
8902 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8903 C                                                                              C
8904 C      Parallel       Antiparallel                                             C
8905 C                                                                              C
8906 C          o             o                                                     C
8907 C     \   /l\           /j\   /                                                C
8908 C      \ /   \         /   \ /                                                 C
8909 C       o| o |         | o |o                                                  C
8910 C     \ j|/k\|      \  |/k\|l                                                  C
8911 C      \ /   \       \ /   \                                                   C
8912 C       o             o                                                        C
8913 C       i             i                                                        C
8914 C                                                                              C
8915 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8916 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8917 C AL 7/4/01 s1 would occur in the sixth-order moment,
8918 C           but not in a cluster cumulant
8919 #ifdef MOMENT
8920       s1=dip(1,jj,i)*dip(1,kk,k)
8921 #endif
8922       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8923       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8924       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8925       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8926       call transpose2(EUg(1,1,k),auxmat(1,1))
8927       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8928       vv(1)=pizda(1,1)-pizda(2,2)
8929       vv(2)=pizda(1,2)+pizda(2,1)
8930       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8931 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8932 #ifdef MOMENT
8933       eello6_graph2=-(s1+s2+s3+s4)
8934 #else
8935       eello6_graph2=-(s2+s3+s4)
8936 #endif
8937 c      eello6_graph2=-s3
8938 C Derivatives in gamma(i-1)
8939       if (i.gt.1) then
8940 #ifdef MOMENT
8941         s1=dipderg(1,jj,i)*dip(1,kk,k)
8942 #endif
8943         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8944         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8945         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8946         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8947 #ifdef MOMENT
8948         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8949 #else
8950         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8951 #endif
8952 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8953       endif
8954 C Derivatives in gamma(k-1)
8955 #ifdef MOMENT
8956       s1=dip(1,jj,i)*dipderg(1,kk,k)
8957 #endif
8958       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8959       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8960       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8961       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8962       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8963       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8964       vv(1)=pizda(1,1)-pizda(2,2)
8965       vv(2)=pizda(1,2)+pizda(2,1)
8966       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8967 #ifdef MOMENT
8968       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8969 #else
8970       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8971 #endif
8972 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8973 C Derivatives in gamma(j-1) or gamma(l-1)
8974       if (j.gt.1) then
8975 #ifdef MOMENT
8976         s1=dipderg(3,jj,i)*dip(1,kk,k)
8977 #endif
8978         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8979         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8980         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8981         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8982         vv(1)=pizda(1,1)-pizda(2,2)
8983         vv(2)=pizda(1,2)+pizda(2,1)
8984         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8985 #ifdef MOMENT
8986         if (swap) then
8987           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8988         else
8989           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8990         endif
8991 #endif
8992         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8993 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8994       endif
8995 C Derivatives in gamma(l-1) or gamma(j-1)
8996       if (l.gt.1) then
8997 #ifdef MOMENT
8998         s1=dip(1,jj,i)*dipderg(3,kk,k)
8999 #endif
9000         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
9001         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9002         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
9003         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9004         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
9005         vv(1)=pizda(1,1)-pizda(2,2)
9006         vv(2)=pizda(1,2)+pizda(2,1)
9007         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9008 #ifdef MOMENT
9009         if (swap) then
9010           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9011         else
9012           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9013         endif
9014 #endif
9015         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
9016 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
9017       endif
9018 C Cartesian derivatives.
9019       if (lprn) then
9020         write (2,*) 'In eello6_graph2'
9021         do iii=1,2
9022           write (2,*) 'iii=',iii
9023           do kkk=1,5
9024             write (2,*) 'kkk=',kkk
9025             do jjj=1,2
9026               write (2,'(3(2f10.5),5x)')
9027      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9028             enddo
9029           enddo
9030         enddo
9031       endif
9032       do iii=1,2
9033         do kkk=1,5
9034           do lll=1,3
9035 #ifdef MOMENT
9036             if (iii.eq.1) then
9037               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
9038             else
9039               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
9040             endif
9041 #endif
9042             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
9043      &        auxvec(1))
9044             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9045             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
9046      &        auxvec(1))
9047             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
9048             call transpose2(EUg(1,1,k),auxmat(1,1))
9049             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
9050      &        pizda(1,1))
9051             vv(1)=pizda(1,1)-pizda(2,2)
9052             vv(2)=pizda(1,2)+pizda(2,1)
9053             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9054 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
9055 #ifdef MOMENT
9056             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9057 #else
9058             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9059 #endif
9060             if (swap) then
9061               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9062             else
9063               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9064             endif
9065           enddo
9066         enddo
9067       enddo
9068       return
9069       end
9070 c----------------------------------------------------------------------------
9071       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
9072       implicit real*8 (a-h,o-z)
9073       include 'DIMENSIONS'
9074       include 'COMMON.IOUNITS'
9075       include 'COMMON.CHAIN'
9076       include 'COMMON.DERIV'
9077       include 'COMMON.INTERACT'
9078       include 'COMMON.CONTACTS'
9079       include 'COMMON.TORSION'
9080       include 'COMMON.VAR'
9081       include 'COMMON.GEO'
9082       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
9083       logical swap
9084 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9085 C                                                                              C
9086 C      Parallel       Antiparallel                                             C
9087 C                                                                              C
9088 C          o             o                                                     C
9089 C         /l\   /   \   /j\                                                    C
9090 C        /   \ /     \ /   \                                                   C
9091 C       /| o |o       o| o |\                                                  C
9092 C       j|/k\|  /      |/k\|l /                                                C
9093 C        /   \ /       /   \ /                                                 C
9094 C       /     o       /     o                                                  C
9095 C       i             i                                                        C
9096 C                                                                              C
9097 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9098 C
9099 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9100 C           energy moment and not to the cluster cumulant.
9101       iti=itortyp(itype(i))
9102       if (j.lt.nres-1) then
9103         itj1=itortyp(itype(j+1))
9104       else
9105         itj1=ntortyp+1
9106       endif
9107       itk=itortyp(itype(k))
9108       itk1=itortyp(itype(k+1))
9109       if (l.lt.nres-1) then
9110         itl1=itortyp(itype(l+1))
9111       else
9112         itl1=ntortyp+1
9113       endif
9114 #ifdef MOMENT
9115       s1=dip(4,jj,i)*dip(4,kk,k)
9116 #endif
9117       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
9118       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9119       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
9120       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9121       call transpose2(EE(1,1,itk),auxmat(1,1))
9122       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
9123       vv(1)=pizda(1,1)+pizda(2,2)
9124       vv(2)=pizda(2,1)-pizda(1,2)
9125       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9126 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9127 cd     & "sum",-(s2+s3+s4)
9128 #ifdef MOMENT
9129       eello6_graph3=-(s1+s2+s3+s4)
9130 #else
9131       eello6_graph3=-(s2+s3+s4)
9132 #endif
9133 c      eello6_graph3=-s4
9134 C Derivatives in gamma(k-1)
9135       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
9136       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9137       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9138       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9139 C Derivatives in gamma(l-1)
9140       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
9141       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9142       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9143       vv(1)=pizda(1,1)+pizda(2,2)
9144       vv(2)=pizda(2,1)-pizda(1,2)
9145       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9146       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9147 C Cartesian derivatives.
9148       do iii=1,2
9149         do kkk=1,5
9150           do lll=1,3
9151 #ifdef MOMENT
9152             if (iii.eq.1) then
9153               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9154             else
9155               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9156             endif
9157 #endif
9158             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
9159      &        auxvec(1))
9160             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9161             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
9162      &        auxvec(1))
9163             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9164             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
9165      &        pizda(1,1))
9166             vv(1)=pizda(1,1)+pizda(2,2)
9167             vv(2)=pizda(2,1)-pizda(1,2)
9168             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9169 #ifdef MOMENT
9170             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9171 #else
9172             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9173 #endif
9174             if (swap) then
9175               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9176             else
9177               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9178             endif
9179 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9180           enddo
9181         enddo
9182       enddo
9183       return
9184       end
9185 c----------------------------------------------------------------------------
9186       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
9187       implicit real*8 (a-h,o-z)
9188       include 'DIMENSIONS'
9189       include 'COMMON.IOUNITS'
9190       include 'COMMON.CHAIN'
9191       include 'COMMON.DERIV'
9192       include 'COMMON.INTERACT'
9193       include 'COMMON.CONTACTS'
9194       include 'COMMON.TORSION'
9195       include 'COMMON.VAR'
9196       include 'COMMON.GEO'
9197       include 'COMMON.FFIELD'
9198       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9199      & auxvec1(2),auxmat1(2,2)
9200       logical swap
9201 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9202 C                                                                              C
9203 C      Parallel       Antiparallel                                             C
9204 C                                                                              C
9205 C          o             o                                                     C
9206 C         /l\   /   \   /j\                                                    C
9207 C        /   \ /     \ /   \                                                   C
9208 C       /| o |o       o| o |\                                                  C
9209 C     \ j|/k\|      \  |/k\|l                                                  C
9210 C      \ /   \       \ /   \                                                   C
9211 C       o     \       o     \                                                  C
9212 C       i             i                                                        C
9213 C                                                                              C
9214 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9215 C
9216 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9217 C           energy moment and not to the cluster cumulant.
9218 cd      write (2,*) 'eello_graph4: wturn6',wturn6
9219       iti=itortyp(itype(i))
9220       itj=itortyp(itype(j))
9221       if (j.lt.nres-1) then
9222         itj1=itortyp(itype(j+1))
9223       else
9224         itj1=ntortyp+1
9225       endif
9226       itk=itortyp(itype(k))
9227       if (k.lt.nres-1) then
9228         itk1=itortyp(itype(k+1))
9229       else
9230         itk1=ntortyp+1
9231       endif
9232       itl=itortyp(itype(l))
9233       if (l.lt.nres-1) then
9234         itl1=itortyp(itype(l+1))
9235       else
9236         itl1=ntortyp+1
9237       endif
9238 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9239 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9240 cd     & ' itl',itl,' itl1',itl1
9241 #ifdef MOMENT
9242       if (imat.eq.1) then
9243         s1=dip(3,jj,i)*dip(3,kk,k)
9244       else
9245         s1=dip(2,jj,j)*dip(2,kk,l)
9246       endif
9247 #endif
9248       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9249       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9250       if (j.eq.l+1) then
9251         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
9252         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9253       else
9254         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
9255         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9256       endif
9257       call transpose2(EUg(1,1,k),auxmat(1,1))
9258       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9259       vv(1)=pizda(1,1)-pizda(2,2)
9260       vv(2)=pizda(2,1)+pizda(1,2)
9261       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9262 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9263 #ifdef MOMENT
9264       eello6_graph4=-(s1+s2+s3+s4)
9265 #else
9266       eello6_graph4=-(s2+s3+s4)
9267 #endif
9268 C Derivatives in gamma(i-1)
9269       if (i.gt.1) then
9270 #ifdef MOMENT
9271         if (imat.eq.1) then
9272           s1=dipderg(2,jj,i)*dip(3,kk,k)
9273         else
9274           s1=dipderg(4,jj,j)*dip(2,kk,l)
9275         endif
9276 #endif
9277         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9278         if (j.eq.l+1) then
9279           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
9280           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9281         else
9282           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
9283           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9284         endif
9285         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9286         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9287 cd          write (2,*) 'turn6 derivatives'
9288 #ifdef MOMENT
9289           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9290 #else
9291           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9292 #endif
9293         else
9294 #ifdef MOMENT
9295           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9296 #else
9297           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9298 #endif
9299         endif
9300       endif
9301 C Derivatives in gamma(k-1)
9302 #ifdef MOMENT
9303       if (imat.eq.1) then
9304         s1=dip(3,jj,i)*dipderg(2,kk,k)
9305       else
9306         s1=dip(2,jj,j)*dipderg(4,kk,l)
9307       endif
9308 #endif
9309       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9310       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9311       if (j.eq.l+1) then
9312         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
9313         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9314       else
9315         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
9316         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9317       endif
9318       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9319       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9320       vv(1)=pizda(1,1)-pizda(2,2)
9321       vv(2)=pizda(2,1)+pizda(1,2)
9322       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9323       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9324 #ifdef MOMENT
9325         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9326 #else
9327         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9328 #endif
9329       else
9330 #ifdef MOMENT
9331         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9332 #else
9333         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9334 #endif
9335       endif
9336 C Derivatives in gamma(j-1) or gamma(l-1)
9337       if (l.eq.j+1 .and. l.gt.1) then
9338         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9339         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9340         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9341         vv(1)=pizda(1,1)-pizda(2,2)
9342         vv(2)=pizda(2,1)+pizda(1,2)
9343         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9344         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9345       else if (j.gt.1) then
9346         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9347         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9348         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9349         vv(1)=pizda(1,1)-pizda(2,2)
9350         vv(2)=pizda(2,1)+pizda(1,2)
9351         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9352         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9353           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9354         else
9355           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9356         endif
9357       endif
9358 C Cartesian derivatives.
9359       do iii=1,2
9360         do kkk=1,5
9361           do lll=1,3
9362 #ifdef MOMENT
9363             if (iii.eq.1) then
9364               if (imat.eq.1) then
9365                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9366               else
9367                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9368               endif
9369             else
9370               if (imat.eq.1) then
9371                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9372               else
9373                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9374               endif
9375             endif
9376 #endif
9377             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
9378      &        auxvec(1))
9379             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9380             if (j.eq.l+1) then
9381               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9382      &          b1(1,itj1),auxvec(1))
9383               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
9384             else
9385               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9386      &          b1(1,itl1),auxvec(1))
9387               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
9388             endif
9389             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9390      &        pizda(1,1))
9391             vv(1)=pizda(1,1)-pizda(2,2)
9392             vv(2)=pizda(2,1)+pizda(1,2)
9393             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9394             if (swap) then
9395               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9396 #ifdef MOMENT
9397                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9398      &             -(s1+s2+s4)
9399 #else
9400                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9401      &             -(s2+s4)
9402 #endif
9403                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9404               else
9405 #ifdef MOMENT
9406                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9407 #else
9408                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9409 #endif
9410                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9411               endif
9412             else
9413 #ifdef MOMENT
9414               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9415 #else
9416               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9417 #endif
9418               if (l.eq.j+1) then
9419                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9420               else
9421                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9422               endif
9423             endif
9424           enddo
9425         enddo
9426       enddo
9427       return
9428       end
9429 c----------------------------------------------------------------------------
9430       double precision function eello_turn6(i,jj,kk)
9431       implicit real*8 (a-h,o-z)
9432       include 'DIMENSIONS'
9433       include 'COMMON.IOUNITS'
9434       include 'COMMON.CHAIN'
9435       include 'COMMON.DERIV'
9436       include 'COMMON.INTERACT'
9437       include 'COMMON.CONTACTS'
9438       include 'COMMON.TORSION'
9439       include 'COMMON.VAR'
9440       include 'COMMON.GEO'
9441       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
9442      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
9443      &  ggg1(3),ggg2(3)
9444       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
9445      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
9446 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9447 C           the respective energy moment and not to the cluster cumulant.
9448       s1=0.0d0
9449       s8=0.0d0
9450       s13=0.0d0
9451 c
9452       eello_turn6=0.0d0
9453       j=i+4
9454       k=i+1
9455       l=i+3
9456       iti=itortyp(itype(i))
9457       itk=itortyp(itype(k))
9458       itk1=itortyp(itype(k+1))
9459       itl=itortyp(itype(l))
9460       itj=itortyp(itype(j))
9461 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9462 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
9463 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9464 cd        eello6=0.0d0
9465 cd        return
9466 cd      endif
9467 cd      write (iout,*)
9468 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9469 cd     &   ' and',k,l
9470 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
9471       do iii=1,2
9472         do kkk=1,5
9473           do lll=1,3
9474             derx_turn(lll,kkk,iii)=0.0d0
9475           enddo
9476         enddo
9477       enddo
9478 cd      eij=1.0d0
9479 cd      ekl=1.0d0
9480 cd      ekont=1.0d0
9481       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9482 cd      eello6_5=0.0d0
9483 cd      write (2,*) 'eello6_5',eello6_5
9484 #ifdef MOMENT
9485       call transpose2(AEA(1,1,1),auxmat(1,1))
9486       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
9487       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
9488       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
9489 #endif
9490       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9491       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
9492       s2 = scalar2(b1(1,itk),vtemp1(1))
9493 #ifdef MOMENT
9494       call transpose2(AEA(1,1,2),atemp(1,1))
9495       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
9496       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
9497       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9498 #endif
9499       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
9500       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
9501       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
9502 #ifdef MOMENT
9503       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
9504       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
9505       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
9506       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
9507       ss13 = scalar2(b1(1,itk),vtemp4(1))
9508       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
9509 #endif
9510 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
9511 c      s1=0.0d0
9512 c      s2=0.0d0
9513 c      s8=0.0d0
9514 c      s12=0.0d0
9515 c      s13=0.0d0
9516       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
9517 C Derivatives in gamma(i+2)
9518       s1d =0.0d0
9519       s8d =0.0d0
9520 #ifdef MOMENT
9521       call transpose2(AEA(1,1,1),auxmatd(1,1))
9522       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9523       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9524       call transpose2(AEAderg(1,1,2),atempd(1,1))
9525       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9526       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9527 #endif
9528       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
9529       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9530       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9531 c      s1d=0.0d0
9532 c      s2d=0.0d0
9533 c      s8d=0.0d0
9534 c      s12d=0.0d0
9535 c      s13d=0.0d0
9536       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
9537 C Derivatives in gamma(i+3)
9538 #ifdef MOMENT
9539       call transpose2(AEA(1,1,1),auxmatd(1,1))
9540       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9541       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
9542       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
9543 #endif
9544       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
9545       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
9546       s2d = scalar2(b1(1,itk),vtemp1d(1))
9547 #ifdef MOMENT
9548       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
9549       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
9550 #endif
9551       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
9552 #ifdef MOMENT
9553       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
9554       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9555       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9556 #endif
9557 c      s1d=0.0d0
9558 c      s2d=0.0d0
9559 c      s8d=0.0d0
9560 c      s12d=0.0d0
9561 c      s13d=0.0d0
9562 #ifdef MOMENT
9563       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9564      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9565 #else
9566       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9567      &               -0.5d0*ekont*(s2d+s12d)
9568 #endif
9569 C Derivatives in gamma(i+4)
9570       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
9571       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9572       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9573 #ifdef MOMENT
9574       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
9575       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
9576       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9577 #endif
9578 c      s1d=0.0d0
9579 c      s2d=0.0d0
9580 c      s8d=0.0d0
9581 C      s12d=0.0d0
9582 c      s13d=0.0d0
9583 #ifdef MOMENT
9584       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
9585 #else
9586       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
9587 #endif
9588 C Derivatives in gamma(i+5)
9589 #ifdef MOMENT
9590       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
9591       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9592       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9593 #endif
9594       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
9595       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
9596       s2d = scalar2(b1(1,itk),vtemp1d(1))
9597 #ifdef MOMENT
9598       call transpose2(AEA(1,1,2),atempd(1,1))
9599       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
9600       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9601 #endif
9602       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
9603       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9604 #ifdef MOMENT
9605       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
9606       ss13d = scalar2(b1(1,itk),vtemp4d(1))
9607       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9608 #endif
9609 c      s1d=0.0d0
9610 c      s2d=0.0d0
9611 c      s8d=0.0d0
9612 c      s12d=0.0d0
9613 c      s13d=0.0d0
9614 #ifdef MOMENT
9615       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9616      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9617 #else
9618       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9619      &               -0.5d0*ekont*(s2d+s12d)
9620 #endif
9621 C Cartesian derivatives
9622       do iii=1,2
9623         do kkk=1,5
9624           do lll=1,3
9625 #ifdef MOMENT
9626             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
9627             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9628             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9629 #endif
9630             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9631             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
9632      &          vtemp1d(1))
9633             s2d = scalar2(b1(1,itk),vtemp1d(1))
9634 #ifdef MOMENT
9635             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
9636             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9637             s8d = -(atempd(1,1)+atempd(2,2))*
9638      &           scalar2(cc(1,1,itl),vtemp2(1))
9639 #endif
9640             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
9641      &           auxmatd(1,1))
9642             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9643             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9644 c      s1d=0.0d0
9645 c      s2d=0.0d0
9646 c      s8d=0.0d0
9647 c      s12d=0.0d0
9648 c      s13d=0.0d0
9649 #ifdef MOMENT
9650             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9651      &        - 0.5d0*(s1d+s2d)
9652 #else
9653             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9654      &        - 0.5d0*s2d
9655 #endif
9656 #ifdef MOMENT
9657             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9658      &        - 0.5d0*(s8d+s12d)
9659 #else
9660             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9661      &        - 0.5d0*s12d
9662 #endif
9663           enddo
9664         enddo
9665       enddo
9666 #ifdef MOMENT
9667       do kkk=1,5
9668         do lll=1,3
9669           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9670      &      achuj_tempd(1,1))
9671           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9672           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9673           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9674           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9675           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9676      &      vtemp4d(1))
9677           ss13d = scalar2(b1(1,itk),vtemp4d(1))
9678           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9679           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9680         enddo
9681       enddo
9682 #endif
9683 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9684 cd     &  16*eel_turn6_num
9685 cd      goto 1112
9686       if (j.lt.nres-1) then
9687         j1=j+1
9688         j2=j-1
9689       else
9690         j1=j-1
9691         j2=j-2
9692       endif
9693       if (l.lt.nres-1) then
9694         l1=l+1
9695         l2=l-1
9696       else
9697         l1=l-1
9698         l2=l-2
9699       endif
9700       do ll=1,3
9701 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9702 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9703 cgrad        ghalf=0.5d0*ggg1(ll)
9704 cd        ghalf=0.0d0
9705         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9706         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9707         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9708      &    +ekont*derx_turn(ll,2,1)
9709         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9710         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9711      &    +ekont*derx_turn(ll,4,1)
9712         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9713         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9714         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9715 cgrad        ghalf=0.5d0*ggg2(ll)
9716 cd        ghalf=0.0d0
9717         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9718      &    +ekont*derx_turn(ll,2,2)
9719         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9720         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9721      &    +ekont*derx_turn(ll,4,2)
9722         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9723         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9724         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9725       enddo
9726 cd      goto 1112
9727 cgrad      do m=i+1,j-1
9728 cgrad        do ll=1,3
9729 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9730 cgrad        enddo
9731 cgrad      enddo
9732 cgrad      do m=k+1,l-1
9733 cgrad        do ll=1,3
9734 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9735 cgrad        enddo
9736 cgrad      enddo
9737 cgrad1112  continue
9738 cgrad      do m=i+2,j2
9739 cgrad        do ll=1,3
9740 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9741 cgrad        enddo
9742 cgrad      enddo
9743 cgrad      do m=k+2,l2
9744 cgrad        do ll=1,3
9745 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9746 cgrad        enddo
9747 cgrad      enddo
9748 cd      do iii=1,nres-3
9749 cd        write (2,*) iii,g_corr6_loc(iii)
9750 cd      enddo
9751       eello_turn6=ekont*eel_turn6
9752 cd      write (2,*) 'ekont',ekont
9753 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9754       return
9755       end
9756
9757 C-----------------------------------------------------------------------------
9758       double precision function scalar(u,v)
9759 !DIR$ INLINEALWAYS scalar
9760 #ifndef OSF
9761 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9762 #endif
9763       implicit none
9764       double precision u(3),v(3)
9765 cd      double precision sc
9766 cd      integer i
9767 cd      sc=0.0d0
9768 cd      do i=1,3
9769 cd        sc=sc+u(i)*v(i)
9770 cd      enddo
9771 cd      scalar=sc
9772
9773       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9774       return
9775       end
9776 crc-------------------------------------------------
9777       SUBROUTINE MATVEC2(A1,V1,V2)
9778 !DIR$ INLINEALWAYS MATVEC2
9779 #ifndef OSF
9780 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9781 #endif
9782       implicit real*8 (a-h,o-z)
9783       include 'DIMENSIONS'
9784       DIMENSION A1(2,2),V1(2),V2(2)
9785 c      DO 1 I=1,2
9786 c        VI=0.0
9787 c        DO 3 K=1,2
9788 c    3     VI=VI+A1(I,K)*V1(K)
9789 c        Vaux(I)=VI
9790 c    1 CONTINUE
9791
9792       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9793       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9794
9795       v2(1)=vaux1
9796       v2(2)=vaux2
9797       END
9798 C---------------------------------------
9799       SUBROUTINE MATMAT2(A1,A2,A3)
9800 #ifndef OSF
9801 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9802 #endif
9803       implicit real*8 (a-h,o-z)
9804       include 'DIMENSIONS'
9805       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9806 c      DIMENSION AI3(2,2)
9807 c        DO  J=1,2
9808 c          A3IJ=0.0
9809 c          DO K=1,2
9810 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9811 c          enddo
9812 c          A3(I,J)=A3IJ
9813 c       enddo
9814 c      enddo
9815
9816       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9817       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9818       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9819       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9820
9821       A3(1,1)=AI3_11
9822       A3(2,1)=AI3_21
9823       A3(1,2)=AI3_12
9824       A3(2,2)=AI3_22
9825       END
9826
9827 c-------------------------------------------------------------------------
9828       double precision function scalar2(u,v)
9829 !DIR$ INLINEALWAYS scalar2
9830       implicit none
9831       double precision u(2),v(2)
9832       double precision sc
9833       integer i
9834       scalar2=u(1)*v(1)+u(2)*v(2)
9835       return
9836       end
9837
9838 C-----------------------------------------------------------------------------
9839
9840       subroutine transpose2(a,at)
9841 !DIR$ INLINEALWAYS transpose2
9842 #ifndef OSF
9843 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9844 #endif
9845       implicit none
9846       double precision a(2,2),at(2,2)
9847       at(1,1)=a(1,1)
9848       at(1,2)=a(2,1)
9849       at(2,1)=a(1,2)
9850       at(2,2)=a(2,2)
9851       return
9852       end
9853 c--------------------------------------------------------------------------
9854       subroutine transpose(n,a,at)
9855       implicit none
9856       integer n,i,j
9857       double precision a(n,n),at(n,n)
9858       do i=1,n
9859         do j=1,n
9860           at(j,i)=a(i,j)
9861         enddo
9862       enddo
9863       return
9864       end
9865 C---------------------------------------------------------------------------
9866       subroutine prodmat3(a1,a2,kk,transp,prod)
9867 !DIR$ INLINEALWAYS prodmat3
9868 #ifndef OSF
9869 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9870 #endif
9871       implicit none
9872       integer i,j
9873       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9874       logical transp
9875 crc      double precision auxmat(2,2),prod_(2,2)
9876
9877       if (transp) then
9878 crc        call transpose2(kk(1,1),auxmat(1,1))
9879 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9880 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9881
9882            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9883      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9884            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9885      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9886            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9887      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9888            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9889      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9890
9891       else
9892 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9893 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9894
9895            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9896      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9897            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9898      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9899            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9900      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9901            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9902      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9903
9904       endif
9905 c      call transpose2(a2(1,1),a2t(1,1))
9906
9907 crc      print *,transp
9908 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9909 crc      print *,((prod(i,j),i=1,2),j=1,2)
9910
9911       return
9912       end
9913