source/unres/src_MD/energy_p_new_barrier.F

   1       subroutine etotal(energia)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4 #ifndef ISNAN
   5       external proc_proc
   6 #ifdef WINPGI
   7 cMS$ATTRIBUTES C ::  proc_proc
   8 #endif
   9 #endif
  10 #ifdef MPI
  11       include "mpif.h"
  12       double precision weights_(n_ene)
  13 #endif
  14       include 'COMMON.SETUP'
  15       include 'COMMON.IOUNITS'
  16       double precision energia(0:n_ene)
  17       include 'COMMON.LOCAL'
  18       include 'COMMON.FFIELD'
  19       include 'COMMON.DERIV'
  20       include 'COMMON.INTERACT'
  21       include 'COMMON.SBRIDGE'
  22       include 'COMMON.CHAIN'
  23       include 'COMMON.VAR'
  24       include 'COMMON.MD'
  25       include 'COMMON.CONTROL'
  26       include 'COMMON.TIME1'
  27 #ifdef MPI
  28 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  29 c     & " nfgtasks",nfgtasks
  30       call flush(iout)
  31       if (nfgtasks.gt.1) then
  32 #ifdef MPI
  33         time00=MPI_Wtime()
  34 #else
  35         time00=tcpu()
  36 #endif
  37 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  38         if (fg_rank.eq.0) then
  39           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  40 c          print *,"Processor",myrank," BROADCAST iorder"
  41 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  42 C FG slaves as WEIGHTS array.
  43           weights_(1)=wsc
  44           weights_(2)=wscp
  45           weights_(3)=welec
  46           weights_(4)=wcorr
  47           weights_(5)=wcorr5
  48           weights_(6)=wcorr6
  49           weights_(7)=wel_loc
  50           weights_(8)=wturn3
  51           weights_(9)=wturn4
  52           weights_(10)=wturn6
  53           weights_(11)=wang
  54           weights_(12)=wscloc
  55           weights_(13)=wtor
  56           weights_(14)=wtor_d
  57           weights_(15)=wstrain
  58           weights_(16)=wvdwpp
  59           weights_(17)=wbond
  60           weights_(18)=scal14
  61           weights_(21)=wsccor
  62           weights_(22)=wsct
  63 C FG Master broadcasts the WEIGHTS_ array
  64           call MPI_Bcast(weights_(1),n_ene,
  65      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  66         else
  67 C FG slaves receive the WEIGHTS array
  68           call MPI_Bcast(weights(1),n_ene,
  69      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  70           wsc=weights(1)
  71           wscp=weights(2)
  72           welec=weights(3)
  73           wcorr=weights(4)
  74           wcorr5=weights(5)
  75           wcorr6=weights(6)
  76           wel_loc=weights(7)
  77           wturn3=weights(8)
  78           wturn4=weights(9)
  79           wturn6=weights(10)
  80           wang=weights(11)
  81           wscloc=weights(12)
  82           wtor=weights(13)
  83           wtor_d=weights(14)
  84           wstrain=weights(15)
  85           wvdwpp=weights(16)
  86           wbond=weights(17)
  87           scal14=weights(18)
  88           wsccor=weights(21)
  89           wsct=weights(22)
  90         endif
  91         time_Bcast=time_Bcast+MPI_Wtime()-time00
  92         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  93 c        call chainbuild_cart
  94       endif
  95 c      write(iout,*) 'Processor',myrank,' calling etotal ipot=',ipot
  96 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  97 #else
  98 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  99 c        call int_from_cart1(.false.)
 100 c      endif
 101 #endif
 102 #ifndef DFA
 103       edfadis=0.0d0
 104       edfator=0.0d0
 105       edfanei=0.0d0
 106       edfabet=0.0d0
 107 #endif
 108 #ifdef TIMING
 109 #ifdef MPI
 110       time00=MPI_Wtime()
 111 #else
 112       time00=tcpu()
 113 #endif
 114 #endif
 115 C
 116 C Compute the side-chain and electrostatic interaction energy
 117 C
 118       goto (101,102,103,104,105,106) ipot
 119 C Lennard-Jones potential.
 120   101 call elj(evdw,evdw_p,evdw_m)
 121 cd    print '(a)','Exit ELJ'
 122       goto 107
 123 C Lennard-Jones-Kihara potential (shifted).
 124   102 call eljk(evdw,evdw_p,evdw_m)
 125       goto 107
 126 C Berne-Pechukas potential (dilated LJ, angular dependence).
 127   103 call ebp(evdw,evdw_p,evdw_m)
 128       goto 107
 129 C Gay-Berne potential (shifted LJ, angular dependence).
 130   104 call egb(evdw,evdw_p,evdw_m)
 131       goto 107
 132 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 133   105 call egbv(evdw,evdw_p,evdw_m)
 134       goto 107
 135 C Soft-sphere potential
 136   106 call e_softsphere(evdw)
 137 C
 138 C Calculate electrostatic (H-bonding) energy of the main chain.
 139 C
 140   107 continue
 141 #ifdef DFA
 142 C     BARTEK for dfa test!
 143       if (wdfa_dist.gt.0) then
 144         call edfad(edfadis)
 145       else
 146         edfadis=0
 147       endif
 148 c      print*, 'edfad is finished!', edfadis
 149       if (wdfa_tor.gt.0) then
 150         call edfat(edfator)
 151       else
 152         edfator=0
 153       endif
 154 c      print*, 'edfat is finished!', edfator
 155       if (wdfa_nei.gt.0) then
 156         call edfan(edfanei)
 157       else
 158         edfanei=0
 159       endif
 160 c      print*, 'edfan is finished!', edfanei
 161       if (wdfa_beta.gt.0) then
 162         call edfab(edfabet)
 163       else
 164         edfabet=0
 165       endif
 166 #endif
 167 c      print*, 'edfab is finished!', edfabet
 168 cmc
 169 cmc Sep-06: egb takes care of dynamic ss bonds too
 170 cmc
 171 c      if (dyn_ss) call dyn_set_nss
 172
 173 c      print *,"Processor",myrank," computed USCSC"
 174 #ifdef TIMING
 175 #ifdef MPI
 176       time01=MPI_Wtime()
 177 #else
 178       time00=tcpu()
 179 #endif
 180 #endif
 181       call vec_and_deriv
 182 #ifdef TIMING
 183 #ifdef MPI
 184       time_vec=time_vec+MPI_Wtime()-time01
 185 #else
 186       time_vec=time_vec+tcpu()-time01
 187 #endif
 188 #endif
 189 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 190       if (ipot.lt.6) then
 191 #ifdef SPLITELE
 192          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 193      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 194      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 195      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 196 #else
 197          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 198      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 199      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 200      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 201 #endif
 202             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 203          else
 204             ees=0.0d0
 205             evdw1=0.0d0
 206             eel_loc=0.0d0
 207             eello_turn3=0.0d0
 208             eello_turn4=0.0d0
 209          endif
 210       else
 211 c        write (iout,*) "Soft-spheer ELEC potential"
 212         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 213      &   eello_turn4)
 214       endif
 215 c      print *,"Processor",myrank," computed UELEC"
 216 C
 217 C Calculate excluded-volume interaction energy between peptide groups
 218 C and side chains.
 219 C
 220       if (ipot.lt.6) then
 221        if(wscp.gt.0d0) then
 222         call escp(evdw2,evdw2_14)
 223        else
 224         evdw2=0
 225         evdw2_14=0
 226        endif
 227       else
 228 c        write (iout,*) "Soft-sphere SCP potential"
 229         call escp_soft_sphere(evdw2,evdw2_14)
 230       endif
 231 c
 232 c Calculate the bond-stretching energy
 233 c
 234       call ebond(estr)
 235 C
 236 C Calculate the disulfide-bridge and other energy and the contributions
 237 C from other distance constraints.
 238 cd    print *,'Calling EHPB'
 239       call edis(ehpb)
 240 cd    print *,'EHPB exitted succesfully.'
 241 C
 242 C Calculate the virtual-bond-angle energy.
 243 C
 244       if (wang.gt.0d0) then
 245         call ebend(ebe)
 246       else
 247         ebe=0
 248       endif
 249 c      print *,"Processor",myrank," computed UB"
 250 C
 251 C Calculate the SC local energy.
 252 C
 253       call esc(escloc)
 254 c      print *,"Processor",myrank," computed USC"
 255 C
 256 C Calculate the virtual-bond torsional energy.
 257 C
 258 cd    print *,'nterm=',nterm
 259       if (wtor.gt.0) then
 260        call etor(etors,edihcnstr)
 261       else
 262        etors=0
 263        edihcnstr=0
 264       endif
 265
 266       if (constr_homology.ge.1.and.waga_homology(iset).ne.0d0) then
 267         call e_modeller(ehomology_constr)
 268 c        print *,'iset=',iset,'me=',me,ehomology_constr,
 269 c     &  'Processor',fg_rank,' CG group',kolor,
 270 c     &  ' absolute rank',MyRank
 271       else
 272         ehomology_constr=0.0d0
 273       endif
 274
 275
 276 c      write(iout,*) ehomology_constr
 277 c      print *,"Processor",myrank," computed Utor"
 278 C
 279 C 6/23/01 Calculate double-torsional energy
 280 C
 281       if (wtor_d.gt.0) then
 282        call etor_d(etors_d)
 283       else
 284        etors_d=0
 285       endif
 286 c      print *,"Processor",myrank," computed Utord"
 287 C
 288 C 21/5/07 Calculate local sicdechain correlation energy
 289 C
 290       if (wsccor.gt.0.0d0) then
 291         call eback_sc_corr(esccor)
 292       else
 293         esccor=0.0d0
 294       endif
 295 c      print *,"Processor",myrank," computed Usccorr"
 296 C
 297 C 12/1/95 Multi-body terms
 298 C
 299       n_corr=0
 300       n_corr1=0
 301       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 302      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 303          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 304 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 305 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 306       else
 307          ecorr=0.0d0
 308          ecorr5=0.0d0
 309          ecorr6=0.0d0
 310          eturn6=0.0d0
 311       endif
 312       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 313          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 314 cd         write (iout,*) "multibody_hb ecorr",ecorr
 315       endif
 316 c      print *,"Processor",myrank," computed Ucorr"
 317 C
 318 C If performing constraint dynamics, call the constraint energy
 319 C  after the equilibration time
 320       if(usampl.and.totT.gt.eq_time) then
 321 c         write (iout,*) "CALL TO ECONSTR_BACK"
 322          call EconstrQ
 323          call Econstr_back
 324       else
 325          Uconst=0.0d0
 326          Uconst_back=0.0d0
 327       endif
 328 #ifdef TIMING
 329 #ifdef MPI
 330       time_enecalc=time_enecalc+MPI_Wtime()-time00
 331 #else
 332       time_enecalc=time_enecalc+tcpu()-time00
 333 #endif
 334 #endif
 335 c      print *,"Processor",myrank," computed Uconstr"
 336 #ifdef TIMING
 337 #ifdef MPI
 338       time00=MPI_Wtime()
 339 #else
 340       time00=tcpu()
 341 #endif
 342 #endif
 343 c
 344 C Sum the energies
 345 C
 346       energia(1)=evdw
 347 #ifdef SCP14
 348       energia(2)=evdw2-evdw2_14
 349       energia(18)=evdw2_14
 350 #else
 351       energia(2)=evdw2
 352       energia(18)=0.0d0
 353 #endif
 354 #ifdef SPLITELE
 355       energia(3)=ees
 356       energia(16)=evdw1
 357 #else
 358       energia(3)=ees+evdw1
 359       energia(16)=0.0d0
 360 #endif
 361       energia(4)=ecorr
 362       energia(5)=ecorr5
 363       energia(6)=ecorr6
 364       energia(7)=eel_loc
 365       energia(8)=eello_turn3
 366       energia(9)=eello_turn4
 367       energia(10)=eturn6
 368       energia(11)=ebe
 369       energia(12)=escloc
 370       energia(13)=etors
 371       energia(14)=etors_d
 372       energia(15)=ehpb
 373       energia(19)=edihcnstr
 374       energia(17)=estr
 375       energia(20)=Uconst+Uconst_back
 376       energia(21)=esccor
 377       energia(22)=evdw_p
 378       energia(23)=evdw_m
 379       energia(24)=ehomology_constr
 380       energia(25)=edfadis
 381       energia(26)=edfator
 382       energia(27)=edfanei
 383       energia(28)=edfabet
 384 c      print *," Processor",myrank," calls SUM_ENERGY"
 385       call sum_energy(energia,.true.)
 386       if (dyn_ss) call dyn_set_nss
 387 c      print *," Processor",myrank," left SUM_ENERGY"
 388 #ifdef TIMING
 389 #ifdef MPI
 390       time_sumene=time_sumene+MPI_Wtime()-time00
 391 #else
 392       time_sumene=time_sumene+tcpu()-time00
 393 #endif
 394 #endif
 395       return
 396       end
 397 c-------------------------------------------------------------------------------
 398       subroutine sum_energy(energia,reduce)
 399       implicit real*8 (a-h,o-z)
 400       include 'DIMENSIONS'
 401 #ifndef ISNAN
 402       external proc_proc
 403 #ifdef WINPGI
 404 cMS$ATTRIBUTES C ::  proc_proc
 405 #endif
 406 #endif
 407 #ifdef MPI
 408       include "mpif.h"
 409 #endif
 410       include 'COMMON.SETUP'
 411       include 'COMMON.IOUNITS'
 412       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 413       include 'COMMON.FFIELD'
 414       include 'COMMON.DERIV'
 415       include 'COMMON.INTERACT'
 416       include 'COMMON.SBRIDGE'
 417       include 'COMMON.CHAIN'
 418       include 'COMMON.VAR'
 419       include 'COMMON.CONTROL'
 420       include 'COMMON.TIME1'
 421       logical reduce
 422 #ifdef MPI
 423       if (nfgtasks.gt.1 .and. reduce) then
 424 #ifdef DEBUG
 425         write (iout,*) "energies before REDUCE"
 426         call enerprint(energia)
 427         call flush(iout)
 428 #endif
 429         do i=0,n_ene
 430           enebuff(i)=energia(i)
 431         enddo
 432         time00=MPI_Wtime()
 433         call MPI_Barrier(FG_COMM,IERR)
 434         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 435         time00=MPI_Wtime()
 436         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 437      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 438 #ifdef DEBUG
 439         write (iout,*) "energies after REDUCE"
 440         call enerprint(energia)
 441         call flush(iout)
 442 #endif
 443         time_Reduce=time_Reduce+MPI_Wtime()-time00
 444       endif
 445       if (fg_rank.eq.0) then
 446 #endif
 447 #ifdef TSCSC
 448       evdw=energia(22)+wsct*energia(23)
 449 #else
 450       evdw=energia(1)
 451 #endif
 452 #ifdef SCP14
 453       evdw2=energia(2)+energia(18)
 454       evdw2_14=energia(18)
 455 #else
 456       evdw2=energia(2)
 457 #endif
 458 #ifdef SPLITELE
 459       ees=energia(3)
 460       evdw1=energia(16)
 461 #else
 462       ees=energia(3)
 463       evdw1=0.0d0
 464 #endif
 465       ecorr=energia(4)
 466       ecorr5=energia(5)
 467       ecorr6=energia(6)
 468       eel_loc=energia(7)
 469       eello_turn3=energia(8)
 470       eello_turn4=energia(9)
 471       eturn6=energia(10)
 472       ebe=energia(11)
 473       escloc=energia(12)
 474       etors=energia(13)
 475       etors_d=energia(14)
 476       ehpb=energia(15)
 477       edihcnstr=energia(19)
 478       estr=energia(17)
 479       Uconst=energia(20)
 480       esccor=energia(21)
 481       ehomology_constr=energia(24)
 482       edfadis=energia(25)
 483       edfator=energia(26)
 484       edfanei=energia(27)
 485       edfabet=energia(28)
 486 #ifdef SPLITELE
 487       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 488      & +wang*ebe+wtor*etors+wscloc*escloc
 489      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 490      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 491      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 492      & +wbond*estr+Uconst+wsccor*esccor+ehomology_constr
 493      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 494      & +wdfa_beta*edfabet
 495 #else
 496       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 497      & +wang*ebe+wtor*etors+wscloc*escloc
 498      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 499      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 500      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 501      & +wbond*estr+Uconst+wsccor*esccor+ehomology_constr
 502      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 503      & +wdfa_beta*edfabet
 504 #endif
 505       energia(0)=etot
 506 c detecting NaNQ
 507 #ifdef ISNAN
 508 #ifdef AIX
 509       if (isnan(etot).ne.0) energia(0)=1.0d+99
 510 #else
 511       if (isnan(etot)) energia(0)=1.0d+99
 512 #endif
 513 #else
 514       i=0
 515 #ifdef WINPGI
 516       idumm=proc_proc(etot,i)
 517 #else
 518       call proc_proc(etot,i)
 519 #endif
 520       if(i.eq.1)energia(0)=1.0d+99
 521 #endif
 522 #ifdef MPI
 523       endif
 524 #endif
 525       return
 526       end
 527 c-------------------------------------------------------------------------------
 528       subroutine sum_gradient
 529       implicit real*8 (a-h,o-z)
 530       include 'DIMENSIONS'
 531 #ifndef ISNAN
 532       external proc_proc
 533 #ifdef WINPGI
 534 cMS$ATTRIBUTES C ::  proc_proc
 535 #endif
 536 #endif
 537 #ifdef MPI
 538       include 'mpif.h'
 539 #endif
 540       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 541      &  glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres)
 542       include 'COMMON.SETUP'
 543       include 'COMMON.IOUNITS'
 544       include 'COMMON.FFIELD'
 545       include 'COMMON.DERIV'
 546       include 'COMMON.INTERACT'
 547       include 'COMMON.SBRIDGE'
 548       include 'COMMON.CHAIN'
 549       include 'COMMON.VAR'
 550       include 'COMMON.CONTROL'
 551       include 'COMMON.TIME1'
 552       include 'COMMON.MAXGRAD'
 553       include 'COMMON.SCCOR'
 554       include 'COMMON.MD'
 555 #ifdef TIMING
 556 #ifdef MPI
 557       time01=MPI_Wtime()
 558 #else
 559       time01=tcpu()
 560 #endif
 561 #endif
 562 #ifdef DEBUG
 563       write (iout,*) "sum_gradient gvdwc, gvdwx"
 564       do i=1,nres
 565         write (iout,'(i3,3f10.5,5x,3f10.5,5x,3f10.5,5x,3f10.5)')
 566      &   i,(gvdwx(j,i),j=1,3),(gvdwcT(j,i),j=1,3),(gvdwc(j,i),j=1,3),
 567      &   (gvdwcT(j,i),j=1,3)
 568       enddo
 569       call flush(iout)
 570 #endif
 571 #ifdef MPI
 572 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 573         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 574      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 575 #endif
 576 C
 577 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 578 C            in virtual-bond-vector coordinates
 579 C
 580 #ifdef DEBUG
 581 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 582 c      do i=1,nres-1
 583 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 584 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 585 c      enddo
 586 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 587 c      do i=1,nres-1
 588 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 589 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 590 c      enddo
 591       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 592       do i=1,nres
 593         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 594      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 595      &   g_corr5_loc(i)
 596       enddo
 597       call flush(iout)
 598 #endif
 599 #ifdef SPLITELE
 600 #ifdef TSCSC
 601       do i=1,nct
 602         do j=1,3
 603           gradbufc(j,i)=wsc*gvdwc(j,i)+wsc*wscT*gvdwcT(j,i)+
 604      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 605      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 606      &                wel_loc*gel_loc_long(j,i)+
 607      &                wcorr*gradcorr_long(j,i)+
 608      &                wcorr5*gradcorr5_long(j,i)+
 609      &                wcorr6*gradcorr6_long(j,i)+
 610      &                wturn6*gcorr6_turn_long(j,i)+
 611      &                wstrain*ghpbc(j,i)+
 612      &                wdfa_dist*gdfad(j,i)+
 613      &                wdfa_tor*gdfat(j,i)+
 614      &                wdfa_nei*gdfan(j,i)+
 615      &                wdfa_beta*gdfab(j,i)
 616         enddo
 617       enddo
 618 #else
 619       do i=1,nct
 620         do j=1,3
 621           gradbufc(j,i)=wsc*gvdwc(j,i)+
 622      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 623      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 624      &                wel_loc*gel_loc_long(j,i)+
 625      &                wcorr*gradcorr_long(j,i)+
 626      &                wcorr5*gradcorr5_long(j,i)+
 627      &                wcorr6*gradcorr6_long(j,i)+
 628      &                wturn6*gcorr6_turn_long(j,i)+
 629      &                wstrain*ghpbc(j,i)+
 630      &                wdfa_dist*gdfad(j,i)+
 631      &                wdfa_tor*gdfat(j,i)+
 632      &                wdfa_nei*gdfan(j,i)+
 633      &                wdfa_beta*gdfab(j,i)
 634         enddo
 635       enddo
 636 #endif
 637 #else
 638       do i=1,nct
 639         do j=1,3
 640           gradbufc(j,i)=wsc*gvdwc(j,i)+
 641      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 642      &                welec*gelc_long(j,i)+
 643      &                wbond*gradb(j,i)+
 644      &                wel_loc*gel_loc_long(j,i)+
 645      &                wcorr*gradcorr_long(j,i)+
 646      &                wcorr5*gradcorr5_long(j,i)+
 647      &                wcorr6*gradcorr6_long(j,i)+
 648      &                wturn6*gcorr6_turn_long(j,i)+
 649      &                wstrain*ghpbc(j,i)+
 650      &                wdfa_dist*gdfad(j,i)+
 651      &                wdfa_tor*gdfat(j,i)+
 652      &                wdfa_nei*gdfan(j,i)+
 653      &                wdfa_beta*gdfab(j,i)
 654         enddo
 655       enddo
 656 #endif
 657 #ifdef MPI
 658       if (nfgtasks.gt.1) then
 659       time00=MPI_Wtime()
 660 #ifdef DEBUG
 661       write (iout,*) "gradbufc before allreduce"
 662       do i=1,nres
 663         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 664       enddo
 665       call flush(iout)
 666 #endif
 667       do i=1,nres
 668         do j=1,3
 669           gradbufc_sum(j,i)=gradbufc(j,i)
 670         enddo
 671       enddo
 672 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 673 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 674 c      time_reduce=time_reduce+MPI_Wtime()-time00
 675 #ifdef DEBUG
 676 c      write (iout,*) "gradbufc_sum after allreduce"
 677 c      do i=1,nres
 678 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 679 c      enddo
 680 c      call flush(iout)
 681 #endif
 682 #ifdef TIMING
 683 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 684 #endif
 685       do i=nnt,nres
 686         do k=1,3
 687           gradbufc(k,i)=0.0d0
 688         enddo
 689       enddo
 690 #ifdef DEBUG
 691       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 692       write (iout,*) (i," jgrad_start",jgrad_start(i),
 693      &                  " jgrad_end  ",jgrad_end(i),
 694      &                  i=igrad_start,igrad_end)
 695 #endif
 696 c
 697 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 698 c do not parallelize this part.
 699 c
 700 c      do i=igrad_start,igrad_end
 701 c        do j=jgrad_start(i),jgrad_end(i)
 702 c          do k=1,3
 703 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 704 c          enddo
 705 c        enddo
 706 c      enddo
 707       do j=1,3
 708         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 709       enddo
 710       do i=nres-2,nnt,-1
 711         do j=1,3
 712           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 713         enddo
 714       enddo
 715 #ifdef DEBUG
 716       write (iout,*) "gradbufc after summing"
 717       do i=1,nres
 718         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 719       enddo
 720       call flush(iout)
 721 #endif
 722       else
 723 #endif
 724 #ifdef DEBUG
 725       write (iout,*) "gradbufc"
 726       do i=1,nres
 727         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 728       enddo
 729       call flush(iout)
 730 #endif
 731       do i=1,nres
 732         do j=1,3
 733           gradbufc_sum(j,i)=gradbufc(j,i)
 734           gradbufc(j,i)=0.0d0
 735         enddo
 736       enddo
 737       do j=1,3
 738         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 739       enddo
 740       do i=nres-2,nnt,-1
 741         do j=1,3
 742           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 743         enddo
 744       enddo
 745 c      do i=nnt,nres-1
 746 c        do k=1,3
 747 c          gradbufc(k,i)=0.0d0
 748 c        enddo
 749 c        do j=i+1,nres
 750 c          do k=1,3
 751 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 752 c          enddo
 753 c        enddo
 754 c      enddo
 755 #ifdef DEBUG
 756       write (iout,*) "gradbufc after summing"
 757       do i=1,nres
 758         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 759       enddo
 760       call flush(iout)
 761 #endif
 762 #ifdef MPI
 763       endif
 764 #endif
 765       do k=1,3
 766         gradbufc(k,nres)=0.0d0
 767       enddo
 768       do i=1,nct
 769         do j=1,3
 770 #ifdef SPLITELE
 771           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 772      &                wel_loc*gel_loc(j,i)+
 773      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 774      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 775      &                wel_loc*gel_loc_long(j,i)+
 776      &                wcorr*gradcorr_long(j,i)+
 777      &                wcorr5*gradcorr5_long(j,i)+
 778      &                wcorr6*gradcorr6_long(j,i)+
 779      &                wturn6*gcorr6_turn_long(j,i))+
 780      &                wbond*gradb(j,i)+
 781      &                wcorr*gradcorr(j,i)+
 782      &                wturn3*gcorr3_turn(j,i)+
 783      &                wturn4*gcorr4_turn(j,i)+
 784      &                wcorr5*gradcorr5(j,i)+
 785      &                wcorr6*gradcorr6(j,i)+
 786      &                wturn6*gcorr6_turn(j,i)+
 787      &                wsccor*gsccorc(j,i)
 788      &               +wscloc*gscloc(j,i)
 789 #else
 790           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 791      &                wel_loc*gel_loc(j,i)+
 792      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 793      &                welec*gelc_long(j,i)+
 794      &                wel_loc*gel_loc_long(j,i)+
 795      &                wcorr*gcorr_long(j,i)+
 796      &                wcorr5*gradcorr5_long(j,i)+
 797      &                wcorr6*gradcorr6_long(j,i)+
 798      &                wturn6*gcorr6_turn_long(j,i))+
 799      &                wbond*gradb(j,i)+
 800      &                wcorr*gradcorr(j,i)+
 801      &                wturn3*gcorr3_turn(j,i)+
 802      &                wturn4*gcorr4_turn(j,i)+
 803      &                wcorr5*gradcorr5(j,i)+
 804      &                wcorr6*gradcorr6(j,i)+
 805      &                wturn6*gcorr6_turn(j,i)+
 806      &                wsccor*gsccorc(j,i)
 807      &               +wscloc*gscloc(j,i)
 808 #endif
 809 #ifdef TSCSC
 810           gradx(j,i,icg)=wsc*gvdwx(j,i)+wsc*wscT*gvdwxT(j,i)+
 811      &                  wscp*gradx_scp(j,i)+
 812      &                  wbond*gradbx(j,i)+
 813      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 814      &                  wsccor*gsccorx(j,i)
 815      &                 +wscloc*gsclocx(j,i)
 816 #else
 817           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 818      &                  wbond*gradbx(j,i)+
 819      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 820      &                  wsccor*gsccorx(j,i)
 821      &                 +wscloc*gsclocx(j,i)
 822 #endif
 823         enddo
 824       enddo
 825       if (constr_homology.gt.0.and.waga_homology(iset).ne.0d0) then
 826         do i=1,nct
 827           do j=1,3
 828             gradc(j,i,icg)=gradc(j,i,icg)+duscdiff(j,i)
 829             gradx(j,i,icg)=gradx(j,i,icg)+duscdiffx(j,i)
 830           enddo
 831         enddo
 832       endif
 833 #ifdef DEBUG
 834       write (iout,*) "gloc before adding corr"
 835       do i=1,4*nres
 836         write (iout,*) i,gloc(i,icg)
 837       enddo
 838 #endif
 839       do i=1,nres-3
 840         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 841      &   +wcorr5*g_corr5_loc(i)
 842      &   +wcorr6*g_corr6_loc(i)
 843      &   +wturn4*gel_loc_turn4(i)
 844      &   +wturn3*gel_loc_turn3(i)
 845      &   +wturn6*gel_loc_turn6(i)
 846      &   +wel_loc*gel_loc_loc(i)
 847       enddo
 848 #ifdef DEBUG
 849       write (iout,*) "gloc after adding corr"
 850       do i=1,4*nres
 851         write (iout,*) i,gloc(i,icg)
 852       enddo
 853 #endif
 854 #ifdef MPI
 855       if (nfgtasks.gt.1) then
 856         do j=1,3
 857           do i=1,nres
 858             gradbufc(j,i)=gradc(j,i,icg)
 859             gradbufx(j,i)=gradx(j,i,icg)
 860           enddo
 861         enddo
 862         do i=1,4*nres
 863           glocbuf(i)=gloc(i,icg)
 864         enddo
 865 #ifdef DEBUG
 866       write (iout,*) "gloc_sc before reduce"
 867       do i=1,nres
 868        do j=1,3
 869         write (iout,*) i,j,gloc_sc(j,i,icg)
 870        enddo
 871       enddo
 872 #endif
 873         do i=1,nres
 874          do j=1,3
 875           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 876          enddo
 877         enddo
 878         time00=MPI_Wtime()
 879         call MPI_Barrier(FG_COMM,IERR)
 880         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 881         time00=MPI_Wtime()
 882         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 883      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 884         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 885      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 886         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 887      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 888         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 889      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 890         time_reduce=time_reduce+MPI_Wtime()-time00
 891 #ifdef DEBUG
 892       write (iout,*) "gloc_sc after reduce"
 893       do i=1,nres
 894        do j=1,3
 895         write (iout,*) i,j,gloc_sc(j,i,icg)
 896        enddo
 897       enddo
 898 #endif
 899 #ifdef DEBUG
 900       write (iout,*) "gloc after reduce"
 901       do i=1,4*nres
 902         write (iout,*) i,gloc(i,icg)
 903       enddo
 904 #endif
 905       endif
 906 #endif
 907       if (gnorm_check) then
 908 c
 909 c Compute the maximum elements of the gradient
 910 c
 911       gvdwc_max=0.0d0
 912       gvdwc_scp_max=0.0d0
 913       gelc_max=0.0d0
 914       gvdwpp_max=0.0d0
 915       gradb_max=0.0d0
 916       ghpbc_max=0.0d0
 917       gradcorr_max=0.0d0
 918       gel_loc_max=0.0d0
 919       gcorr3_turn_max=0.0d0
 920       gcorr4_turn_max=0.0d0
 921       gradcorr5_max=0.0d0
 922       gradcorr6_max=0.0d0
 923       gcorr6_turn_max=0.0d0
 924       gsccorc_max=0.0d0
 925       gscloc_max=0.0d0
 926       gvdwx_max=0.0d0
 927       gradx_scp_max=0.0d0
 928       ghpbx_max=0.0d0
 929       gradxorr_max=0.0d0
 930       gsccorx_max=0.0d0
 931       gsclocx_max=0.0d0
 932       do i=1,nct
 933         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 934         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 935 #ifdef TSCSC
 936         gvdwc_norm=dsqrt(scalar(gvdwcT(1,i),gvdwcT(1,i)))
 937         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 938 #endif
 939         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 940         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 941      &   gvdwc_scp_max=gvdwc_scp_norm
 942         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 943         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 944         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 945         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 946         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 947         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 948         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 949         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 950         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 951         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 952         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 953         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 954         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 955      &    gcorr3_turn(1,i)))
 956         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 957      &    gcorr3_turn_max=gcorr3_turn_norm
 958         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 959      &    gcorr4_turn(1,i)))
 960         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 961      &    gcorr4_turn_max=gcorr4_turn_norm
 962         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 963         if (gradcorr5_norm.gt.gradcorr5_max)
 964      &    gradcorr5_max=gradcorr5_norm
 965         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 966         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 967         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 968      &    gcorr6_turn(1,i)))
 969         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 970      &    gcorr6_turn_max=gcorr6_turn_norm
 971         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 972         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 973         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 974         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 975         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 976         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 977 #ifdef TSCSC
 978         gvdwx_norm=dsqrt(scalar(gvdwxT(1,i),gvdwxT(1,i)))
 979         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 980 #endif
 981         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 982         if (gradx_scp_norm.gt.gradx_scp_max)
 983      &    gradx_scp_max=gradx_scp_norm
 984         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 985         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 986         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 987         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 988         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 989         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 990         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 991         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 992       enddo
 993       if (gradout) then
 994 #ifdef AIX
 995         open(istat,file=statname,position="append")
 996 #else
 997         open(istat,file=statname,access="append")
 998 #endif
 999         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
1000      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
1001      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
1002      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
1003      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
1004      &     gsccorx_max,gsclocx_max
1005         close(istat)
1006         if (gvdwc_max.gt.1.0d4) then
1007           write (iout,*) "gvdwc gvdwx gradb gradbx"
1008           do i=nnt,nct
1009             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
1010      &        gradb(j,i),gradbx(j,i),j=1,3)
1011           enddo
1012           call pdbout(0.0d0,'cipiszcze',iout)
1013           call flush(iout)
1014         endif
1015       endif
1016       endif
1017 #ifdef DEBUG
1018       write (iout,*) "gradc gradx gloc"
1019       do i=1,nres
1020         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
1021      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
1022       enddo
1023 #endif
1024 #ifdef TIMING
1025 #ifdef MPI
1026       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
1027 #else
1028       time_sumgradient=time_sumgradient+tcpu()-time01
1029 #endif
1030 #endif
1031       return
1032       end
1033 c-------------------------------------------------------------------------------
1034       subroutine rescale_weights(t_bath)
1035       implicit real*8 (a-h,o-z)
1036       include 'DIMENSIONS'
1037       include 'COMMON.IOUNITS'
1038       include 'COMMON.FFIELD'
1039       include 'COMMON.SBRIDGE'
1040       double precision kfac /2.4d0/
1041       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
1042 c      facT=temp0/t_bath
1043 c      facT=2*temp0/(t_bath+temp0)
1044       if (rescale_mode.eq.0) then
1045         facT=1.0d0
1046         facT2=1.0d0
1047         facT3=1.0d0
1048         facT4=1.0d0
1049         facT5=1.0d0
1050       else if (rescale_mode.eq.1) then
1051         facT=kfac/(kfac-1.0d0+t_bath/temp0)
1052         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1053         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1054         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1055         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1056       else if (rescale_mode.eq.2) then
1057         x=t_bath/temp0
1058         x2=x*x
1059         x3=x2*x
1060         x4=x3*x
1061         x5=x4*x
1062         facT=licznik/dlog(dexp(x)+dexp(-x))
1063         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
1064         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
1065         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
1066         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
1067       else
1068         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1069         write (*,*) "Wrong RESCALE_MODE",rescale_mode
1070 #ifdef MPI
1071        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1072 #endif
1073        stop 555
1074       endif
1075       welec=weights(3)*fact
1076       wcorr=weights(4)*fact3
1077       wcorr5=weights(5)*fact4
1078       wcorr6=weights(6)*fact5
1079       wel_loc=weights(7)*fact2
1080       wturn3=weights(8)*fact2
1081       wturn4=weights(9)*fact3
1082       wturn6=weights(10)*fact5
1083       wtor=weights(13)*fact
1084       wtor_d=weights(14)*fact2
1085       wsccor=weights(21)*fact
1086 #ifdef TSCSC
1087 c      wsct=t_bath/temp0
1088       wsct=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
1089 #endif
1090       return
1091       end
1092 C------------------------------------------------------------------------
1093       subroutine enerprint(energia)
1094       implicit real*8 (a-h,o-z)
1095       include 'DIMENSIONS'
1096       include 'COMMON.IOUNITS'
1097       include 'COMMON.FFIELD'
1098       include 'COMMON.SBRIDGE'
1099       include 'COMMON.MD'
1100       double precision energia(0:n_ene)
1101       etot=energia(0)
1102 #ifdef TSCSC
1103       evdw=energia(22)+wsct*energia(23)
1104 #else
1105       evdw=energia(1)
1106 #endif
1107       evdw2=energia(2)
1108 #ifdef SCP14
1109       evdw2=energia(2)+energia(18)
1110 #else
1111       evdw2=energia(2)
1112 #endif
1113       ees=energia(3)
1114 #ifdef SPLITELE
1115       evdw1=energia(16)
1116 #endif
1117       ecorr=energia(4)
1118       ecorr5=energia(5)
1119       ecorr6=energia(6)
1120       eel_loc=energia(7)
1121       eello_turn3=energia(8)
1122       eello_turn4=energia(9)
1123       eello_turn6=energia(10)
1124       ebe=energia(11)
1125       escloc=energia(12)
1126       etors=energia(13)
1127       etors_d=energia(14)
1128       ehpb=energia(15)
1129       edihcnstr=energia(19)
1130       estr=energia(17)
1131       Uconst=energia(20)
1132       esccor=energia(21)
1133       ehomology_constr=energia(24)
1134 C     Bartek
1135       edfadis = energia(25)
1136       edfator = energia(26)
1137       edfanei = energia(27)
1138       edfabet = energia(28)
1139
1140 #ifdef SPLITELE
1141       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1142      &  estr,wbond,ebe,wang,
1143      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1144      &  ecorr,wcorr,
1145      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1146      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
1147      &  edihcnstr,ehomology_constr, ebr*nss,
1148      &  Uconst,edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
1149      &  edfabet,wdfa_beta,etot
1150    10 format (/'Virtual-chain energies:'//
1151      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
1152      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
1153      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
1154      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pE16.6,' (p-p VDW)'/
1155      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
1156      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
1157      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
1158      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
1159      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
1160      & 'EHPB=  ',1pE16.6,' WEIGHT=',1pE16.6,
1161      & ' (SS bridges & dist. cnstr.)'/
1162      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1163      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1164      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1165      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
1166      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
1167      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
1168      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
1169      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
1170      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1171      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1172      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1173      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1174      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
1175      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
1176      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
1177      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
1178      & 'ETOT=  ',1pE16.6,' (total)')
1179 #else
1180       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1181      &  estr,wbond,ebe,wang,
1182      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1183      &  ecorr,wcorr,
1184      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1185      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1186      &  ehomology_constr,ebr*nss,Uconst,edfadis,wdfa_dist,edfator,
1187      &  wdfa_tor,edfanei,wdfa_nei,edfabet,wdfa_beta,
1188      &  etot
1189    10 format (/'Virtual-chain energies:'//
1190      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1191      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1192      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1193      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1194      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1195      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1196      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1197      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1198      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1199      & ' (SS bridges & dist. cnstr.)'/
1200      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1201      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1202      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1203      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1204      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1205      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1206      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1207      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1208      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1209      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1210      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1211      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1212      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA distance energy)'/
1213      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA torsion energy)'/
1214      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA NCa energy)'/
1215      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA Beta energy)'/
1216      & 'ETOT=  ',1pE16.6,' (total)')
1217 #endif
1218       return
1219       end
1220 C-----------------------------------------------------------------------
1221       subroutine elj(evdw,evdw_p,evdw_m)
1222 C
1223 C This subroutine calculates the interaction energy of nonbonded side chains
1224 C assuming the LJ potential of interaction.
1225 C
1226       implicit real*8 (a-h,o-z)
1227       include 'DIMENSIONS'
1228       parameter (accur=1.0d-10)
1229       include 'COMMON.GEO'
1230       include 'COMMON.VAR'
1231       include 'COMMON.LOCAL'
1232       include 'COMMON.CHAIN'
1233       include 'COMMON.DERIV'
1234       include 'COMMON.INTERACT'
1235       include 'COMMON.TORSION'
1236       include 'COMMON.SBRIDGE'
1237       include 'COMMON.NAMES'
1238       include 'COMMON.IOUNITS'
1239       include 'COMMON.CONTACTS'
1240       dimension gg(3)
1241 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1242       evdw=0.0D0
1243       do i=iatsc_s,iatsc_e
1244         itypi=itype(i)
1245         itypi1=itype(i+1)
1246         xi=c(1,nres+i)
1247         yi=c(2,nres+i)
1248         zi=c(3,nres+i)
1249 C Change 12/1/95
1250         num_conti=0
1251 C
1252 C Calculate SC interaction energy.
1253 C
1254         do iint=1,nint_gr(i)
1255 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1256 cd   &                  'iend=',iend(i,iint)
1257           do j=istart(i,iint),iend(i,iint)
1258             itypj=itype(j)
1259             xj=c(1,nres+j)-xi
1260             yj=c(2,nres+j)-yi
1261             zj=c(3,nres+j)-zi
1262 C Change 12/1/95 to calculate four-body interactions
1263             rij=xj*xj+yj*yj+zj*zj
1264             rrij=1.0D0/rij
1265 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1266             eps0ij=eps(itypi,itypj)
1267             fac=rrij**expon2
1268             e1=fac*fac*aa(itypi,itypj)
1269             e2=fac*bb(itypi,itypj)
1270             evdwij=e1+e2
1271 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1272 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1273 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1274 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1275 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1276 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1277 #ifdef TSCSC
1278             if (bb(itypi,itypj).gt.0) then
1279                evdw_p=evdw_p+evdwij
1280             else
1281                evdw_m=evdw_m+evdwij
1282             endif
1283 #else
1284             evdw=evdw+evdwij
1285 #endif
1286 C
1287 C Calculate the components of the gradient in DC and X
1288 C
1289             fac=-rrij*(e1+evdwij)
1290             gg(1)=xj*fac
1291             gg(2)=yj*fac
1292             gg(3)=zj*fac
1293 #ifdef TSCSC
1294             if (bb(itypi,itypj).gt.0.0d0) then
1295               do k=1,3
1296                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1297                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1298                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1299                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1300               enddo
1301             else
1302               do k=1,3
1303                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1304                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1305                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1306                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1307               enddo
1308             endif
1309 #else
1310             do k=1,3
1311               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1312               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1313               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1314               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1315             enddo
1316 #endif
1317 cgrad            do k=i,j-1
1318 cgrad              do l=1,3
1319 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1320 cgrad              enddo
1321 cgrad            enddo
1322 C
1323 C 12/1/95, revised on 5/20/97
1324 C
1325 C Calculate the contact function. The ith column of the array JCONT will
1326 C contain the numbers of atoms that make contacts with the atom I (of numbers
1327 C greater than I). The arrays FACONT and GACONT will contain the values of
1328 C the contact function and its derivative.
1329 C
1330 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1331 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1332 C Uncomment next line, if the correlation interactions are contact function only
1333             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1334               rij=dsqrt(rij)
1335               sigij=sigma(itypi,itypj)
1336               r0ij=rs0(itypi,itypj)
1337 C
1338 C Check whether the SC's are not too far to make a contact.
1339 C
1340               rcut=1.5d0*r0ij
1341               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1342 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1343 C
1344               if (fcont.gt.0.0D0) then
1345 C If the SC-SC distance if close to sigma, apply spline.
1346 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1347 cAdam &             fcont1,fprimcont1)
1348 cAdam           fcont1=1.0d0-fcont1
1349 cAdam           if (fcont1.gt.0.0d0) then
1350 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1351 cAdam             fcont=fcont*fcont1
1352 cAdam           endif
1353 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1354 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1355 cga             do k=1,3
1356 cga               gg(k)=gg(k)*eps0ij
1357 cga             enddo
1358 cga             eps0ij=-evdwij*eps0ij
1359 C Uncomment for AL's type of SC correlation interactions.
1360 cadam           eps0ij=-evdwij
1361                 num_conti=num_conti+1
1362                 jcont(num_conti,i)=j
1363                 facont(num_conti,i)=fcont*eps0ij
1364                 fprimcont=eps0ij*fprimcont/rij
1365                 fcont=expon*fcont
1366 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1367 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1368 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1369 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1370                 gacont(1,num_conti,i)=-fprimcont*xj
1371                 gacont(2,num_conti,i)=-fprimcont*yj
1372                 gacont(3,num_conti,i)=-fprimcont*zj
1373 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1374 cd              write (iout,'(2i3,3f10.5)')
1375 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1376               endif
1377             endif
1378           enddo      ! j
1379         enddo        ! iint
1380 C Change 12/1/95
1381         num_cont(i)=num_conti
1382       enddo          ! i
1383       do i=1,nct
1384         do j=1,3
1385           gvdwc(j,i)=expon*gvdwc(j,i)
1386           gvdwx(j,i)=expon*gvdwx(j,i)
1387         enddo
1388       enddo
1389 C******************************************************************************
1390 C
1391 C                              N O T E !!!
1392 C
1393 C To save time, the factor of EXPON has been extracted from ALL components
1394 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1395 C use!
1396 C
1397 C******************************************************************************
1398       return
1399       end
1400 C-----------------------------------------------------------------------------
1401       subroutine eljk(evdw,evdw_p,evdw_m)
1402 C
1403 C This subroutine calculates the interaction energy of nonbonded side chains
1404 C assuming the LJK potential of interaction.
1405 C
1406       implicit real*8 (a-h,o-z)
1407       include 'DIMENSIONS'
1408       include 'COMMON.GEO'
1409       include 'COMMON.VAR'
1410       include 'COMMON.LOCAL'
1411       include 'COMMON.CHAIN'
1412       include 'COMMON.DERIV'
1413       include 'COMMON.INTERACT'
1414       include 'COMMON.IOUNITS'
1415       include 'COMMON.NAMES'
1416       dimension gg(3)
1417       logical scheck
1418 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1419       evdw=0.0D0
1420       do i=iatsc_s,iatsc_e
1421         itypi=itype(i)
1422         itypi1=itype(i+1)
1423         xi=c(1,nres+i)
1424         yi=c(2,nres+i)
1425         zi=c(3,nres+i)
1426 C
1427 C Calculate SC interaction energy.
1428 C
1429         do iint=1,nint_gr(i)
1430           do j=istart(i,iint),iend(i,iint)
1431             itypj=itype(j)
1432             xj=c(1,nres+j)-xi
1433             yj=c(2,nres+j)-yi
1434             zj=c(3,nres+j)-zi
1435             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1436             fac_augm=rrij**expon
1437             e_augm=augm(itypi,itypj)*fac_augm
1438             r_inv_ij=dsqrt(rrij)
1439             rij=1.0D0/r_inv_ij
1440             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1441             fac=r_shift_inv**expon
1442             e1=fac*fac*aa(itypi,itypj)
1443             e2=fac*bb(itypi,itypj)
1444             evdwij=e_augm+e1+e2
1445 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1446 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1447 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1448 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1449 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1450 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1451 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1452 #ifdef TSCSC
1453             if (bb(itypi,itypj).gt.0) then
1454                evdw_p=evdw_p+evdwij
1455             else
1456                evdw_m=evdw_m+evdwij
1457             endif
1458 #else
1459             evdw=evdw+evdwij
1460 #endif
1461 C
1462 C Calculate the components of the gradient in DC and X
1463 C
1464             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1465             gg(1)=xj*fac
1466             gg(2)=yj*fac
1467             gg(3)=zj*fac
1468 #ifdef TSCSC
1469             if (bb(itypi,itypj).gt.0.0d0) then
1470               do k=1,3
1471                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1472                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1473                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1474                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1475               enddo
1476             else
1477               do k=1,3
1478                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1479                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1480                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1481                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1482               enddo
1483             endif
1484 #else
1485             do k=1,3
1486               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1487               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1488               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1489               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1490             enddo
1491 #endif
1492 cgrad            do k=i,j-1
1493 cgrad              do l=1,3
1494 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1495 cgrad              enddo
1496 cgrad            enddo
1497           enddo      ! j
1498         enddo        ! iint
1499       enddo          ! i
1500       do i=1,nct
1501         do j=1,3
1502           gvdwc(j,i)=expon*gvdwc(j,i)
1503           gvdwx(j,i)=expon*gvdwx(j,i)
1504         enddo
1505       enddo
1506       return
1507       end
1508 C-----------------------------------------------------------------------------
1509       subroutine ebp(evdw,evdw_p,evdw_m)
1510 C
1511 C This subroutine calculates the interaction energy of nonbonded side chains
1512 C assuming the Berne-Pechukas potential of interaction.
1513 C
1514       implicit real*8 (a-h,o-z)
1515       include 'DIMENSIONS'
1516       include 'COMMON.GEO'
1517       include 'COMMON.VAR'
1518       include 'COMMON.LOCAL'
1519       include 'COMMON.CHAIN'
1520       include 'COMMON.DERIV'
1521       include 'COMMON.NAMES'
1522       include 'COMMON.INTERACT'
1523       include 'COMMON.IOUNITS'
1524       include 'COMMON.CALC'
1525       common /srutu/ icall
1526 c     double precision rrsave(maxdim)
1527       logical lprn
1528       evdw=0.0D0
1529 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1530       evdw=0.0D0
1531 c     if (icall.eq.0) then
1532 c       lprn=.true.
1533 c     else
1534         lprn=.false.
1535 c     endif
1536       ind=0
1537       do i=iatsc_s,iatsc_e
1538         itypi=itype(i)
1539         itypi1=itype(i+1)
1540         xi=c(1,nres+i)
1541         yi=c(2,nres+i)
1542         zi=c(3,nres+i)
1543         dxi=dc_norm(1,nres+i)
1544         dyi=dc_norm(2,nres+i)
1545         dzi=dc_norm(3,nres+i)
1546 c        dsci_inv=dsc_inv(itypi)
1547         dsci_inv=vbld_inv(i+nres)
1548 C
1549 C Calculate SC interaction energy.
1550 C
1551         do iint=1,nint_gr(i)
1552           do j=istart(i,iint),iend(i,iint)
1553             ind=ind+1
1554             itypj=itype(j)
1555 c            dscj_inv=dsc_inv(itypj)
1556             dscj_inv=vbld_inv(j+nres)
1557             chi1=chi(itypi,itypj)
1558             chi2=chi(itypj,itypi)
1559             chi12=chi1*chi2
1560             chip1=chip(itypi)
1561             chip2=chip(itypj)
1562             chip12=chip1*chip2
1563             alf1=alp(itypi)
1564             alf2=alp(itypj)
1565             alf12=0.5D0*(alf1+alf2)
1566 C For diagnostics only!!!
1567 c           chi1=0.0D0
1568 c           chi2=0.0D0
1569 c           chi12=0.0D0
1570 c           chip1=0.0D0
1571 c           chip2=0.0D0
1572 c           chip12=0.0D0
1573 c           alf1=0.0D0
1574 c           alf2=0.0D0
1575 c           alf12=0.0D0
1576             xj=c(1,nres+j)-xi
1577             yj=c(2,nres+j)-yi
1578             zj=c(3,nres+j)-zi
1579             dxj=dc_norm(1,nres+j)
1580             dyj=dc_norm(2,nres+j)
1581             dzj=dc_norm(3,nres+j)
1582             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1583 cd          if (icall.eq.0) then
1584 cd            rrsave(ind)=rrij
1585 cd          else
1586 cd            rrij=rrsave(ind)
1587 cd          endif
1588             rij=dsqrt(rrij)
1589 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1590             call sc_angular
1591 C Calculate whole angle-dependent part of epsilon and contributions
1592 C to its derivatives
1593             fac=(rrij*sigsq)**expon2
1594             e1=fac*fac*aa(itypi,itypj)
1595             e2=fac*bb(itypi,itypj)
1596             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1597             eps2der=evdwij*eps3rt
1598             eps3der=evdwij*eps2rt
1599             evdwij=evdwij*eps2rt*eps3rt
1600 #ifdef TSCSC
1601             if (bb(itypi,itypj).gt.0) then
1602                evdw_p=evdw_p+evdwij
1603             else
1604                evdw_m=evdw_m+evdwij
1605             endif
1606 #else
1607             evdw=evdw+evdwij
1608 #endif
1609             if (lprn) then
1610             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1611             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1612 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1613 cd     &        restyp(itypi),i,restyp(itypj),j,
1614 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1615 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1616 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1617 cd     &        evdwij
1618             endif
1619 C Calculate gradient components.
1620             e1=e1*eps1*eps2rt**2*eps3rt**2
1621             fac=-expon*(e1+evdwij)
1622             sigder=fac/sigsq
1623             fac=rrij*fac
1624 C Calculate radial part of the gradient
1625             gg(1)=xj*fac
1626             gg(2)=yj*fac
1627             gg(3)=zj*fac
1628 C Calculate the angular part of the gradient and sum add the contributions
1629 C to the appropriate components of the Cartesian gradient.
1630 #ifdef TSCSC
1631             if (bb(itypi,itypj).gt.0) then
1632                call sc_grad
1633             else
1634                call sc_grad_T
1635             endif
1636 #else
1637             call sc_grad
1638 #endif
1639           enddo      ! j
1640         enddo        ! iint
1641       enddo          ! i
1642 c     stop
1643       return
1644       end
1645 C-----------------------------------------------------------------------------
1646       subroutine egb(evdw,evdw_p,evdw_m)
1647 C
1648 C This subroutine calculates the interaction energy of nonbonded side chains
1649 C assuming the Gay-Berne potential of interaction.
1650 C
1651       implicit real*8 (a-h,o-z)
1652       include 'DIMENSIONS'
1653       include 'COMMON.GEO'
1654       include 'COMMON.VAR'
1655       include 'COMMON.LOCAL'
1656       include 'COMMON.CHAIN'
1657       include 'COMMON.DERIV'
1658       include 'COMMON.NAMES'
1659       include 'COMMON.INTERACT'
1660       include 'COMMON.IOUNITS'
1661       include 'COMMON.CALC'
1662       include 'COMMON.CONTROL'
1663       include 'COMMON.SBRIDGE'
1664       logical lprn
1665       evdw=0.0D0
1666 ccccc      energy_dec=.false.
1667 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1668       evdw=0.0D0
1669       evdw_p=0.0D0
1670       evdw_m=0.0D0
1671       lprn=.false.
1672 c     if (icall.eq.0) lprn=.false.
1673       ind=0
1674       do i=iatsc_s,iatsc_e
1675         itypi=itype(i)
1676         itypi1=itype(i+1)
1677         xi=c(1,nres+i)
1678         yi=c(2,nres+i)
1679         zi=c(3,nres+i)
1680         dxi=dc_norm(1,nres+i)
1681         dyi=dc_norm(2,nres+i)
1682         dzi=dc_norm(3,nres+i)
1683 c        dsci_inv=dsc_inv(itypi)
1684         dsci_inv=vbld_inv(i+nres)
1685 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1686 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1687 C
1688 C Calculate SC interaction energy.
1689 C
1690         do iint=1,nint_gr(i)
1691           do j=istart(i,iint),iend(i,iint)
1692             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1693               call dyn_ssbond_ene(i,j,evdwij)
1694               evdw=evdw+evdwij
1695               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1696      &                        'evdw',i,j,evdwij,' ss'
1697             ELSE
1698             ind=ind+1
1699             itypj=itype(j)
1700 c            dscj_inv=dsc_inv(itypj)
1701             dscj_inv=vbld_inv(j+nres)
1702 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1703 c     &       1.0d0/vbld(j+nres)
1704 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1705             sig0ij=sigma(itypi,itypj)
1706             chi1=chi(itypi,itypj)
1707             chi2=chi(itypj,itypi)
1708             chi12=chi1*chi2
1709             chip1=chip(itypi)
1710             chip2=chip(itypj)
1711             chip12=chip1*chip2
1712             alf1=alp(itypi)
1713             alf2=alp(itypj)
1714             alf12=0.5D0*(alf1+alf2)
1715 C For diagnostics only!!!
1716 c           chi1=0.0D0
1717 c           chi2=0.0D0
1718 c           chi12=0.0D0
1719 c           chip1=0.0D0
1720 c           chip2=0.0D0
1721 c           chip12=0.0D0
1722 c           alf1=0.0D0
1723 c           alf2=0.0D0
1724 c           alf12=0.0D0
1725             xj=c(1,nres+j)-xi
1726             yj=c(2,nres+j)-yi
1727             zj=c(3,nres+j)-zi
1728             dxj=dc_norm(1,nres+j)
1729             dyj=dc_norm(2,nres+j)
1730             dzj=dc_norm(3,nres+j)
1731 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1732 c            write (iout,*) "j",j," dc_norm",
1733 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1734             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1735             rij=dsqrt(rrij)
1736 C Calculate angle-dependent terms of energy and contributions to their
1737 C derivatives.
1738             call sc_angular
1739             sigsq=1.0D0/sigsq
1740             sig=sig0ij*dsqrt(sigsq)
1741             rij_shift=1.0D0/rij-sig+sig0ij
1742 c for diagnostics; uncomment
1743 c            rij_shift=1.2*sig0ij
1744 C I hate to put IF's in the loops, but here don't have another choice!!!!
1745             if (rij_shift.le.0.0D0) then
1746               evdw=1.0D20
1747 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1748 cd     &        restyp(itypi),i,restyp(itypj),j,
1749 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1750               return
1751             endif
1752             sigder=-sig*sigsq
1753 c---------------------------------------------------------------
1754             rij_shift=1.0D0/rij_shift
1755             fac=rij_shift**expon
1756             e1=fac*fac*aa(itypi,itypj)
1757             e2=fac*bb(itypi,itypj)
1758             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1759             eps2der=evdwij*eps3rt
1760             eps3der=evdwij*eps2rt
1761 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1762 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1763             evdwij=evdwij*eps2rt*eps3rt
1764 #ifdef TSCSC
1765             if (bb(itypi,itypj).gt.0) then
1766                evdw_p=evdw_p+evdwij
1767             else
1768                evdw_m=evdw_m+evdwij
1769             endif
1770 #else
1771             evdw=evdw+evdwij
1772 #endif
1773             if (lprn) then
1774             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1775             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1776             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1777      &        restyp(itypi),i,restyp(itypj),j,
1778      &        epsi,sigm,chi1,chi2,chip1,chip2,
1779      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1780      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1781      &        evdwij
1782             endif
1783
1784             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1785      &                        'evdw',i,j,evdwij
1786
1787 C Calculate gradient components.
1788             e1=e1*eps1*eps2rt**2*eps3rt**2
1789             fac=-expon*(e1+evdwij)*rij_shift
1790             sigder=fac*sigder
1791             fac=rij*fac
1792 c            fac=0.0d0
1793 C Calculate the radial part of the gradient
1794             gg(1)=xj*fac
1795             gg(2)=yj*fac
1796             gg(3)=zj*fac
1797 C Calculate angular part of the gradient.
1798 #ifdef TSCSC
1799             if (bb(itypi,itypj).gt.0) then
1800                call sc_grad
1801             else
1802                call sc_grad_T
1803             endif
1804 #else
1805             call sc_grad
1806 #endif
1807             ENDIF    ! dyn_ss
1808           enddo      ! j
1809         enddo        ! iint
1810       enddo          ! i
1811 c      write (iout,*) "Number of loop steps in EGB:",ind
1812 cccc      energy_dec=.false.
1813       return
1814       end
1815 C-----------------------------------------------------------------------------
1816       subroutine egbv(evdw,evdw_p,evdw_m)
1817 C
1818 C This subroutine calculates the interaction energy of nonbonded side chains
1819 C assuming the Gay-Berne-Vorobjev potential of interaction.
1820 C
1821       implicit real*8 (a-h,o-z)
1822       include 'DIMENSIONS'
1823       include 'COMMON.GEO'
1824       include 'COMMON.VAR'
1825       include 'COMMON.LOCAL'
1826       include 'COMMON.CHAIN'
1827       include 'COMMON.DERIV'
1828       include 'COMMON.NAMES'
1829       include 'COMMON.INTERACT'
1830       include 'COMMON.IOUNITS'
1831       include 'COMMON.CALC'
1832       common /srutu/ icall
1833       logical lprn
1834       evdw=0.0D0
1835 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1836       evdw=0.0D0
1837       lprn=.false.
1838 c     if (icall.eq.0) lprn=.true.
1839       ind=0
1840       do i=iatsc_s,iatsc_e
1841         itypi=itype(i)
1842         itypi1=itype(i+1)
1843         xi=c(1,nres+i)
1844         yi=c(2,nres+i)
1845         zi=c(3,nres+i)
1846         dxi=dc_norm(1,nres+i)
1847         dyi=dc_norm(2,nres+i)
1848         dzi=dc_norm(3,nres+i)
1849 c        dsci_inv=dsc_inv(itypi)
1850         dsci_inv=vbld_inv(i+nres)
1851 C
1852 C Calculate SC interaction energy.
1853 C
1854         do iint=1,nint_gr(i)
1855           do j=istart(i,iint),iend(i,iint)
1856             ind=ind+1
1857             itypj=itype(j)
1858 c            dscj_inv=dsc_inv(itypj)
1859             dscj_inv=vbld_inv(j+nres)
1860             sig0ij=sigma(itypi,itypj)
1861             r0ij=r0(itypi,itypj)
1862             chi1=chi(itypi,itypj)
1863             chi2=chi(itypj,itypi)
1864             chi12=chi1*chi2
1865             chip1=chip(itypi)
1866             chip2=chip(itypj)
1867             chip12=chip1*chip2
1868             alf1=alp(itypi)
1869             alf2=alp(itypj)
1870             alf12=0.5D0*(alf1+alf2)
1871 C For diagnostics only!!!
1872 c           chi1=0.0D0
1873 c           chi2=0.0D0
1874 c           chi12=0.0D0
1875 c           chip1=0.0D0
1876 c           chip2=0.0D0
1877 c           chip12=0.0D0
1878 c           alf1=0.0D0
1879 c           alf2=0.0D0
1880 c           alf12=0.0D0
1881             xj=c(1,nres+j)-xi
1882             yj=c(2,nres+j)-yi
1883             zj=c(3,nres+j)-zi
1884             dxj=dc_norm(1,nres+j)
1885             dyj=dc_norm(2,nres+j)
1886             dzj=dc_norm(3,nres+j)
1887             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1888             rij=dsqrt(rrij)
1889 C Calculate angle-dependent terms of energy and contributions to their
1890 C derivatives.
1891             call sc_angular
1892             sigsq=1.0D0/sigsq
1893             sig=sig0ij*dsqrt(sigsq)
1894             rij_shift=1.0D0/rij-sig+r0ij
1895 C I hate to put IF's in the loops, but here don't have another choice!!!!
1896             if (rij_shift.le.0.0D0) then
1897               evdw=1.0D20
1898               return
1899             endif
1900             sigder=-sig*sigsq
1901 c---------------------------------------------------------------
1902             rij_shift=1.0D0/rij_shift
1903             fac=rij_shift**expon
1904             e1=fac*fac*aa(itypi,itypj)
1905             e2=fac*bb(itypi,itypj)
1906             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1907             eps2der=evdwij*eps3rt
1908             eps3der=evdwij*eps2rt
1909             fac_augm=rrij**expon
1910             e_augm=augm(itypi,itypj)*fac_augm
1911             evdwij=evdwij*eps2rt*eps3rt
1912 #ifdef TSCSC
1913             if (bb(itypi,itypj).gt.0) then
1914                evdw_p=evdw_p+evdwij+e_augm
1915             else
1916                evdw_m=evdw_m+evdwij+e_augm
1917             endif
1918 #else
1919             evdw=evdw+evdwij+e_augm
1920 #endif
1921             if (lprn) then
1922             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1923             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1924             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1925      &        restyp(itypi),i,restyp(itypj),j,
1926      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1927      &        chi1,chi2,chip1,chip2,
1928      &        eps1,eps2rt**2,eps3rt**2,
1929      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1930      &        evdwij+e_augm
1931             endif
1932 C Calculate gradient components.
1933             e1=e1*eps1*eps2rt**2*eps3rt**2
1934             fac=-expon*(e1+evdwij)*rij_shift
1935             sigder=fac*sigder
1936             fac=rij*fac-2*expon*rrij*e_augm
1937 C Calculate the radial part of the gradient
1938             gg(1)=xj*fac
1939             gg(2)=yj*fac
1940             gg(3)=zj*fac
1941 C Calculate angular part of the gradient.
1942 #ifdef TSCSC
1943             if (bb(itypi,itypj).gt.0) then
1944                call sc_grad
1945             else
1946                call sc_grad_T
1947             endif
1948 #else
1949             call sc_grad
1950 #endif
1951           enddo      ! j
1952         enddo        ! iint
1953       enddo          ! i
1954       end
1955 C-----------------------------------------------------------------------------
1956       subroutine sc_angular
1957 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1958 C om12. Called by ebp, egb, and egbv.
1959       implicit none
1960       include 'COMMON.CALC'
1961       include 'COMMON.IOUNITS'
1962       erij(1)=xj*rij
1963       erij(2)=yj*rij
1964       erij(3)=zj*rij
1965       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1966       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1967       om12=dxi*dxj+dyi*dyj+dzi*dzj
1968       chiom12=chi12*om12
1969 C Calculate eps1(om12) and its derivative in om12
1970       faceps1=1.0D0-om12*chiom12
1971       faceps1_inv=1.0D0/faceps1
1972       eps1=dsqrt(faceps1_inv)
1973 C Following variable is eps1*deps1/dom12
1974       eps1_om12=faceps1_inv*chiom12
1975 c diagnostics only
1976 c      faceps1_inv=om12
1977 c      eps1=om12
1978 c      eps1_om12=1.0d0
1979 c      write (iout,*) "om12",om12," eps1",eps1
1980 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1981 C and om12.
1982       om1om2=om1*om2
1983       chiom1=chi1*om1
1984       chiom2=chi2*om2
1985       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1986       sigsq=1.0D0-facsig*faceps1_inv
1987       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1988       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1989       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1990 c diagnostics only
1991 c      sigsq=1.0d0
1992 c      sigsq_om1=0.0d0
1993 c      sigsq_om2=0.0d0
1994 c      sigsq_om12=0.0d0
1995 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1996 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1997 c     &    " eps1",eps1
1998 C Calculate eps2 and its derivatives in om1, om2, and om12.
1999       chipom1=chip1*om1
2000       chipom2=chip2*om2
2001       chipom12=chip12*om12
2002       facp=1.0D0-om12*chipom12
2003       facp_inv=1.0D0/facp
2004       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2005 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2006 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2007 C Following variable is the square root of eps2
2008       eps2rt=1.0D0-facp1*facp_inv
2009 C Following three variables are the derivatives of the square root of eps
2010 C in om1, om2, and om12.
2011       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2012       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2013       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2014 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2015       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2016 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2017 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2018 c     &  " eps2rt_om12",eps2rt_om12
2019 C Calculate whole angle-dependent part of epsilon and contributions
2020 C to its derivatives
2021       return
2022       end
2023
2024 C----------------------------------------------------------------------------
2025       subroutine sc_grad_T
2026       implicit real*8 (a-h,o-z)
2027       include 'DIMENSIONS'
2028       include 'COMMON.CHAIN'
2029       include 'COMMON.DERIV'
2030       include 'COMMON.CALC'
2031       include 'COMMON.IOUNITS'
2032       double precision dcosom1(3),dcosom2(3)
2033       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2034       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2035       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2036      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2037 c diagnostics only
2038 c      eom1=0.0d0
2039 c      eom2=0.0d0
2040 c      eom12=evdwij*eps1_om12
2041 c end diagnostics
2042 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2043 c     &  " sigder",sigder
2044 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2045 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2046       do k=1,3
2047         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2048         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2049       enddo
2050       do k=1,3
2051         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
2052       enddo
2053 c      write (iout,*) "gg",(gg(k),k=1,3)
2054       do k=1,3
2055         gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
2056      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2057      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2058         gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
2059      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2060      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2061 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2062 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2063 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2064 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2065       enddo
2066 C
2067 C Calculate the components of the gradient in DC and X
2068 C
2069 cgrad      do k=i,j-1
2070 cgrad        do l=1,3
2071 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2072 cgrad        enddo
2073 cgrad      enddo
2074       do l=1,3
2075         gvdwcT(l,i)=gvdwcT(l,i)-gg(l)
2076         gvdwcT(l,j)=gvdwcT(l,j)+gg(l)
2077       enddo
2078       return
2079       end
2080
2081 C----------------------------------------------------------------------------
2082       subroutine sc_grad
2083       implicit real*8 (a-h,o-z)
2084       include 'DIMENSIONS'
2085       include 'COMMON.CHAIN'
2086       include 'COMMON.DERIV'
2087       include 'COMMON.CALC'
2088       include 'COMMON.IOUNITS'
2089       double precision dcosom1(3),dcosom2(3)
2090       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2091       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2092       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2093      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2094 c diagnostics only
2095 c      eom1=0.0d0
2096 c      eom2=0.0d0
2097 c      eom12=evdwij*eps1_om12
2098 c end diagnostics
2099 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2100 c     &  " sigder",sigder
2101 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2102 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2103       do k=1,3
2104         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2105         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2106       enddo
2107       do k=1,3
2108         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
2109       enddo
2110 c      write (iout,*) "gg",(gg(k),k=1,3)
2111       do k=1,3
2112         gvdwx(k,i)=gvdwx(k,i)-gg(k)
2113      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2114      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2115         gvdwx(k,j)=gvdwx(k,j)+gg(k)
2116      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2117      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2118 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2119 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2120 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2121 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2122       enddo
2123 C
2124 C Calculate the components of the gradient in DC and X
2125 C
2126 cgrad      do k=i,j-1
2127 cgrad        do l=1,3
2128 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2129 cgrad        enddo
2130 cgrad      enddo
2131       do l=1,3
2132         gvdwc(l,i)=gvdwc(l,i)-gg(l)
2133         gvdwc(l,j)=gvdwc(l,j)+gg(l)
2134       enddo
2135       return
2136       end
2137 C-----------------------------------------------------------------------
2138       subroutine e_softsphere(evdw)
2139 C
2140 C This subroutine calculates the interaction energy of nonbonded side chains
2141 C assuming the LJ potential of interaction.
2142 C
2143       implicit real*8 (a-h,o-z)
2144       include 'DIMENSIONS'
2145       parameter (accur=1.0d-10)
2146       include 'COMMON.GEO'
2147       include 'COMMON.VAR'
2148       include 'COMMON.LOCAL'
2149       include 'COMMON.CHAIN'
2150       include 'COMMON.DERIV'
2151       include 'COMMON.INTERACT'
2152       include 'COMMON.TORSION'
2153       include 'COMMON.SBRIDGE'
2154       include 'COMMON.NAMES'
2155       include 'COMMON.IOUNITS'
2156       include 'COMMON.CONTACTS'
2157       dimension gg(3)
2158 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2159       evdw=0.0D0
2160       do i=iatsc_s,iatsc_e
2161         itypi=itype(i)
2162         itypi1=itype(i+1)
2163         xi=c(1,nres+i)
2164         yi=c(2,nres+i)
2165         zi=c(3,nres+i)
2166 C
2167 C Calculate SC interaction energy.
2168 C
2169         do iint=1,nint_gr(i)
2170 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2171 cd   &                  'iend=',iend(i,iint)
2172           do j=istart(i,iint),iend(i,iint)
2173             itypj=itype(j)
2174             xj=c(1,nres+j)-xi
2175             yj=c(2,nres+j)-yi
2176             zj=c(3,nres+j)-zi
2177             rij=xj*xj+yj*yj+zj*zj
2178 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2179             r0ij=r0(itypi,itypj)
2180             r0ijsq=r0ij*r0ij
2181 c            print *,i,j,r0ij,dsqrt(rij)
2182             if (rij.lt.r0ijsq) then
2183               evdwij=0.25d0*(rij-r0ijsq)**2
2184               fac=rij-r0ijsq
2185             else
2186               evdwij=0.0d0
2187               fac=0.0d0
2188             endif
2189             evdw=evdw+evdwij
2190 C
2191 C Calculate the components of the gradient in DC and X
2192 C
2193             gg(1)=xj*fac
2194             gg(2)=yj*fac
2195             gg(3)=zj*fac
2196             do k=1,3
2197               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2198               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2199               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2200               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2201             enddo
2202 cgrad            do k=i,j-1
2203 cgrad              do l=1,3
2204 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2205 cgrad              enddo
2206 cgrad            enddo
2207           enddo ! j
2208         enddo ! iint
2209       enddo ! i
2210       return
2211       end
2212 C--------------------------------------------------------------------------
2213       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2214      &              eello_turn4)
2215 C
2216 C Soft-sphere potential of p-p interaction
2217 C
2218       implicit real*8 (a-h,o-z)
2219       include 'DIMENSIONS'
2220       include 'COMMON.CONTROL'
2221       include 'COMMON.IOUNITS'
2222       include 'COMMON.GEO'
2223       include 'COMMON.VAR'
2224       include 'COMMON.LOCAL'
2225       include 'COMMON.CHAIN'
2226       include 'COMMON.DERIV'
2227       include 'COMMON.INTERACT'
2228       include 'COMMON.CONTACTS'
2229       include 'COMMON.TORSION'
2230       include 'COMMON.VECTORS'
2231       include 'COMMON.FFIELD'
2232       dimension ggg(3)
2233 cd      write(iout,*) 'In EELEC_soft_sphere'
2234       ees=0.0D0
2235       evdw1=0.0D0
2236       eel_loc=0.0d0
2237       eello_turn3=0.0d0
2238       eello_turn4=0.0d0
2239       ind=0
2240       do i=iatel_s,iatel_e
2241         dxi=dc(1,i)
2242         dyi=dc(2,i)
2243         dzi=dc(3,i)
2244         xmedi=c(1,i)+0.5d0*dxi
2245         ymedi=c(2,i)+0.5d0*dyi
2246         zmedi=c(3,i)+0.5d0*dzi
2247         num_conti=0
2248 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2249         do j=ielstart(i),ielend(i)
2250           ind=ind+1
2251           iteli=itel(i)
2252           itelj=itel(j)
2253           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2254           r0ij=rpp(iteli,itelj)
2255           r0ijsq=r0ij*r0ij
2256           dxj=dc(1,j)
2257           dyj=dc(2,j)
2258           dzj=dc(3,j)
2259           xj=c(1,j)+0.5D0*dxj-xmedi
2260           yj=c(2,j)+0.5D0*dyj-ymedi
2261           zj=c(3,j)+0.5D0*dzj-zmedi
2262           rij=xj*xj+yj*yj+zj*zj
2263           if (rij.lt.r0ijsq) then
2264             evdw1ij=0.25d0*(rij-r0ijsq)**2
2265             fac=rij-r0ijsq
2266           else
2267             evdw1ij=0.0d0
2268             fac=0.0d0
2269           endif
2270           evdw1=evdw1+evdw1ij
2271 C
2272 C Calculate contributions to the Cartesian gradient.
2273 C
2274           ggg(1)=fac*xj
2275           ggg(2)=fac*yj
2276           ggg(3)=fac*zj
2277           do k=1,3
2278             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2279             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2280           enddo
2281 *
2282 * Loop over residues i+1 thru j-1.
2283 *
2284 cgrad          do k=i+1,j-1
2285 cgrad            do l=1,3
2286 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2287 cgrad            enddo
2288 cgrad          enddo
2289         enddo ! j
2290       enddo   ! i
2291 cgrad      do i=nnt,nct-1
2292 cgrad        do k=1,3
2293 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2294 cgrad        enddo
2295 cgrad        do j=i+1,nct-1
2296 cgrad          do k=1,3
2297 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2298 cgrad          enddo
2299 cgrad        enddo
2300 cgrad      enddo
2301       return
2302       end
2303 c------------------------------------------------------------------------------
2304       subroutine vec_and_deriv
2305       implicit real*8 (a-h,o-z)
2306       include 'DIMENSIONS'
2307 #ifdef MPI
2308       include 'mpif.h'
2309 #endif
2310       include 'COMMON.IOUNITS'
2311       include 'COMMON.GEO'
2312       include 'COMMON.VAR'
2313       include 'COMMON.LOCAL'
2314       include 'COMMON.CHAIN'
2315       include 'COMMON.VECTORS'
2316       include 'COMMON.SETUP'
2317       include 'COMMON.TIME1'
2318       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2319 C Compute the local reference systems. For reference system (i), the
2320 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2321 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2322 #ifdef PARVEC
2323       do i=ivec_start,ivec_end
2324 #else
2325       do i=1,nres-1
2326 #endif
2327           if (i.eq.nres-1) then
2328 C Case of the last full residue
2329 C Compute the Z-axis
2330             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2331             costh=dcos(pi-theta(nres))
2332             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2333             do k=1,3
2334               uz(k,i)=fac*uz(k,i)
2335             enddo
2336 C Compute the derivatives of uz
2337             uzder(1,1,1)= 0.0d0
2338             uzder(2,1,1)=-dc_norm(3,i-1)
2339             uzder(3,1,1)= dc_norm(2,i-1)
2340             uzder(1,2,1)= dc_norm(3,i-1)
2341             uzder(2,2,1)= 0.0d0
2342             uzder(3,2,1)=-dc_norm(1,i-1)
2343             uzder(1,3,1)=-dc_norm(2,i-1)
2344             uzder(2,3,1)= dc_norm(1,i-1)
2345             uzder(3,3,1)= 0.0d0
2346             uzder(1,1,2)= 0.0d0
2347             uzder(2,1,2)= dc_norm(3,i)
2348             uzder(3,1,2)=-dc_norm(2,i)
2349             uzder(1,2,2)=-dc_norm(3,i)
2350             uzder(2,2,2)= 0.0d0
2351             uzder(3,2,2)= dc_norm(1,i)
2352             uzder(1,3,2)= dc_norm(2,i)
2353             uzder(2,3,2)=-dc_norm(1,i)
2354             uzder(3,3,2)= 0.0d0
2355 C Compute the Y-axis
2356             facy=fac
2357             do k=1,3
2358               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2359             enddo
2360 C Compute the derivatives of uy
2361             do j=1,3
2362               do k=1,3
2363                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2364      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2365                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2366               enddo
2367               uyder(j,j,1)=uyder(j,j,1)-costh
2368               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2369             enddo
2370             do j=1,2
2371               do k=1,3
2372                 do l=1,3
2373                   uygrad(l,k,j,i)=uyder(l,k,j)
2374                   uzgrad(l,k,j,i)=uzder(l,k,j)
2375                 enddo
2376               enddo
2377             enddo
2378             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2379             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2380             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2381             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2382           else
2383 C Other residues
2384 C Compute the Z-axis
2385             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2386             costh=dcos(pi-theta(i+2))
2387             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2388             do k=1,3
2389               uz(k,i)=fac*uz(k,i)
2390             enddo
2391 C Compute the derivatives of uz
2392             uzder(1,1,1)= 0.0d0
2393             uzder(2,1,1)=-dc_norm(3,i+1)
2394             uzder(3,1,1)= dc_norm(2,i+1)
2395             uzder(1,2,1)= dc_norm(3,i+1)
2396             uzder(2,2,1)= 0.0d0
2397             uzder(3,2,1)=-dc_norm(1,i+1)
2398             uzder(1,3,1)=-dc_norm(2,i+1)
2399             uzder(2,3,1)= dc_norm(1,i+1)
2400             uzder(3,3,1)= 0.0d0
2401             uzder(1,1,2)= 0.0d0
2402             uzder(2,1,2)= dc_norm(3,i)
2403             uzder(3,1,2)=-dc_norm(2,i)
2404             uzder(1,2,2)=-dc_norm(3,i)
2405             uzder(2,2,2)= 0.0d0
2406             uzder(3,2,2)= dc_norm(1,i)
2407             uzder(1,3,2)= dc_norm(2,i)
2408             uzder(2,3,2)=-dc_norm(1,i)
2409             uzder(3,3,2)= 0.0d0
2410 C Compute the Y-axis
2411             facy=fac
2412             do k=1,3
2413               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2414             enddo
2415 C Compute the derivatives of uy
2416             do j=1,3
2417               do k=1,3
2418                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2419      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2420                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2421               enddo
2422               uyder(j,j,1)=uyder(j,j,1)-costh
2423               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2424             enddo
2425             do j=1,2
2426               do k=1,3
2427                 do l=1,3
2428                   uygrad(l,k,j,i)=uyder(l,k,j)
2429                   uzgrad(l,k,j,i)=uzder(l,k,j)
2430                 enddo
2431               enddo
2432             enddo
2433             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2434             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2435             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2436             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2437           endif
2438       enddo
2439       do i=1,nres-1
2440         vbld_inv_temp(1)=vbld_inv(i+1)
2441         if (i.lt.nres-1) then
2442           vbld_inv_temp(2)=vbld_inv(i+2)
2443           else
2444           vbld_inv_temp(2)=vbld_inv(i)
2445           endif
2446         do j=1,2
2447           do k=1,3
2448             do l=1,3
2449               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2450               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2451             enddo
2452           enddo
2453         enddo
2454       enddo
2455 #if defined(PARVEC) && defined(MPI)
2456       if (nfgtasks1.gt.1) then
2457         time00=MPI_Wtime()
2458 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2459 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2460 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2461         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2462      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2463      &   FG_COMM1,IERR)
2464         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2465      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2466      &   FG_COMM1,IERR)
2467         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2468      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2469      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2470         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2471      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2472      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2473         time_gather=time_gather+MPI_Wtime()-time00
2474       endif
2475 c      if (fg_rank.eq.0) then
2476 c        write (iout,*) "Arrays UY and UZ"
2477 c        do i=1,nres-1
2478 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2479 c     &     (uz(k,i),k=1,3)
2480 c        enddo
2481 c      endif
2482 #endif
2483       return
2484       end
2485 C-----------------------------------------------------------------------------
2486       subroutine check_vecgrad
2487       implicit real*8 (a-h,o-z)
2488       include 'DIMENSIONS'
2489       include 'COMMON.IOUNITS'
2490       include 'COMMON.GEO'
2491       include 'COMMON.VAR'
2492       include 'COMMON.LOCAL'
2493       include 'COMMON.CHAIN'
2494       include 'COMMON.VECTORS'
2495       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2496       dimension uyt(3,maxres),uzt(3,maxres)
2497       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2498       double precision delta /1.0d-7/
2499       call vec_and_deriv
2500 cd      do i=1,nres
2501 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2502 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2503 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2504 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2505 cd     &     (dc_norm(if90,i),if90=1,3)
2506 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2507 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2508 cd          write(iout,'(a)')
2509 cd      enddo
2510       do i=1,nres
2511         do j=1,2
2512           do k=1,3
2513             do l=1,3
2514               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2515               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2516             enddo
2517           enddo
2518         enddo
2519       enddo
2520       call vec_and_deriv
2521       do i=1,nres
2522         do j=1,3
2523           uyt(j,i)=uy(j,i)
2524           uzt(j,i)=uz(j,i)
2525         enddo
2526       enddo
2527       do i=1,nres
2528 cd        write (iout,*) 'i=',i
2529         do k=1,3
2530           erij(k)=dc_norm(k,i)
2531         enddo
2532         do j=1,3
2533           do k=1,3
2534             dc_norm(k,i)=erij(k)
2535           enddo
2536           dc_norm(j,i)=dc_norm(j,i)+delta
2537 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2538 c          do k=1,3
2539 c            dc_norm(k,i)=dc_norm(k,i)/fac
2540 c          enddo
2541 c          write (iout,*) (dc_norm(k,i),k=1,3)
2542 c          write (iout,*) (erij(k),k=1,3)
2543           call vec_and_deriv
2544           do k=1,3
2545             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2546             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2547             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2548             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2549           enddo
2550 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2551 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2552 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2553         enddo
2554         do k=1,3
2555           dc_norm(k,i)=erij(k)
2556         enddo
2557 cd        do k=1,3
2558 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2559 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2560 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2561 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2562 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2563 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2564 cd          write (iout,'(a)')
2565 cd        enddo
2566       enddo
2567       return
2568       end
2569 C--------------------------------------------------------------------------
2570       subroutine set_matrices
2571       implicit real*8 (a-h,o-z)
2572       include 'DIMENSIONS'
2573 #ifdef MPI
2574       include "mpif.h"
2575       include "COMMON.SETUP"
2576       integer IERR
2577       integer status(MPI_STATUS_SIZE)
2578 #endif
2579       include 'COMMON.IOUNITS'
2580       include 'COMMON.GEO'
2581       include 'COMMON.VAR'
2582       include 'COMMON.LOCAL'
2583       include 'COMMON.CHAIN'
2584       include 'COMMON.DERIV'
2585       include 'COMMON.INTERACT'
2586       include 'COMMON.CONTACTS'
2587       include 'COMMON.TORSION'
2588       include 'COMMON.VECTORS'
2589       include 'COMMON.FFIELD'
2590       double precision auxvec(2),auxmat(2,2)
2591 C
2592 C Compute the virtual-bond-torsional-angle dependent quantities needed
2593 C to calculate the el-loc multibody terms of various order.
2594 C
2595 #ifdef PARMAT
2596       do i=ivec_start+2,ivec_end+2
2597 #else
2598       do i=3,nres+1
2599 #endif
2600         if (i .lt. nres+1) then
2601           sin1=dsin(phi(i))
2602           cos1=dcos(phi(i))
2603           sintab(i-2)=sin1
2604           costab(i-2)=cos1
2605           obrot(1,i-2)=cos1
2606           obrot(2,i-2)=sin1
2607           sin2=dsin(2*phi(i))
2608           cos2=dcos(2*phi(i))
2609           sintab2(i-2)=sin2
2610           costab2(i-2)=cos2
2611           obrot2(1,i-2)=cos2
2612           obrot2(2,i-2)=sin2
2613           Ug(1,1,i-2)=-cos1
2614           Ug(1,2,i-2)=-sin1
2615           Ug(2,1,i-2)=-sin1
2616           Ug(2,2,i-2)= cos1
2617           Ug2(1,1,i-2)=-cos2
2618           Ug2(1,2,i-2)=-sin2
2619           Ug2(2,1,i-2)=-sin2
2620           Ug2(2,2,i-2)= cos2
2621         else
2622           costab(i-2)=1.0d0
2623           sintab(i-2)=0.0d0
2624           obrot(1,i-2)=1.0d0
2625           obrot(2,i-2)=0.0d0
2626           obrot2(1,i-2)=0.0d0
2627           obrot2(2,i-2)=0.0d0
2628           Ug(1,1,i-2)=1.0d0
2629           Ug(1,2,i-2)=0.0d0
2630           Ug(2,1,i-2)=0.0d0
2631           Ug(2,2,i-2)=1.0d0
2632           Ug2(1,1,i-2)=0.0d0
2633           Ug2(1,2,i-2)=0.0d0
2634           Ug2(2,1,i-2)=0.0d0
2635           Ug2(2,2,i-2)=0.0d0
2636         endif
2637         if (i .gt. 3 .and. i .lt. nres+1) then
2638           obrot_der(1,i-2)=-sin1
2639           obrot_der(2,i-2)= cos1
2640           Ugder(1,1,i-2)= sin1
2641           Ugder(1,2,i-2)=-cos1
2642           Ugder(2,1,i-2)=-cos1
2643           Ugder(2,2,i-2)=-sin1
2644           dwacos2=cos2+cos2
2645           dwasin2=sin2+sin2
2646           obrot2_der(1,i-2)=-dwasin2
2647           obrot2_der(2,i-2)= dwacos2
2648           Ug2der(1,1,i-2)= dwasin2
2649           Ug2der(1,2,i-2)=-dwacos2
2650           Ug2der(2,1,i-2)=-dwacos2
2651           Ug2der(2,2,i-2)=-dwasin2
2652         else
2653           obrot_der(1,i-2)=0.0d0
2654           obrot_der(2,i-2)=0.0d0
2655           Ugder(1,1,i-2)=0.0d0
2656           Ugder(1,2,i-2)=0.0d0
2657           Ugder(2,1,i-2)=0.0d0
2658           Ugder(2,2,i-2)=0.0d0
2659           obrot2_der(1,i-2)=0.0d0
2660           obrot2_der(2,i-2)=0.0d0
2661           Ug2der(1,1,i-2)=0.0d0
2662           Ug2der(1,2,i-2)=0.0d0
2663           Ug2der(2,1,i-2)=0.0d0
2664           Ug2der(2,2,i-2)=0.0d0
2665         endif
2666 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2667         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2668           iti = itortyp(itype(i-2))
2669         else
2670           iti=ntortyp+1
2671         endif
2672 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2673         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2674           iti1 = itortyp(itype(i-1))
2675         else
2676           iti1=ntortyp+1
2677         endif
2678 cd        write (iout,*) '*******i',i,' iti1',iti
2679 cd        write (iout,*) 'b1',b1(:,iti)
2680 cd        write (iout,*) 'b2',b2(:,iti)
2681 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2682 c        if (i .gt. iatel_s+2) then
2683         if (i .gt. nnt+2) then
2684           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2685           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2686           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2687      &    then
2688           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2689           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2690           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2691           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2692           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2693           endif
2694         else
2695           do k=1,2
2696             Ub2(k,i-2)=0.0d0
2697             Ctobr(k,i-2)=0.0d0
2698             Dtobr2(k,i-2)=0.0d0
2699             do l=1,2
2700               EUg(l,k,i-2)=0.0d0
2701               CUg(l,k,i-2)=0.0d0
2702               DUg(l,k,i-2)=0.0d0
2703               DtUg2(l,k,i-2)=0.0d0
2704             enddo
2705           enddo
2706         endif
2707         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2708         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2709         do k=1,2
2710           muder(k,i-2)=Ub2der(k,i-2)
2711         enddo
2712 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2713         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2714           iti1 = itortyp(itype(i-1))
2715         else
2716           iti1=ntortyp+1
2717         endif
2718         do k=1,2
2719           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2720         enddo
2721 cd        write (iout,*) 'mu ',mu(:,i-2)
2722 cd        write (iout,*) 'mu1',mu1(:,i-2)
2723 cd        write (iout,*) 'mu2',mu2(:,i-2)
2724         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2725      &  then
2726         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2727         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2728         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2729         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2730         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2731 C Vectors and matrices dependent on a single virtual-bond dihedral.
2732         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2733         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2734         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2735         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2736         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2737         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2738         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2739         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2740         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2741         endif
2742       enddo
2743 C Matrices dependent on two consecutive virtual-bond dihedrals.
2744 C The order of matrices is from left to right.
2745       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2746      &then
2747 c      do i=max0(ivec_start,2),ivec_end
2748       do i=2,nres-1
2749         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2750         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2751         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2752         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2753         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2754         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2755         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2756         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2757       enddo
2758       endif
2759 #if defined(MPI) && defined(PARMAT)
2760 #ifdef DEBUG
2761 c      if (fg_rank.eq.0) then
2762         write (iout,*) "Arrays UG and UGDER before GATHER"
2763         do i=1,nres-1
2764           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2765      &     ((ug(l,k,i),l=1,2),k=1,2),
2766      &     ((ugder(l,k,i),l=1,2),k=1,2)
2767         enddo
2768         write (iout,*) "Arrays UG2 and UG2DER"
2769         do i=1,nres-1
2770           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2771      &     ((ug2(l,k,i),l=1,2),k=1,2),
2772      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2773         enddo
2774         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2775         do i=1,nres-1
2776           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2777      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2778      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2779         enddo
2780         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2781         do i=1,nres-1
2782           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2783      &     costab(i),sintab(i),costab2(i),sintab2(i)
2784         enddo
2785         write (iout,*) "Array MUDER"
2786         do i=1,nres-1
2787           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2788         enddo
2789 c      endif
2790 #endif
2791       if (nfgtasks.gt.1) then
2792         time00=MPI_Wtime()
2793 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2794 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2795 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2796 #ifdef MATGATHER
2797         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2798      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2799      &   FG_COMM1,IERR)
2800         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2801      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2802      &   FG_COMM1,IERR)
2803         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2804      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2805      &   FG_COMM1,IERR)
2806         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2807      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2808      &   FG_COMM1,IERR)
2809         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2810      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2811      &   FG_COMM1,IERR)
2812         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2813      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2814      &   FG_COMM1,IERR)
2815         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2816      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2817      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2818         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2819      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2820      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2821         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2822      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2823      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2824         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2825      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2826      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2827         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2828      &  then
2829         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2830      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2831      &   FG_COMM1,IERR)
2832         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2833      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2834      &   FG_COMM1,IERR)
2835         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2836      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2837      &   FG_COMM1,IERR)
2838        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2839      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2840      &   FG_COMM1,IERR)
2841         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2842      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2843      &   FG_COMM1,IERR)
2844         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2845      &   ivec_count(fg_rank1),
2846      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2847      &   FG_COMM1,IERR)
2848         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2849      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2850      &   FG_COMM1,IERR)
2851         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2852      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2853      &   FG_COMM1,IERR)
2854         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2855      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2856      &   FG_COMM1,IERR)
2857         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2858      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2859      &   FG_COMM1,IERR)
2860         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2861      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2862      &   FG_COMM1,IERR)
2863         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2864      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2865      &   FG_COMM1,IERR)
2866         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2867      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2868      &   FG_COMM1,IERR)
2869         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2870      &   ivec_count(fg_rank1),
2871      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2872      &   FG_COMM1,IERR)
2873         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2874      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2875      &   FG_COMM1,IERR)
2876        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2877      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2878      &   FG_COMM1,IERR)
2879         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2880      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2881      &   FG_COMM1,IERR)
2882        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2883      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2884      &   FG_COMM1,IERR)
2885         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2886      &   ivec_count(fg_rank1),
2887      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2888      &   FG_COMM1,IERR)
2889         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2890      &   ivec_count(fg_rank1),
2891      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2892      &   FG_COMM1,IERR)
2893         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2894      &   ivec_count(fg_rank1),
2895      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2896      &   MPI_MAT2,FG_COMM1,IERR)
2897         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2898      &   ivec_count(fg_rank1),
2899      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2900      &   MPI_MAT2,FG_COMM1,IERR)
2901         endif
2902 #else
2903 c Passes matrix info through the ring
2904       isend=fg_rank1
2905       irecv=fg_rank1-1
2906       if (irecv.lt.0) irecv=nfgtasks1-1
2907       iprev=irecv
2908       inext=fg_rank1+1
2909       if (inext.ge.nfgtasks1) inext=0
2910       do i=1,nfgtasks1-1
2911 c        write (iout,*) "isend",isend," irecv",irecv
2912 c        call flush(iout)
2913         lensend=lentyp(isend)
2914         lenrecv=lentyp(irecv)
2915 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2916 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2917 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2918 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2919 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2920 c        write (iout,*) "Gather ROTAT1"
2921 c        call flush(iout)
2922 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2923 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2924 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2925 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2926 c        write (iout,*) "Gather ROTAT2"
2927 c        call flush(iout)
2928         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2929      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2930      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2931      &   iprev,4400+irecv,FG_COMM,status,IERR)
2932 c        write (iout,*) "Gather ROTAT_OLD"
2933 c        call flush(iout)
2934         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2935      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2936      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2937      &   iprev,5500+irecv,FG_COMM,status,IERR)
2938 c        write (iout,*) "Gather PRECOMP11"
2939 c        call flush(iout)
2940         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2941      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2942      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2943      &   iprev,6600+irecv,FG_COMM,status,IERR)
2944 c        write (iout,*) "Gather PRECOMP12"
2945 c        call flush(iout)
2946         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2947      &  then
2948         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2949      &   MPI_ROTAT2(lensend),inext,7700+isend,
2950      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2951      &   iprev,7700+irecv,FG_COMM,status,IERR)
2952 c        write (iout,*) "Gather PRECOMP21"
2953 c        call flush(iout)
2954         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2955      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2956      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2957      &   iprev,8800+irecv,FG_COMM,status,IERR)
2958 c        write (iout,*) "Gather PRECOMP22"
2959 c        call flush(iout)
2960         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2961      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2962      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2963      &   MPI_PRECOMP23(lenrecv),
2964      &   iprev,9900+irecv,FG_COMM,status,IERR)
2965 c        write (iout,*) "Gather PRECOMP23"
2966 c        call flush(iout)
2967         endif
2968         isend=irecv
2969         irecv=irecv-1
2970         if (irecv.lt.0) irecv=nfgtasks1-1
2971       enddo
2972 #endif
2973         time_gather=time_gather+MPI_Wtime()-time00
2974       endif
2975 #ifdef DEBUG
2976 c      if (fg_rank.eq.0) then
2977         write (iout,*) "Arrays UG and UGDER"
2978         do i=1,nres-1
2979           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2980      &     ((ug(l,k,i),l=1,2),k=1,2),
2981      &     ((ugder(l,k,i),l=1,2),k=1,2)
2982         enddo
2983         write (iout,*) "Arrays UG2 and UG2DER"
2984         do i=1,nres-1
2985           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2986      &     ((ug2(l,k,i),l=1,2),k=1,2),
2987      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2988         enddo
2989         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2990         do i=1,nres-1
2991           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2992      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2993      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2994         enddo
2995         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2996         do i=1,nres-1
2997           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2998      &     costab(i),sintab(i),costab2(i),sintab2(i)
2999         enddo
3000         write (iout,*) "Array MUDER"
3001         do i=1,nres-1
3002           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3003         enddo
3004 c      endif
3005 #endif
3006 #endif
3007 cd      do i=1,nres
3008 cd        iti = itortyp(itype(i))
3009 cd        write (iout,*) i
3010 cd        do j=1,2
3011 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3012 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3013 cd        enddo
3014 cd      enddo
3015       return
3016       end
3017 C--------------------------------------------------------------------------
3018       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3019 C
3020 C This subroutine calculates the average interaction energy and its gradient
3021 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3022 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3023 C The potential depends both on the distance of peptide-group centers and on
3024 C the orientation of the CA-CA virtual bonds.
3025 C
3026       implicit real*8 (a-h,o-z)
3027 #ifdef MPI
3028       include 'mpif.h'
3029 #endif
3030       include 'DIMENSIONS'
3031       include 'COMMON.CONTROL'
3032       include 'COMMON.SETUP'
3033       include 'COMMON.IOUNITS'
3034       include 'COMMON.GEO'
3035       include 'COMMON.VAR'
3036       include 'COMMON.LOCAL'
3037       include 'COMMON.CHAIN'
3038       include 'COMMON.DERIV'
3039       include 'COMMON.INTERACT'
3040       include 'COMMON.CONTACTS'
3041       include 'COMMON.TORSION'
3042       include 'COMMON.VECTORS'
3043       include 'COMMON.FFIELD'
3044       include 'COMMON.TIME1'
3045       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3046      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3047       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3048      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3049       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3050      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3051      &    num_conti,j1,j2
3052 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3053 #ifdef MOMENT
3054       double precision scal_el /1.0d0/
3055 #else
3056       double precision scal_el /0.5d0/
3057 #endif
3058 C 12/13/98
3059 C 13-go grudnia roku pamietnego...
3060       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3061      &                   0.0d0,1.0d0,0.0d0,
3062      &                   0.0d0,0.0d0,1.0d0/
3063 cd      write(iout,*) 'In EELEC'
3064 cd      do i=1,nloctyp
3065 cd        write(iout,*) 'Type',i
3066 cd        write(iout,*) 'B1',B1(:,i)
3067 cd        write(iout,*) 'B2',B2(:,i)
3068 cd        write(iout,*) 'CC',CC(:,:,i)
3069 cd        write(iout,*) 'DD',DD(:,:,i)
3070 cd        write(iout,*) 'EE',EE(:,:,i)
3071 cd      enddo
3072 cd      call check_vecgrad
3073 cd      stop
3074       if (icheckgrad.eq.1) then
3075         do i=1,nres-1
3076           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3077           do k=1,3
3078             dc_norm(k,i)=dc(k,i)*fac
3079           enddo
3080 c          write (iout,*) 'i',i,' fac',fac
3081         enddo
3082       endif
3083       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3084      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3085      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3086 c        call vec_and_deriv
3087 #ifdef TIMING
3088         time01=MPI_Wtime()
3089 #endif
3090         call set_matrices
3091 #ifdef TIMING
3092         time_mat=time_mat+MPI_Wtime()-time01
3093 #endif
3094       endif
3095 cd      do i=1,nres-1
3096 cd        write (iout,*) 'i=',i
3097 cd        do k=1,3
3098 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3099 cd        enddo
3100 cd        do k=1,3
3101 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3102 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3103 cd        enddo
3104 cd      enddo
3105       t_eelecij=0.0d0
3106       ees=0.0D0
3107       evdw1=0.0D0
3108       eel_loc=0.0d0
3109       eello_turn3=0.0d0
3110       eello_turn4=0.0d0
3111       ind=0
3112       do i=1,nres
3113         num_cont_hb(i)=0
3114       enddo
3115 cd      print '(a)','Enter EELEC'
3116 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3117       do i=1,nres
3118         gel_loc_loc(i)=0.0d0
3119         gcorr_loc(i)=0.0d0
3120       enddo
3121 c
3122 c
3123 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3124 C
3125 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3126 C
3127       do i=iturn3_start,iturn3_end
3128         dxi=dc(1,i)
3129         dyi=dc(2,i)
3130         dzi=dc(3,i)
3131         dx_normi=dc_norm(1,i)
3132         dy_normi=dc_norm(2,i)
3133         dz_normi=dc_norm(3,i)
3134         xmedi=c(1,i)+0.5d0*dxi
3135         ymedi=c(2,i)+0.5d0*dyi
3136         zmedi=c(3,i)+0.5d0*dzi
3137         num_conti=0
3138         call eelecij(i,i+2,ees,evdw1,eel_loc)
3139         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3140         num_cont_hb(i)=num_conti
3141       enddo
3142       do i=iturn4_start,iturn4_end
3143         dxi=dc(1,i)
3144         dyi=dc(2,i)
3145         dzi=dc(3,i)
3146         dx_normi=dc_norm(1,i)
3147         dy_normi=dc_norm(2,i)
3148         dz_normi=dc_norm(3,i)
3149         xmedi=c(1,i)+0.5d0*dxi
3150         ymedi=c(2,i)+0.5d0*dyi
3151         zmedi=c(3,i)+0.5d0*dzi
3152         num_conti=num_cont_hb(i)
3153         call eelecij(i,i+3,ees,evdw1,eel_loc)
3154         if (wturn4.gt.0.0d0) call eturn4(i,eello_turn4)
3155         num_cont_hb(i)=num_conti
3156       enddo   ! i
3157 c
3158 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3159 c
3160       do i=iatel_s,iatel_e
3161         dxi=dc(1,i)
3162         dyi=dc(2,i)
3163         dzi=dc(3,i)
3164         dx_normi=dc_norm(1,i)
3165         dy_normi=dc_norm(2,i)
3166         dz_normi=dc_norm(3,i)
3167         xmedi=c(1,i)+0.5d0*dxi
3168         ymedi=c(2,i)+0.5d0*dyi
3169         zmedi=c(3,i)+0.5d0*dzi
3170 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3171         num_conti=num_cont_hb(i)
3172         do j=ielstart(i),ielend(i)
3173           call eelecij(i,j,ees,evdw1,eel_loc)
3174         enddo ! j
3175         num_cont_hb(i)=num_conti
3176       enddo   ! i
3177 c      write (iout,*) "Number of loop steps in EELEC:",ind
3178 cd      do i=1,nres
3179 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3180 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3181 cd      enddo
3182 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3183 ccc      eel_loc=eel_loc+eello_turn3
3184 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3185       return
3186       end
3187 C-------------------------------------------------------------------------------
3188       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3189       implicit real*8 (a-h,o-z)
3190       include 'DIMENSIONS'
3191 #ifdef MPI
3192       include "mpif.h"
3193 #endif
3194       include 'COMMON.CONTROL'
3195       include 'COMMON.IOUNITS'
3196       include 'COMMON.GEO'
3197       include 'COMMON.VAR'
3198       include 'COMMON.LOCAL'
3199       include 'COMMON.CHAIN'
3200       include 'COMMON.DERIV'
3201       include 'COMMON.INTERACT'
3202       include 'COMMON.CONTACTS'
3203       include 'COMMON.TORSION'
3204       include 'COMMON.VECTORS'
3205       include 'COMMON.FFIELD'
3206       include 'COMMON.TIME1'
3207       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3208      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3209       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3210      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3211       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3212      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3213      &    num_conti,j1,j2
3214 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3215 #ifdef MOMENT
3216       double precision scal_el /1.0d0/
3217 #else
3218       double precision scal_el /0.5d0/
3219 #endif
3220 C 12/13/98
3221 C 13-go grudnia roku pamietnego...
3222       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3223      &                   0.0d0,1.0d0,0.0d0,
3224      &                   0.0d0,0.0d0,1.0d0/
3225 c          time00=MPI_Wtime()
3226 cd      write (iout,*) "eelecij",i,j
3227 c          ind=ind+1
3228           iteli=itel(i)
3229           itelj=itel(j)
3230           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3231           aaa=app(iteli,itelj)
3232           bbb=bpp(iteli,itelj)
3233           ael6i=ael6(iteli,itelj)
3234           ael3i=ael3(iteli,itelj)
3235           dxj=dc(1,j)
3236           dyj=dc(2,j)
3237           dzj=dc(3,j)
3238           dx_normj=dc_norm(1,j)
3239           dy_normj=dc_norm(2,j)
3240           dz_normj=dc_norm(3,j)
3241           xj=c(1,j)+0.5D0*dxj-xmedi
3242           yj=c(2,j)+0.5D0*dyj-ymedi
3243           zj=c(3,j)+0.5D0*dzj-zmedi
3244           rij=xj*xj+yj*yj+zj*zj
3245           rrmij=1.0D0/rij
3246           rij=dsqrt(rij)
3247           rmij=1.0D0/rij
3248           r3ij=rrmij*rmij
3249           r6ij=r3ij*r3ij
3250           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3251           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3252           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3253           fac=cosa-3.0D0*cosb*cosg
3254           ev1=aaa*r6ij*r6ij
3255 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3256           if (j.eq.i+2) ev1=scal_el*ev1
3257           ev2=bbb*r6ij
3258           fac3=ael6i*r6ij
3259           fac4=ael3i*r3ij
3260           evdwij=ev1+ev2
3261           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3262           el2=fac4*fac
3263           eesij=el1+el2
3264 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3265           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3266           ees=ees+eesij
3267           evdw1=evdw1+evdwij
3268 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3269 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3270 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3271 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3272
3273           if (energy_dec) then
3274               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3275               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3276           endif
3277
3278 C
3279 C Calculate contributions to the Cartesian gradient.
3280 C
3281 #ifdef SPLITELE
3282           facvdw=-6*rrmij*(ev1+evdwij)
3283           facel=-3*rrmij*(el1+eesij)
3284           fac1=fac
3285           erij(1)=xj*rmij
3286           erij(2)=yj*rmij
3287           erij(3)=zj*rmij
3288 *
3289 * Radial derivatives. First process both termini of the fragment (i,j)
3290 *
3291           ggg(1)=facel*xj
3292           ggg(2)=facel*yj
3293           ggg(3)=facel*zj
3294 c          do k=1,3
3295 c            ghalf=0.5D0*ggg(k)
3296 c            gelc(k,i)=gelc(k,i)+ghalf
3297 c            gelc(k,j)=gelc(k,j)+ghalf
3298 c          enddo
3299 c 9/28/08 AL Gradient compotents will be summed only at the end
3300           do k=1,3
3301             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3302             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3303           enddo
3304 *
3305 * Loop over residues i+1 thru j-1.
3306 *
3307 cgrad          do k=i+1,j-1
3308 cgrad            do l=1,3
3309 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3310 cgrad            enddo
3311 cgrad          enddo
3312           ggg(1)=facvdw*xj
3313           ggg(2)=facvdw*yj
3314           ggg(3)=facvdw*zj
3315 c          do k=1,3
3316 c            ghalf=0.5D0*ggg(k)
3317 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3318 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3319 c          enddo
3320 c 9/28/08 AL Gradient compotents will be summed only at the end
3321           do k=1,3
3322             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3323             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3324           enddo
3325 *
3326 * Loop over residues i+1 thru j-1.
3327 *
3328 cgrad          do k=i+1,j-1
3329 cgrad            do l=1,3
3330 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3331 cgrad            enddo
3332 cgrad          enddo
3333 #else
3334           facvdw=ev1+evdwij
3335           facel=el1+eesij
3336           fac1=fac
3337           fac=-3*rrmij*(facvdw+facvdw+facel)
3338           erij(1)=xj*rmij
3339           erij(2)=yj*rmij
3340           erij(3)=zj*rmij
3341 *
3342 * Radial derivatives. First process both termini of the fragment (i,j)
3343 *
3344           ggg(1)=fac*xj
3345           ggg(2)=fac*yj
3346           ggg(3)=fac*zj
3347 c          do k=1,3
3348 c            ghalf=0.5D0*ggg(k)
3349 c            gelc(k,i)=gelc(k,i)+ghalf
3350 c            gelc(k,j)=gelc(k,j)+ghalf
3351 c          enddo
3352 c 9/28/08 AL Gradient compotents will be summed only at the end
3353           do k=1,3
3354             gelc_long(k,j)=gelc(k,j)+ggg(k)
3355             gelc_long(k,i)=gelc(k,i)-ggg(k)
3356           enddo
3357 *
3358 * Loop over residues i+1 thru j-1.
3359 *
3360 cgrad          do k=i+1,j-1
3361 cgrad            do l=1,3
3362 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3363 cgrad            enddo
3364 cgrad          enddo
3365 c 9/28/08 AL Gradient compotents will be summed only at the end
3366           ggg(1)=facvdw*xj
3367           ggg(2)=facvdw*yj
3368           ggg(3)=facvdw*zj
3369           do k=1,3
3370             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3371             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3372           enddo
3373 #endif
3374 *
3375 * Angular part
3376 *
3377           ecosa=2.0D0*fac3*fac1+fac4
3378           fac4=-3.0D0*fac4
3379           fac3=-6.0D0*fac3
3380           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3381           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3382           do k=1,3
3383             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3384             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3385           enddo
3386 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3387 cd   &          (dcosg(k),k=1,3)
3388           do k=1,3
3389             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3390           enddo
3391 c          do k=1,3
3392 c            ghalf=0.5D0*ggg(k)
3393 c            gelc(k,i)=gelc(k,i)+ghalf
3394 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3395 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3396 c            gelc(k,j)=gelc(k,j)+ghalf
3397 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3398 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3399 c          enddo
3400 cgrad          do k=i+1,j-1
3401 cgrad            do l=1,3
3402 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3403 cgrad            enddo
3404 cgrad          enddo
3405           do k=1,3
3406             gelc(k,i)=gelc(k,i)
3407      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3408      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3409             gelc(k,j)=gelc(k,j)
3410      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3411      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3412             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3413             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3414           enddo
3415           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3416      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3417      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3418 C
3419 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3420 C   energy of a peptide unit is assumed in the form of a second-order
3421 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3422 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3423 C   are computed for EVERY pair of non-contiguous peptide groups.
3424 C
3425           if (j.lt.nres-1) then
3426             j1=j+1
3427             j2=j-1
3428           else
3429             j1=j-1
3430             j2=j-2
3431           endif
3432           kkk=0
3433           do k=1,2
3434             do l=1,2
3435               kkk=kkk+1
3436               muij(kkk)=mu(k,i)*mu(l,j)
3437             enddo
3438           enddo
3439 cd         write (iout,*) 'EELEC: i',i,' j',j
3440 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3441 cd          write(iout,*) 'muij',muij
3442           ury=scalar(uy(1,i),erij)
3443           urz=scalar(uz(1,i),erij)
3444           vry=scalar(uy(1,j),erij)
3445           vrz=scalar(uz(1,j),erij)
3446           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3447           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3448           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3449           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3450           fac=dsqrt(-ael6i)*r3ij
3451           a22=a22*fac
3452           a23=a23*fac
3453           a32=a32*fac
3454           a33=a33*fac
3455 cd          write (iout,'(4i5,4f10.5)')
3456 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3457 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3458 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3459 cd     &      uy(:,j),uz(:,j)
3460 cd          write (iout,'(4f10.5)')
3461 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3462 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3463 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3464 cd           write (iout,'(9f10.5/)')
3465 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3466 C Derivatives of the elements of A in virtual-bond vectors
3467           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3468           do k=1,3
3469             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3470             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3471             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3472             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3473             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3474             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3475             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3476             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3477             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3478             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3479             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3480             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3481           enddo
3482 C Compute radial contributions to the gradient
3483           facr=-3.0d0*rrmij
3484           a22der=a22*facr
3485           a23der=a23*facr
3486           a32der=a32*facr
3487           a33der=a33*facr
3488           agg(1,1)=a22der*xj
3489           agg(2,1)=a22der*yj
3490           agg(3,1)=a22der*zj
3491           agg(1,2)=a23der*xj
3492           agg(2,2)=a23der*yj
3493           agg(3,2)=a23der*zj
3494           agg(1,3)=a32der*xj
3495           agg(2,3)=a32der*yj
3496           agg(3,3)=a32der*zj
3497           agg(1,4)=a33der*xj
3498           agg(2,4)=a33der*yj
3499           agg(3,4)=a33der*zj
3500 C Add the contributions coming from er
3501           fac3=-3.0d0*fac
3502           do k=1,3
3503             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3504             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3505             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3506             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3507           enddo
3508           do k=1,3
3509 C Derivatives in DC(i)
3510 cgrad            ghalf1=0.5d0*agg(k,1)
3511 cgrad            ghalf2=0.5d0*agg(k,2)
3512 cgrad            ghalf3=0.5d0*agg(k,3)
3513 cgrad            ghalf4=0.5d0*agg(k,4)
3514             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3515      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3516             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3517      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3518             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3519      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3520             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3521      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3522 C Derivatives in DC(i+1)
3523             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3524      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3525             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3526      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3527             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3528      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3529             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3530      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3531 C Derivatives in DC(j)
3532             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3533      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3534             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3535      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3536             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3537      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3538             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3539      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3540 C Derivatives in DC(j+1) or DC(nres-1)
3541             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3542      &      -3.0d0*vryg(k,3)*ury)
3543             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3544      &      -3.0d0*vrzg(k,3)*ury)
3545             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3546      &      -3.0d0*vryg(k,3)*urz)
3547             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3548      &      -3.0d0*vrzg(k,3)*urz)
3549 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3550 cgrad              do l=1,4
3551 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3552 cgrad              enddo
3553 cgrad            endif
3554           enddo
3555           acipa(1,1)=a22
3556           acipa(1,2)=a23
3557           acipa(2,1)=a32
3558           acipa(2,2)=a33
3559           a22=-a22
3560           a23=-a23
3561           do l=1,2
3562             do k=1,3
3563               agg(k,l)=-agg(k,l)
3564               aggi(k,l)=-aggi(k,l)
3565               aggi1(k,l)=-aggi1(k,l)
3566               aggj(k,l)=-aggj(k,l)
3567               aggj1(k,l)=-aggj1(k,l)
3568             enddo
3569           enddo
3570           if (j.lt.nres-1) then
3571             a22=-a22
3572             a32=-a32
3573             do l=1,3,2
3574               do k=1,3
3575                 agg(k,l)=-agg(k,l)
3576                 aggi(k,l)=-aggi(k,l)
3577                 aggi1(k,l)=-aggi1(k,l)
3578                 aggj(k,l)=-aggj(k,l)
3579                 aggj1(k,l)=-aggj1(k,l)
3580               enddo
3581             enddo
3582           else
3583             a22=-a22
3584             a23=-a23
3585             a32=-a32
3586             a33=-a33
3587             do l=1,4
3588               do k=1,3
3589                 agg(k,l)=-agg(k,l)
3590                 aggi(k,l)=-aggi(k,l)
3591                 aggi1(k,l)=-aggi1(k,l)
3592                 aggj(k,l)=-aggj(k,l)
3593                 aggj1(k,l)=-aggj1(k,l)
3594               enddo
3595             enddo
3596           endif
3597           ENDIF ! WCORR
3598           IF (wel_loc.gt.0.0d0) THEN
3599 C Contribution to the local-electrostatic energy coming from the i-j pair
3600           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3601      &     +a33*muij(4)
3602 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3603
3604           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3605      &            'eelloc',i,j,eel_loc_ij
3606
3607           eel_loc=eel_loc+eel_loc_ij
3608 C Partial derivatives in virtual-bond dihedral angles gamma
3609           if (i.gt.1)
3610      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3611      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3612      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3613           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3614      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3615      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3616 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3617           do l=1,3
3618             ggg(l)=agg(l,1)*muij(1)+
3619      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3620             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3621             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3622 cgrad            ghalf=0.5d0*ggg(l)
3623 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3624 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3625           enddo
3626 cgrad          do k=i+1,j2
3627 cgrad            do l=1,3
3628 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3629 cgrad            enddo
3630 cgrad          enddo
3631 C Remaining derivatives of eello
3632           do l=1,3
3633             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3634      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3635             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3636      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3637             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3638      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3639             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3640      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3641           enddo
3642           ENDIF
3643 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3644 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3645           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3646      &       .and. num_conti.le.maxconts) then
3647 c            write (iout,*) i,j," entered corr"
3648 C
3649 C Calculate the contact function. The ith column of the array JCONT will
3650 C contain the numbers of atoms that make contacts with the atom I (of numbers
3651 C greater than I). The arrays FACONT and GACONT will contain the values of
3652 C the contact function and its derivative.
3653 c           r0ij=1.02D0*rpp(iteli,itelj)
3654 c           r0ij=1.11D0*rpp(iteli,itelj)
3655             r0ij=2.20D0*rpp(iteli,itelj)
3656 c           r0ij=1.55D0*rpp(iteli,itelj)
3657             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3658             if (fcont.gt.0.0D0) then
3659               num_conti=num_conti+1
3660               if (num_conti.gt.maxconts) then
3661                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3662      &                         ' will skip next contacts for this conf.'
3663               else
3664                 jcont_hb(num_conti,i)=j
3665 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3666 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3667                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3668      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3669 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3670 C  terms.
3671                 d_cont(num_conti,i)=rij
3672 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3673 C     --- Electrostatic-interaction matrix ---
3674                 a_chuj(1,1,num_conti,i)=a22
3675                 a_chuj(1,2,num_conti,i)=a23
3676                 a_chuj(2,1,num_conti,i)=a32
3677                 a_chuj(2,2,num_conti,i)=a33
3678 C     --- Gradient of rij
3679                 do kkk=1,3
3680                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3681                 enddo
3682                 kkll=0
3683                 do k=1,2
3684                   do l=1,2
3685                     kkll=kkll+1
3686                     do m=1,3
3687                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3688                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3689                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3690                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3691                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3692                     enddo
3693                   enddo
3694                 enddo
3695                 ENDIF
3696                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3697 C Calculate contact energies
3698                 cosa4=4.0D0*cosa
3699                 wij=cosa-3.0D0*cosb*cosg
3700                 cosbg1=cosb+cosg
3701                 cosbg2=cosb-cosg
3702 c               fac3=dsqrt(-ael6i)/r0ij**3
3703                 fac3=dsqrt(-ael6i)*r3ij
3704 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3705                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3706                 if (ees0tmp.gt.0) then
3707                   ees0pij=dsqrt(ees0tmp)
3708                 else
3709                   ees0pij=0
3710                 endif
3711 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3712                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3713                 if (ees0tmp.gt.0) then
3714                   ees0mij=dsqrt(ees0tmp)
3715                 else
3716                   ees0mij=0
3717                 endif
3718 c               ees0mij=0.0D0
3719                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3720                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3721 C Diagnostics. Comment out or remove after debugging!
3722 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3723 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3724 c               ees0m(num_conti,i)=0.0D0
3725 C End diagnostics.
3726 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3727 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3728 C Angular derivatives of the contact function
3729                 ees0pij1=fac3/ees0pij
3730                 ees0mij1=fac3/ees0mij
3731                 fac3p=-3.0D0*fac3*rrmij
3732                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3733                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3734 c               ees0mij1=0.0D0
3735                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3736                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3737                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3738                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3739                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3740                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3741                 ecosap=ecosa1+ecosa2
3742                 ecosbp=ecosb1+ecosb2
3743                 ecosgp=ecosg1+ecosg2
3744                 ecosam=ecosa1-ecosa2
3745                 ecosbm=ecosb1-ecosb2
3746                 ecosgm=ecosg1-ecosg2
3747 C Diagnostics
3748 c               ecosap=ecosa1
3749 c               ecosbp=ecosb1
3750 c               ecosgp=ecosg1
3751 c               ecosam=0.0D0
3752 c               ecosbm=0.0D0
3753 c               ecosgm=0.0D0
3754 C End diagnostics
3755                 facont_hb(num_conti,i)=fcont
3756                 fprimcont=fprimcont/rij
3757 cd              facont_hb(num_conti,i)=1.0D0
3758 C Following line is for diagnostics.
3759 cd              fprimcont=0.0D0
3760                 do k=1,3
3761                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3762                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3763                 enddo
3764                 do k=1,3
3765                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3766                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3767                 enddo
3768                 gggp(1)=gggp(1)+ees0pijp*xj
3769                 gggp(2)=gggp(2)+ees0pijp*yj
3770                 gggp(3)=gggp(3)+ees0pijp*zj
3771                 gggm(1)=gggm(1)+ees0mijp*xj
3772                 gggm(2)=gggm(2)+ees0mijp*yj
3773                 gggm(3)=gggm(3)+ees0mijp*zj
3774 C Derivatives due to the contact function
3775                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3776                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3777                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3778                 do k=1,3
3779 c
3780 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3781 c          following the change of gradient-summation algorithm.
3782 c
3783 cgrad                  ghalfp=0.5D0*gggp(k)
3784 cgrad                  ghalfm=0.5D0*gggm(k)
3785                   gacontp_hb1(k,num_conti,i)=!ghalfp
3786      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3787      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3788                   gacontp_hb2(k,num_conti,i)=!ghalfp
3789      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3790      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3791                   gacontp_hb3(k,num_conti,i)=gggp(k)
3792                   gacontm_hb1(k,num_conti,i)=!ghalfm
3793      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3794      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3795                   gacontm_hb2(k,num_conti,i)=!ghalfm
3796      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3797      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3798                   gacontm_hb3(k,num_conti,i)=gggm(k)
3799                 enddo
3800 C Diagnostics. Comment out or remove after debugging!
3801 cdiag           do k=1,3
3802 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3803 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3804 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3805 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3806 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3807 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3808 cdiag           enddo
3809               ENDIF ! wcorr
3810               endif  ! num_conti.le.maxconts
3811             endif  ! fcont.gt.0
3812           endif    ! j.gt.i+1
3813           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3814             do k=1,4
3815               do l=1,3
3816                 ghalf=0.5d0*agg(l,k)
3817                 aggi(l,k)=aggi(l,k)+ghalf
3818                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3819                 aggj(l,k)=aggj(l,k)+ghalf
3820               enddo
3821             enddo
3822             if (j.eq.nres-1 .and. i.lt.j-2) then
3823               do k=1,4
3824                 do l=1,3
3825                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3826                 enddo
3827               enddo
3828             endif
3829           endif
3830 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3831       return
3832       end
3833 C-----------------------------------------------------------------------------
3834       subroutine eturn3(i,eello_turn3)
3835 C Third- and fourth-order contributions from turns
3836       implicit real*8 (a-h,o-z)
3837       include 'DIMENSIONS'
3838       include 'COMMON.IOUNITS'
3839       include 'COMMON.GEO'
3840       include 'COMMON.VAR'
3841       include 'COMMON.LOCAL'
3842       include 'COMMON.CHAIN'
3843       include 'COMMON.DERIV'
3844       include 'COMMON.INTERACT'
3845       include 'COMMON.CONTACTS'
3846       include 'COMMON.TORSION'
3847       include 'COMMON.VECTORS'
3848       include 'COMMON.FFIELD'
3849       include 'COMMON.CONTROL'
3850       dimension ggg(3)
3851       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3852      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3853      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3854       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3855      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3856       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3857      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3858      &    num_conti,j1,j2
3859       j=i+2
3860 c      write (iout,*) "eturn3",i,j,j1,j2
3861       a_temp(1,1)=a22
3862       a_temp(1,2)=a23
3863       a_temp(2,1)=a32
3864       a_temp(2,2)=a33
3865 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3866 C
3867 C               Third-order contributions
3868 C
3869 C                 (i+2)o----(i+3)
3870 C                      | |
3871 C                      | |
3872 C                 (i+1)o----i
3873 C
3874 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3875 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3876         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3877         call transpose2(auxmat(1,1),auxmat1(1,1))
3878         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3879         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3880         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3881      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3882 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3883 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3884 cd     &    ' eello_turn3_num',4*eello_turn3_num
3885 C Derivatives in gamma(i)
3886         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3887         call transpose2(auxmat2(1,1),auxmat3(1,1))
3888         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3889         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3890 C Derivatives in gamma(i+1)
3891         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3892         call transpose2(auxmat2(1,1),auxmat3(1,1))
3893         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3894         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3895      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3896 C Cartesian derivatives
3897         do l=1,3
3898 c            ghalf1=0.5d0*agg(l,1)
3899 c            ghalf2=0.5d0*agg(l,2)
3900 c            ghalf3=0.5d0*agg(l,3)
3901 c            ghalf4=0.5d0*agg(l,4)
3902           a_temp(1,1)=aggi(l,1)!+ghalf1
3903           a_temp(1,2)=aggi(l,2)!+ghalf2
3904           a_temp(2,1)=aggi(l,3)!+ghalf3
3905           a_temp(2,2)=aggi(l,4)!+ghalf4
3906           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3907           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3908      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3909           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3910           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3911           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3912           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3913           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3914           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3915      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3916           a_temp(1,1)=aggj(l,1)!+ghalf1
3917           a_temp(1,2)=aggj(l,2)!+ghalf2
3918           a_temp(2,1)=aggj(l,3)!+ghalf3
3919           a_temp(2,2)=aggj(l,4)!+ghalf4
3920           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3921           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3922      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3923           a_temp(1,1)=aggj1(l,1)
3924           a_temp(1,2)=aggj1(l,2)
3925           a_temp(2,1)=aggj1(l,3)
3926           a_temp(2,2)=aggj1(l,4)
3927           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3928           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3929      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3930         enddo
3931       return
3932       end
3933 C-------------------------------------------------------------------------------
3934       subroutine eturn4(i,eello_turn4)
3935 C Third- and fourth-order contributions from turns
3936       implicit real*8 (a-h,o-z)
3937       include 'DIMENSIONS'
3938       include 'COMMON.IOUNITS'
3939       include 'COMMON.GEO'
3940       include 'COMMON.VAR'
3941       include 'COMMON.LOCAL'
3942       include 'COMMON.CHAIN'
3943       include 'COMMON.DERIV'
3944       include 'COMMON.INTERACT'
3945       include 'COMMON.CONTACTS'
3946       include 'COMMON.TORSION'
3947       include 'COMMON.VECTORS'
3948       include 'COMMON.FFIELD'
3949       include 'COMMON.CONTROL'
3950       dimension ggg(3)
3951       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3952      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3953      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3954       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3955      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3956       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3957      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3958      &    num_conti,j1,j2
3959       j=i+3
3960 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3961 C
3962 C               Fourth-order contributions
3963 C
3964 C                 (i+3)o----(i+4)
3965 C                     /  |
3966 C               (i+2)o   |
3967 C                     \  |
3968 C                 (i+1)o----i
3969 C
3970 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3971 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3972 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3973         a_temp(1,1)=a22
3974         a_temp(1,2)=a23
3975         a_temp(2,1)=a32
3976         a_temp(2,2)=a33
3977         iti1=itortyp(itype(i+1))
3978         iti2=itortyp(itype(i+2))
3979         iti3=itortyp(itype(i+3))
3980 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3981         call transpose2(EUg(1,1,i+1),e1t(1,1))
3982         call transpose2(Eug(1,1,i+2),e2t(1,1))
3983         call transpose2(Eug(1,1,i+3),e3t(1,1))
3984         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3985         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3986         s1=scalar2(b1(1,iti2),auxvec(1))
3987         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3988         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3989         s2=scalar2(b1(1,iti1),auxvec(1))
3990         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3991         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3992         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3993         eello_turn4=eello_turn4-(s1+s2+s3)
3994         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3995      &      'eturn4',i,j,-(s1+s2+s3)
3996 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3997 cd     &    ' eello_turn4_num',8*eello_turn4_num
3998 C Derivatives in gamma(i)
3999         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4000         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4001         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4002         s1=scalar2(b1(1,iti2),auxvec(1))
4003         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4004         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4005         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
4006 C Derivatives in gamma(i+1)
4007         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4008         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4009         s2=scalar2(b1(1,iti1),auxvec(1))
4010         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4011         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4012         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4013         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
4014 C Derivatives in gamma(i+2)
4015         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4016         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4017         s1=scalar2(b1(1,iti2),auxvec(1))
4018         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4019         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4020         s2=scalar2(b1(1,iti1),auxvec(1))
4021         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
4022         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
4023         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4024         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
4025 C Cartesian derivatives
4026 C Derivatives of this turn contributions in DC(i+2)
4027         if (j.lt.nres-1) then
4028           do l=1,3
4029             a_temp(1,1)=agg(l,1)
4030             a_temp(1,2)=agg(l,2)
4031             a_temp(2,1)=agg(l,3)
4032             a_temp(2,2)=agg(l,4)
4033             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4034             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4035             s1=scalar2(b1(1,iti2),auxvec(1))
4036             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4037             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4038             s2=scalar2(b1(1,iti1),auxvec(1))
4039             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4040             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4041             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4042             ggg(l)=-(s1+s2+s3)
4043             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
4044           enddo
4045         endif
4046 C Remaining derivatives of this turn contribution
4047         do l=1,3
4048           a_temp(1,1)=aggi(l,1)
4049           a_temp(1,2)=aggi(l,2)
4050           a_temp(2,1)=aggi(l,3)
4051           a_temp(2,2)=aggi(l,4)
4052           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4053           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4054           s1=scalar2(b1(1,iti2),auxvec(1))
4055           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4056           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4057           s2=scalar2(b1(1,iti1),auxvec(1))
4058           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4059           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4060           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4061           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
4062           a_temp(1,1)=aggi1(l,1)
4063           a_temp(1,2)=aggi1(l,2)
4064           a_temp(2,1)=aggi1(l,3)
4065           a_temp(2,2)=aggi1(l,4)
4066           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4067           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4068           s1=scalar2(b1(1,iti2),auxvec(1))
4069           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4070           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4071           s2=scalar2(b1(1,iti1),auxvec(1))
4072           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4073           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4074           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4075           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
4076           a_temp(1,1)=aggj(l,1)
4077           a_temp(1,2)=aggj(l,2)
4078           a_temp(2,1)=aggj(l,3)
4079           a_temp(2,2)=aggj(l,4)
4080           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4081           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4082           s1=scalar2(b1(1,iti2),auxvec(1))
4083           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4084           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4085           s2=scalar2(b1(1,iti1),auxvec(1))
4086           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4087           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4088           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4089           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
4090           a_temp(1,1)=aggj1(l,1)
4091           a_temp(1,2)=aggj1(l,2)
4092           a_temp(2,1)=aggj1(l,3)
4093           a_temp(2,2)=aggj1(l,4)
4094           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4095           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4096           s1=scalar2(b1(1,iti2),auxvec(1))
4097           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4098           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4099           s2=scalar2(b1(1,iti1),auxvec(1))
4100           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4101           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4102           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4103 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4104           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4105         enddo
4106       return
4107       end
4108 C-----------------------------------------------------------------------------
4109       subroutine vecpr(u,v,w)
4110       implicit real*8(a-h,o-z)
4111       dimension u(3),v(3),w(3)
4112       w(1)=u(2)*v(3)-u(3)*v(2)
4113       w(2)=-u(1)*v(3)+u(3)*v(1)
4114       w(3)=u(1)*v(2)-u(2)*v(1)
4115       return
4116       end
4117 C-----------------------------------------------------------------------------
4118       subroutine unormderiv(u,ugrad,unorm,ungrad)
4119 C This subroutine computes the derivatives of a normalized vector u, given
4120 C the derivatives computed without normalization conditions, ugrad. Returns
4121 C ungrad.
4122       implicit none
4123       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4124       double precision vec(3)
4125       double precision scalar
4126       integer i,j
4127 c      write (2,*) 'ugrad',ugrad
4128 c      write (2,*) 'u',u
4129       do i=1,3
4130         vec(i)=scalar(ugrad(1,i),u(1))
4131       enddo
4132 c      write (2,*) 'vec',vec
4133       do i=1,3
4134         do j=1,3
4135           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4136         enddo
4137       enddo
4138 c      write (2,*) 'ungrad',ungrad
4139       return
4140       end
4141 C-----------------------------------------------------------------------------
4142       subroutine escp_soft_sphere(evdw2,evdw2_14)
4143 C
4144 C This subroutine calculates the excluded-volume interaction energy between
4145 C peptide-group centers and side chains and its gradient in virtual-bond and
4146 C side-chain vectors.
4147 C
4148       implicit real*8 (a-h,o-z)
4149       include 'DIMENSIONS'
4150       include 'COMMON.GEO'
4151       include 'COMMON.VAR'
4152       include 'COMMON.LOCAL'
4153       include 'COMMON.CHAIN'
4154       include 'COMMON.DERIV'
4155       include 'COMMON.INTERACT'
4156       include 'COMMON.FFIELD'
4157       include 'COMMON.IOUNITS'
4158       include 'COMMON.CONTROL'
4159       dimension ggg(3)
4160       evdw2=0.0D0
4161       evdw2_14=0.0d0
4162       r0_scp=4.5d0
4163 cd    print '(a)','Enter ESCP'
4164 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4165       do i=iatscp_s,iatscp_e
4166         iteli=itel(i)
4167         xi=0.5D0*(c(1,i)+c(1,i+1))
4168         yi=0.5D0*(c(2,i)+c(2,i+1))
4169         zi=0.5D0*(c(3,i)+c(3,i+1))
4170
4171         do iint=1,nscp_gr(i)
4172
4173         do j=iscpstart(i,iint),iscpend(i,iint)
4174           itypj=itype(j)
4175 C Uncomment following three lines for SC-p interactions
4176 c         xj=c(1,nres+j)-xi
4177 c         yj=c(2,nres+j)-yi
4178 c         zj=c(3,nres+j)-zi
4179 C Uncomment following three lines for Ca-p interactions
4180           xj=c(1,j)-xi
4181           yj=c(2,j)-yi
4182           zj=c(3,j)-zi
4183           rij=xj*xj+yj*yj+zj*zj
4184           r0ij=r0_scp
4185           r0ijsq=r0ij*r0ij
4186           if (rij.lt.r0ijsq) then
4187             evdwij=0.25d0*(rij-r0ijsq)**2
4188             fac=rij-r0ijsq
4189           else
4190             evdwij=0.0d0
4191             fac=0.0d0
4192           endif
4193           evdw2=evdw2+evdwij
4194 C
4195 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4196 C
4197           ggg(1)=xj*fac
4198           ggg(2)=yj*fac
4199           ggg(3)=zj*fac
4200 cgrad          if (j.lt.i) then
4201 cd          write (iout,*) 'j<i'
4202 C Uncomment following three lines for SC-p interactions
4203 c           do k=1,3
4204 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4205 c           enddo
4206 cgrad          else
4207 cd          write (iout,*) 'j>i'
4208 cgrad            do k=1,3
4209 cgrad              ggg(k)=-ggg(k)
4210 C Uncomment following line for SC-p interactions
4211 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4212 cgrad            enddo
4213 cgrad          endif
4214 cgrad          do k=1,3
4215 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4216 cgrad          enddo
4217 cgrad          kstart=min0(i+1,j)
4218 cgrad          kend=max0(i-1,j-1)
4219 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4220 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4221 cgrad          do k=kstart,kend
4222 cgrad            do l=1,3
4223 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4224 cgrad            enddo
4225 cgrad          enddo
4226           do k=1,3
4227             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4228             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4229           enddo
4230         enddo
4231
4232         enddo ! iint
4233       enddo ! i
4234       return
4235       end
4236 C-----------------------------------------------------------------------------
4237       subroutine escp(evdw2,evdw2_14)
4238 C
4239 C This subroutine calculates the excluded-volume interaction energy between
4240 C peptide-group centers and side chains and its gradient in virtual-bond and
4241 C side-chain vectors.
4242 C
4243       implicit real*8 (a-h,o-z)
4244       include 'DIMENSIONS'
4245       include 'COMMON.GEO'
4246       include 'COMMON.VAR'
4247       include 'COMMON.LOCAL'
4248       include 'COMMON.CHAIN'
4249       include 'COMMON.DERIV'
4250       include 'COMMON.INTERACT'
4251       include 'COMMON.FFIELD'
4252       include 'COMMON.IOUNITS'
4253       include 'COMMON.CONTROL'
4254       dimension ggg(3)
4255       evdw2=0.0D0
4256       evdw2_14=0.0d0
4257 cd    print '(a)','Enter ESCP'
4258 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4259       do i=iatscp_s,iatscp_e
4260         iteli=itel(i)
4261         xi=0.5D0*(c(1,i)+c(1,i+1))
4262         yi=0.5D0*(c(2,i)+c(2,i+1))
4263         zi=0.5D0*(c(3,i)+c(3,i+1))
4264
4265         do iint=1,nscp_gr(i)
4266
4267         do j=iscpstart(i,iint),iscpend(i,iint)
4268           itypj=itype(j)
4269 C Uncomment following three lines for SC-p interactions
4270 c         xj=c(1,nres+j)-xi
4271 c         yj=c(2,nres+j)-yi
4272 c         zj=c(3,nres+j)-zi
4273 C Uncomment following three lines for Ca-p interactions
4274           xj=c(1,j)-xi
4275           yj=c(2,j)-yi
4276           zj=c(3,j)-zi
4277           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4278           fac=rrij**expon2
4279           e1=fac*fac*aad(itypj,iteli)
4280           e2=fac*bad(itypj,iteli)
4281           if (iabs(j-i) .le. 2) then
4282             e1=scal14*e1
4283             e2=scal14*e2
4284             evdw2_14=evdw2_14+e1+e2
4285           endif
4286           evdwij=e1+e2
4287           evdw2=evdw2+evdwij
4288           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4289      &        'evdw2',i,j,evdwij
4290 C
4291 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4292 C
4293           fac=-(evdwij+e1)*rrij
4294           ggg(1)=xj*fac
4295           ggg(2)=yj*fac
4296           ggg(3)=zj*fac
4297 cgrad          if (j.lt.i) then
4298 cd          write (iout,*) 'j<i'
4299 C Uncomment following three lines for SC-p interactions
4300 c           do k=1,3
4301 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4302 c           enddo
4303 cgrad          else
4304 cd          write (iout,*) 'j>i'
4305 cgrad            do k=1,3
4306 cgrad              ggg(k)=-ggg(k)
4307 C Uncomment following line for SC-p interactions
4308 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4309 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4310 cgrad            enddo
4311 cgrad          endif
4312 cgrad          do k=1,3
4313 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4314 cgrad          enddo
4315 cgrad          kstart=min0(i+1,j)
4316 cgrad          kend=max0(i-1,j-1)
4317 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4318 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4319 cgrad          do k=kstart,kend
4320 cgrad            do l=1,3
4321 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4322 cgrad            enddo
4323 cgrad          enddo
4324           do k=1,3
4325             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4326             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4327           enddo
4328         enddo
4329
4330         enddo ! iint
4331       enddo ! i
4332       do i=1,nct
4333         do j=1,3
4334           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4335           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4336           gradx_scp(j,i)=expon*gradx_scp(j,i)
4337         enddo
4338       enddo
4339 C******************************************************************************
4340 C
4341 C                              N O T E !!!
4342 C
4343 C To save time the factor EXPON has been extracted from ALL components
4344 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4345 C use!
4346 C
4347 C******************************************************************************
4348       return
4349       end
4350 C--------------------------------------------------------------------------
4351       subroutine edis(ehpb)
4352 C
4353 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4354 C
4355       implicit real*8 (a-h,o-z)
4356       include 'DIMENSIONS'
4357       include 'COMMON.SBRIDGE'
4358       include 'COMMON.CHAIN'
4359       include 'COMMON.DERIV'
4360       include 'COMMON.VAR'
4361       include 'COMMON.INTERACT'
4362       include 'COMMON.IOUNITS'
4363       dimension ggg(3)
4364       ehpb=0.0D0
4365 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4366 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4367       if (link_end.eq.0) return
4368       do i=link_start,link_end
4369 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4370 C CA-CA distance used in regularization of structure.
4371         ii=ihpb(i)
4372         jj=jhpb(i)
4373 C iii and jjj point to the residues for which the distance is assigned.
4374         if (ii.gt.nres) then
4375           iii=ii-nres
4376           jjj=jj-nres
4377         else
4378           iii=ii
4379           jjj=jj
4380         endif
4381 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4382 c     &    dhpb(i),dhpb1(i),forcon(i)
4383 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4384 C    distance and angle dependent SS bond potential.
4385 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4386 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4387         if (.not.dyn_ss .and. i.le.nss) then
4388 C 15/02/13 CC dynamic SSbond - additional check
4389          if (ii.gt.nres
4390      &       .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4391           call ssbond_ene(iii,jjj,eij)
4392           ehpb=ehpb+2*eij
4393          endif
4394 cd          write (iout,*) "eij",eij
4395         else if (ii.gt.nres .and. jj.gt.nres) then
4396 c Restraints from contact prediction
4397           dd=dist(ii,jj)
4398           if (dhpb1(i).gt.0.0d0) then
4399             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4400             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4401 c            write (iout,*) "beta nmr",
4402 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4403           else
4404             dd=dist(ii,jj)
4405             rdis=dd-dhpb(i)
4406 C Get the force constant corresponding to this distance.
4407             waga=forcon(i)
4408 C Calculate the contribution to energy.
4409             ehpb=ehpb+waga*rdis*rdis
4410 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
4411 C
4412 C Evaluate gradient.
4413 C
4414             fac=waga*rdis/dd
4415           endif
4416           do j=1,3
4417             ggg(j)=fac*(c(j,jj)-c(j,ii))
4418           enddo
4419           do j=1,3
4420             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4421             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4422           enddo
4423           do k=1,3
4424             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4425             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4426           enddo
4427         else
4428 C Calculate the distance between the two points and its difference from the
4429 C target distance.
4430           dd=dist(ii,jj)
4431           if (dhpb1(i).gt.0.0d0) then
4432             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4433             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4434 c            write (iout,*) "alph nmr",
4435 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4436           else
4437             rdis=dd-dhpb(i)
4438 C Get the force constant corresponding to this distance.
4439             waga=forcon(i)
4440 C Calculate the contribution to energy.
4441             ehpb=ehpb+waga*rdis*rdis
4442 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
4443 C
4444 C Evaluate gradient.
4445 C
4446             fac=waga*rdis/dd
4447           endif
4448 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4449 cd   &   ' waga=',waga,' fac=',fac
4450             do j=1,3
4451               ggg(j)=fac*(c(j,jj)-c(j,ii))
4452             enddo
4453 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4454 C If this is a SC-SC distance, we need to calculate the contributions to the
4455 C Cartesian gradient in the SC vectors (ghpbx).
4456           if (iii.lt.ii) then
4457           do j=1,3
4458             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4459             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4460           enddo
4461           endif
4462 cgrad        do j=iii,jjj-1
4463 cgrad          do k=1,3
4464 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4465 cgrad          enddo
4466 cgrad        enddo
4467           do k=1,3
4468             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4469             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4470           enddo
4471         endif
4472       enddo
4473       ehpb=0.5D0*ehpb
4474       return
4475       end
4476 C--------------------------------------------------------------------------
4477       subroutine ssbond_ene(i,j,eij)
4478 C
4479 C Calculate the distance and angle dependent SS-bond potential energy
4480 C using a free-energy function derived based on RHF/6-31G** ab initio
4481 C calculations of diethyl disulfide.
4482 C
4483 C A. Liwo and U. Kozlowska, 11/24/03
4484 C
4485       implicit real*8 (a-h,o-z)
4486       include 'DIMENSIONS'
4487       include 'COMMON.SBRIDGE'
4488       include 'COMMON.CHAIN'
4489       include 'COMMON.DERIV'
4490       include 'COMMON.LOCAL'
4491       include 'COMMON.INTERACT'
4492       include 'COMMON.VAR'
4493       include 'COMMON.IOUNITS'
4494       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4495       itypi=itype(i)
4496       xi=c(1,nres+i)
4497       yi=c(2,nres+i)
4498       zi=c(3,nres+i)
4499       dxi=dc_norm(1,nres+i)
4500       dyi=dc_norm(2,nres+i)
4501       dzi=dc_norm(3,nres+i)
4502 c      dsci_inv=dsc_inv(itypi)
4503       dsci_inv=vbld_inv(nres+i)
4504       itypj=itype(j)
4505 c      dscj_inv=dsc_inv(itypj)
4506       dscj_inv=vbld_inv(nres+j)
4507       xj=c(1,nres+j)-xi
4508       yj=c(2,nres+j)-yi
4509       zj=c(3,nres+j)-zi
4510       dxj=dc_norm(1,nres+j)
4511       dyj=dc_norm(2,nres+j)
4512       dzj=dc_norm(3,nres+j)
4513       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4514       rij=dsqrt(rrij)
4515       erij(1)=xj*rij
4516       erij(2)=yj*rij
4517       erij(3)=zj*rij
4518       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4519       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4520       om12=dxi*dxj+dyi*dyj+dzi*dzj
4521       do k=1,3
4522         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4523         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4524       enddo
4525       rij=1.0d0/rij
4526       deltad=rij-d0cm
4527       deltat1=1.0d0-om1
4528       deltat2=1.0d0+om2
4529       deltat12=om2-om1+2.0d0
4530       cosphi=om12-om1*om2
4531       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4532      &  +akct*deltad*deltat12+ebr
4533      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4534 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4535 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4536 c     &  " deltat12",deltat12," eij",eij
4537       ed=2*akcm*deltad+akct*deltat12
4538       pom1=akct*deltad
4539       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4540       eom1=-2*akth*deltat1-pom1-om2*pom2
4541       eom2= 2*akth*deltat2+pom1-om1*pom2
4542       eom12=pom2
4543       do k=1,3
4544         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4545         ghpbx(k,i)=ghpbx(k,i)-ggk
4546      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4547      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4548         ghpbx(k,j)=ghpbx(k,j)+ggk
4549      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4550      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4551         ghpbc(k,i)=ghpbc(k,i)-ggk
4552         ghpbc(k,j)=ghpbc(k,j)+ggk
4553       enddo
4554 C
4555 C Calculate the components of the gradient in DC and X
4556 C
4557 cgrad      do k=i,j-1
4558 cgrad        do l=1,3
4559 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4560 cgrad        enddo
4561 cgrad      enddo
4562       return
4563       end
4564 C--------------------------------------------------------------------------
4565       subroutine ebond(estr)
4566 c
4567 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4568 c
4569       implicit real*8 (a-h,o-z)
4570       include 'DIMENSIONS'
4571       include 'COMMON.LOCAL'
4572       include 'COMMON.GEO'
4573       include 'COMMON.INTERACT'
4574       include 'COMMON.DERIV'
4575       include 'COMMON.VAR'
4576       include 'COMMON.CHAIN'
4577       include 'COMMON.IOUNITS'
4578       include 'COMMON.NAMES'
4579       include 'COMMON.FFIELD'
4580       include 'COMMON.CONTROL'
4581       include 'COMMON.SETUP'
4582       double precision u(3),ud(3)
4583       estr=0.0d0
4584       do i=ibondp_start,ibondp_end
4585         diff = vbld(i)-vbldp0
4586 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4587         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
4588      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4589         estr=estr+diff*diff
4590         do j=1,3
4591           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4592         enddo
4593 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4594       enddo
4595       estr=0.5d0*AKP*estr
4596 c
4597 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4598 c
4599       do i=ibond_start,ibond_end
4600         iti=itype(i)
4601         if (iti.ne.10) then
4602           nbi=nbondterm(iti)
4603           if (nbi.eq.1) then
4604             diff=vbld(i+nres)-vbldsc0(1,iti)
4605 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4606 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4607             if (energy_dec)  write (iout,*)
4608      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4609      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4610             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4611             do j=1,3
4612               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4613             enddo
4614           else
4615             do j=1,nbi
4616               diff=vbld(i+nres)-vbldsc0(j,iti)
4617               ud(j)=aksc(j,iti)*diff
4618               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4619             enddo
4620             uprod=u(1)
4621             do j=2,nbi
4622               uprod=uprod*u(j)
4623             enddo
4624             usum=0.0d0
4625             usumsqder=0.0d0
4626             do j=1,nbi
4627               uprod1=1.0d0
4628               uprod2=1.0d0
4629               do k=1,nbi
4630                 if (k.ne.j) then
4631                   uprod1=uprod1*u(k)
4632                   uprod2=uprod2*u(k)*u(k)
4633                 endif
4634               enddo
4635               usum=usum+uprod1
4636               usumsqder=usumsqder+ud(j)*uprod2
4637             enddo
4638             estr=estr+uprod/usum
4639             do j=1,3
4640              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4641             enddo
4642           endif
4643         endif
4644       enddo
4645       return
4646       end
4647 #ifdef CRYST_THETA
4648 C--------------------------------------------------------------------------
4649       subroutine ebend(etheta)
4650 C
4651 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4652 C angles gamma and its derivatives in consecutive thetas and gammas.
4653 C
4654       implicit real*8 (a-h,o-z)
4655       include 'DIMENSIONS'
4656       include 'COMMON.LOCAL'
4657       include 'COMMON.GEO'
4658       include 'COMMON.INTERACT'
4659       include 'COMMON.DERIV'
4660       include 'COMMON.VAR'
4661       include 'COMMON.CHAIN'
4662       include 'COMMON.IOUNITS'
4663       include 'COMMON.NAMES'
4664       include 'COMMON.FFIELD'
4665       include 'COMMON.CONTROL'
4666       common /calcthet/ term1,term2,termm,diffak,ratak,
4667      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4668      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4669       double precision y(2),z(2)
4670       delta=0.02d0*pi
4671 c      time11=dexp(-2*time)
4672 c      time12=1.0d0
4673       etheta=0.0D0
4674 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4675       do i=ithet_start,ithet_end
4676 C Zero the energy function and its derivative at 0 or pi.
4677         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4678         it=itype(i-1)
4679         if (i.gt.3) then
4680 #ifdef OSF
4681           phii=phi(i)
4682           if (phii.ne.phii) phii=150.0
4683 #else
4684           phii=phi(i)
4685 #endif
4686           y(1)=dcos(phii)
4687           y(2)=dsin(phii)
4688         else
4689           y(1)=0.0D0
4690           y(2)=0.0D0
4691         endif
4692         if (i.lt.nres) then
4693 #ifdef OSF
4694           phii1=phi(i+1)
4695           if (phii1.ne.phii1) phii1=150.0
4696           phii1=pinorm(phii1)
4697           z(1)=cos(phii1)
4698 #else
4699           phii1=phi(i+1)
4700           z(1)=dcos(phii1)
4701 #endif
4702           z(2)=dsin(phii1)
4703         else
4704           z(1)=0.0D0
4705           z(2)=0.0D0
4706         endif
4707 C Calculate the "mean" value of theta from the part of the distribution
4708 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4709 C In following comments this theta will be referred to as t_c.
4710         thet_pred_mean=0.0d0
4711         do k=1,2
4712           athetk=athet(k,it)
4713           bthetk=bthet(k,it)
4714           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4715         enddo
4716         dthett=thet_pred_mean*ssd
4717         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4718 C Derivatives of the "mean" values in gamma1 and gamma2.
4719         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
4720         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
4721         if (theta(i).gt.pi-delta) then
4722           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4723      &         E_tc0)
4724           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4725           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4726           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4727      &        E_theta)
4728           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4729      &        E_tc)
4730         else if (theta(i).lt.delta) then
4731           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4732           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4733           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4734      &        E_theta)
4735           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4736           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4737      &        E_tc)
4738         else
4739           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4740      &        E_theta,E_tc)
4741         endif
4742         etheta=etheta+ethetai
4743         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4744      &      'ebend',i,ethetai
4745         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4746         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4747         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
4748       enddo
4749 C Ufff.... We've done all this!!!
4750       return
4751       end
4752 C---------------------------------------------------------------------------
4753       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4754      &     E_tc)
4755       implicit real*8 (a-h,o-z)
4756       include 'DIMENSIONS'
4757       include 'COMMON.LOCAL'
4758       include 'COMMON.IOUNITS'
4759       common /calcthet/ term1,term2,termm,diffak,ratak,
4760      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4761      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4762 C Calculate the contributions to both Gaussian lobes.
4763 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4764 C The "polynomial part" of the "standard deviation" of this part of
4765 C the distribution.
4766         sig=polthet(3,it)
4767         do j=2,0,-1
4768           sig=sig*thet_pred_mean+polthet(j,it)
4769         enddo
4770 C Derivative of the "interior part" of the "standard deviation of the"
4771 C gamma-dependent Gaussian lobe in t_c.
4772         sigtc=3*polthet(3,it)
4773         do j=2,1,-1
4774           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4775         enddo
4776         sigtc=sig*sigtc
4777 C Set the parameters of both Gaussian lobes of the distribution.
4778 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4779         fac=sig*sig+sigc0(it)
4780         sigcsq=fac+fac
4781         sigc=1.0D0/sigcsq
4782 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4783         sigsqtc=-4.0D0*sigcsq*sigtc
4784 c       print *,i,sig,sigtc,sigsqtc
4785 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4786         sigtc=-sigtc/(fac*fac)
4787 C Following variable is sigma(t_c)**(-2)
4788         sigcsq=sigcsq*sigcsq
4789         sig0i=sig0(it)
4790         sig0inv=1.0D0/sig0i**2
4791         delthec=thetai-thet_pred_mean
4792         delthe0=thetai-theta0i
4793         term1=-0.5D0*sigcsq*delthec*delthec
4794         term2=-0.5D0*sig0inv*delthe0*delthe0
4795 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4796 C NaNs in taking the logarithm. We extract the largest exponent which is added
4797 C to the energy (this being the log of the distribution) at the end of energy
4798 C term evaluation for this virtual-bond angle.
4799         if (term1.gt.term2) then
4800           termm=term1
4801           term2=dexp(term2-termm)
4802           term1=1.0d0
4803         else
4804           termm=term2
4805           term1=dexp(term1-termm)
4806           term2=1.0d0
4807         endif
4808 C The ratio between the gamma-independent and gamma-dependent lobes of
4809 C the distribution is a Gaussian function of thet_pred_mean too.
4810         diffak=gthet(2,it)-thet_pred_mean
4811         ratak=diffak/gthet(3,it)**2
4812         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4813 C Let's differentiate it in thet_pred_mean NOW.
4814         aktc=ak*ratak
4815 C Now put together the distribution terms to make complete distribution.
4816         termexp=term1+ak*term2
4817         termpre=sigc+ak*sig0i
4818 C Contribution of the bending energy from this theta is just the -log of
4819 C the sum of the contributions from the two lobes and the pre-exponential
4820 C factor. Simple enough, isn't it?
4821         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4822 C NOW the derivatives!!!
4823 C 6/6/97 Take into account the deformation.
4824         E_theta=(delthec*sigcsq*term1
4825      &       +ak*delthe0*sig0inv*term2)/termexp
4826         E_tc=((sigtc+aktc*sig0i)/termpre
4827      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4828      &       aktc*term2)/termexp)
4829       return
4830       end
4831 c-----------------------------------------------------------------------------
4832       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4833       implicit real*8 (a-h,o-z)
4834       include 'DIMENSIONS'
4835       include 'COMMON.LOCAL'
4836       include 'COMMON.IOUNITS'
4837       common /calcthet/ term1,term2,termm,diffak,ratak,
4838      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4839      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4840       delthec=thetai-thet_pred_mean
4841       delthe0=thetai-theta0i
4842 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4843       t3 = thetai-thet_pred_mean
4844       t6 = t3**2
4845       t9 = term1
4846       t12 = t3*sigcsq
4847       t14 = t12+t6*sigsqtc
4848       t16 = 1.0d0
4849       t21 = thetai-theta0i
4850       t23 = t21**2
4851       t26 = term2
4852       t27 = t21*t26
4853       t32 = termexp
4854       t40 = t32**2
4855       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4856      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4857      & *(-t12*t9-ak*sig0inv*t27)
4858       return
4859       end
4860 #else
4861 C--------------------------------------------------------------------------
4862       subroutine ebend(etheta)
4863 C
4864 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4865 C angles gamma and its derivatives in consecutive thetas and gammas.
4866 C ab initio-derived potentials from
4867 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4868 C
4869       implicit real*8 (a-h,o-z)
4870       include 'DIMENSIONS'
4871       include 'COMMON.LOCAL'
4872       include 'COMMON.GEO'
4873       include 'COMMON.INTERACT'
4874       include 'COMMON.DERIV'
4875       include 'COMMON.VAR'
4876       include 'COMMON.CHAIN'
4877       include 'COMMON.IOUNITS'
4878       include 'COMMON.NAMES'
4879       include 'COMMON.FFIELD'
4880       include 'COMMON.CONTROL'
4881       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4882      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4883      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4884      & sinph1ph2(maxdouble,maxdouble)
4885       logical lprn /.false./, lprn1 /.false./
4886       etheta=0.0D0
4887 c      write (iout,*) "EBEND ithet_start",ithet_start,
4888 c     &     " ithet_end",ithet_end
4889       do i=ithet_start,ithet_end
4890         if ((itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
4891      &(itype(i).eq.ntyp1)) cycle
4892         dethetai=0.0d0
4893         dephii=0.0d0
4894         dephii1=0.0d0
4895         theti2=0.5d0*theta(i)
4896         ityp2=ithetyp(itype(i-1))
4897         do k=1,nntheterm
4898           coskt(k)=dcos(k*theti2)
4899           sinkt(k)=dsin(k*theti2)
4900         enddo
4901 C        if (i.gt.3) then
4902          if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4903 #ifdef OSF
4904           phii=phi(i)
4905           if (phii.ne.phii) phii=150.0
4906 #else
4907           phii=phi(i)
4908 #endif
4909           ityp1=ithetyp(itype(i-2))
4910           do k=1,nsingle
4911             cosph1(k)=dcos(k*phii)
4912             sinph1(k)=dsin(k*phii)
4913           enddo
4914         else
4915           phii=0.0d0
4916           ityp1=ithetyp(itype(i-2))
4917           do k=1,nsingle
4918             cosph1(k)=0.0d0
4919             sinph1(k)=0.0d0
4920           enddo
4921         endif
4922         if ((i.lt.nres).and. itype(i+1).ne.ntyp1) then
4923 #ifdef OSF
4924           phii1=phi(i+1)
4925           if (phii1.ne.phii1) phii1=150.0
4926           phii1=pinorm(phii1)
4927 #else
4928           phii1=phi(i+1)
4929 #endif
4930           ityp3=ithetyp(itype(i))
4931           do k=1,nsingle
4932             cosph2(k)=dcos(k*phii1)
4933             sinph2(k)=dsin(k*phii1)
4934           enddo
4935         else
4936           phii1=0.0d0
4937           ityp3=ithetyp(itype(i))
4938           do k=1,nsingle
4939             cosph2(k)=0.0d0
4940             sinph2(k)=0.0d0
4941           enddo
4942         endif
4943         ethetai=aa0thet(ityp1,ityp2,ityp3)
4944         do k=1,ndouble
4945           do l=1,k-1
4946             ccl=cosph1(l)*cosph2(k-l)
4947             ssl=sinph1(l)*sinph2(k-l)
4948             scl=sinph1(l)*cosph2(k-l)
4949             csl=cosph1(l)*sinph2(k-l)
4950             cosph1ph2(l,k)=ccl-ssl
4951             cosph1ph2(k,l)=ccl+ssl
4952             sinph1ph2(l,k)=scl+csl
4953             sinph1ph2(k,l)=scl-csl
4954           enddo
4955         enddo
4956         if (lprn) then
4957         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4958      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4959         write (iout,*) "coskt and sinkt"
4960         do k=1,nntheterm
4961           write (iout,*) k,coskt(k),sinkt(k)
4962         enddo
4963         endif
4964         do k=1,ntheterm
4965           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4966           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4967      &      *coskt(k)
4968           if (lprn)
4969      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4970      &     " ethetai",ethetai
4971         enddo
4972         if (lprn) then
4973         write (iout,*) "cosph and sinph"
4974         do k=1,nsingle
4975           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4976         enddo
4977         write (iout,*) "cosph1ph2 and sinph2ph2"
4978         do k=2,ndouble
4979           do l=1,k-1
4980             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4981      &         sinph1ph2(l,k),sinph1ph2(k,l)
4982           enddo
4983         enddo
4984         write(iout,*) "ethetai",ethetai
4985         endif
4986         do m=1,ntheterm2
4987           do k=1,nsingle
4988             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4989      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4990      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4991      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4992             ethetai=ethetai+sinkt(m)*aux
4993             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4994             dephii=dephii+k*sinkt(m)*(
4995      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4996      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4997             dephii1=dephii1+k*sinkt(m)*(
4998      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4999      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
5000             if (lprn)
5001      &      write (iout,*) "m",m," k",k," bbthet",
5002      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
5003      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
5004      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
5005      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
5006           enddo
5007         enddo
5008         if (lprn)
5009      &  write(iout,*) "ethetai",ethetai
5010         do m=1,ntheterm3
5011           do k=2,ndouble
5012             do l=1,k-1
5013               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
5014      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
5015      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
5016      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
5017               ethetai=ethetai+sinkt(m)*aux
5018               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5019               dephii=dephii+l*sinkt(m)*(
5020      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
5021      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
5022      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
5023      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
5024               dephii1=dephii1+(k-l)*sinkt(m)*(
5025      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
5026      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
5027      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
5028      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
5029               if (lprn) then
5030               write (iout,*) "m",m," k",k," l",l," ffthet",
5031      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
5032      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
5033      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
5034      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
5035               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5036      &            cosph1ph2(k,l)*sinkt(m),
5037      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5038               endif
5039             enddo
5040           enddo
5041         enddo
5042 10      continue
5043 c        lprn1=.true.
5044         if (lprn1) write (iout,'(a4,i2,3f8.1,9h ethetai ,f10.5)')
5045      &  'ebe', i,theta(i)*rad2deg,phii*rad2deg,
5046      &   phii1*rad2deg,ethetai
5047 c        lprn1=.false.
5048         etheta=etheta+ethetai
5049         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5050      &      'ebend',i,ethetai
5051         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5052         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5053         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
5054       enddo
5055       return
5056       end
5057 #endif
5058 #ifdef CRYST_SC
5059 c-----------------------------------------------------------------------------
5060       subroutine esc(escloc)
5061 C Calculate the local energy of a side chain and its derivatives in the
5062 C corresponding virtual-bond valence angles THETA and the spherical angles
5063 C ALPHA and OMEGA.
5064       implicit real*8 (a-h,o-z)
5065       include 'DIMENSIONS'
5066       include 'COMMON.GEO'
5067       include 'COMMON.LOCAL'
5068       include 'COMMON.VAR'
5069       include 'COMMON.INTERACT'
5070       include 'COMMON.DERIV'
5071       include 'COMMON.CHAIN'
5072       include 'COMMON.IOUNITS'
5073       include 'COMMON.NAMES'
5074       include 'COMMON.FFIELD'
5075       include 'COMMON.CONTROL'
5076       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5077      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5078       common /sccalc/ time11,time12,time112,theti,it,nlobit
5079       delta=0.02d0*pi
5080       escloc=0.0D0
5081 c     write (iout,'(a)') 'ESC'
5082       do i=loc_start,loc_end
5083         it=itype(i)
5084         if (it.eq.10) goto 1
5085         nlobit=nlob(it)
5086 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5087 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5088         theti=theta(i+1)-pipol
5089         x(1)=dtan(theti)
5090         x(2)=alph(i)
5091         x(3)=omeg(i)
5092
5093         if (x(2).gt.pi-delta) then
5094           xtemp(1)=x(1)
5095           xtemp(2)=pi-delta
5096           xtemp(3)=x(3)
5097           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5098           xtemp(2)=pi
5099           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5100           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5101      &        escloci,dersc(2))
5102           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5103      &        ddersc0(1),dersc(1))
5104           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5105      &        ddersc0(3),dersc(3))
5106           xtemp(2)=pi-delta
5107           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5108           xtemp(2)=pi
5109           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5110           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5111      &            dersc0(2),esclocbi,dersc02)
5112           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5113      &            dersc12,dersc01)
5114           call splinthet(x(2),0.5d0*delta,ss,ssd)
5115           dersc0(1)=dersc01
5116           dersc0(2)=dersc02
5117           dersc0(3)=0.0d0
5118           do k=1,3
5119             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5120           enddo
5121           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5122 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5123 c    &             esclocbi,ss,ssd
5124           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5125 c         escloci=esclocbi
5126 c         write (iout,*) escloci
5127         else if (x(2).lt.delta) then
5128           xtemp(1)=x(1)
5129           xtemp(2)=delta
5130           xtemp(3)=x(3)
5131           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5132           xtemp(2)=0.0d0
5133           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5134           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5135      &        escloci,dersc(2))
5136           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5137      &        ddersc0(1),dersc(1))
5138           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5139      &        ddersc0(3),dersc(3))
5140           xtemp(2)=delta
5141           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5142           xtemp(2)=0.0d0
5143           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5144           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5145      &            dersc0(2),esclocbi,dersc02)
5146           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5147      &            dersc12,dersc01)
5148           dersc0(1)=dersc01
5149           dersc0(2)=dersc02
5150           dersc0(3)=0.0d0
5151           call splinthet(x(2),0.5d0*delta,ss,ssd)
5152           do k=1,3
5153             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5154           enddo
5155           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5156 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5157 c    &             esclocbi,ss,ssd
5158           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5159 c         write (iout,*) escloci
5160         else
5161           call enesc(x,escloci,dersc,ddummy,.false.)
5162         endif
5163
5164         escloc=escloc+escloci
5165         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5166      &     'escloc',i,escloci
5167 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5168
5169         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5170      &   wscloc*dersc(1)
5171         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5172         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5173     1   continue
5174       enddo
5175       return
5176       end
5177 C---------------------------------------------------------------------------
5178       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5179       implicit real*8 (a-h,o-z)
5180       include 'DIMENSIONS'
5181       include 'COMMON.GEO'
5182       include 'COMMON.LOCAL'
5183       include 'COMMON.IOUNITS'
5184       common /sccalc/ time11,time12,time112,theti,it,nlobit
5185       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5186       double precision contr(maxlob,-1:1)
5187       logical mixed
5188 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5189         escloc_i=0.0D0
5190         do j=1,3
5191           dersc(j)=0.0D0
5192           if (mixed) ddersc(j)=0.0d0
5193         enddo
5194         x3=x(3)
5195
5196 C Because of periodicity of the dependence of the SC energy in omega we have
5197 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5198 C To avoid underflows, first compute & store the exponents.
5199
5200         do iii=-1,1
5201
5202           x(3)=x3+iii*dwapi
5203
5204           do j=1,nlobit
5205             do k=1,3
5206               z(k)=x(k)-censc(k,j,it)
5207             enddo
5208             do k=1,3
5209               Axk=0.0D0
5210               do l=1,3
5211                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5212               enddo
5213               Ax(k,j,iii)=Axk
5214             enddo
5215             expfac=0.0D0
5216             do k=1,3
5217               expfac=expfac+Ax(k,j,iii)*z(k)
5218             enddo
5219             contr(j,iii)=expfac
5220           enddo ! j
5221
5222         enddo ! iii
5223
5224         x(3)=x3
5225 C As in the case of ebend, we want to avoid underflows in exponentiation and
5226 C subsequent NaNs and INFs in energy calculation.
5227 C Find the largest exponent
5228         emin=contr(1,-1)
5229         do iii=-1,1
5230           do j=1,nlobit
5231             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5232           enddo
5233         enddo
5234         emin=0.5D0*emin
5235 cd      print *,'it=',it,' emin=',emin
5236
5237 C Compute the contribution to SC energy and derivatives
5238         do iii=-1,1
5239
5240           do j=1,nlobit
5241 #ifdef OSF
5242             adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin
5243             if(adexp.ne.adexp) adexp=1.0
5244             expfac=dexp(adexp)
5245 #else
5246             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
5247 #endif
5248 cd          print *,'j=',j,' expfac=',expfac
5249             escloc_i=escloc_i+expfac
5250             do k=1,3
5251               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5252             enddo
5253             if (mixed) then
5254               do k=1,3,2
5255                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5256      &            +gaussc(k,2,j,it))*expfac
5257               enddo
5258             endif
5259           enddo
5260
5261         enddo ! iii
5262
5263         dersc(1)=dersc(1)/cos(theti)**2
5264         ddersc(1)=ddersc(1)/cos(theti)**2
5265         ddersc(3)=ddersc(3)
5266
5267         escloci=-(dlog(escloc_i)-emin)
5268         do j=1,3
5269           dersc(j)=dersc(j)/escloc_i
5270         enddo
5271         if (mixed) then
5272           do j=1,3,2
5273             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5274           enddo
5275         endif
5276       return
5277       end
5278 C------------------------------------------------------------------------------
5279       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5280       implicit real*8 (a-h,o-z)
5281       include 'DIMENSIONS'
5282       include 'COMMON.GEO'
5283       include 'COMMON.LOCAL'
5284       include 'COMMON.IOUNITS'
5285       common /sccalc/ time11,time12,time112,theti,it,nlobit
5286       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5287       double precision contr(maxlob)
5288       logical mixed
5289
5290       escloc_i=0.0D0
5291
5292       do j=1,3
5293         dersc(j)=0.0D0
5294       enddo
5295
5296       do j=1,nlobit
5297         do k=1,2
5298           z(k)=x(k)-censc(k,j,it)
5299         enddo
5300         z(3)=dwapi
5301         do k=1,3
5302           Axk=0.0D0
5303           do l=1,3
5304             Axk=Axk+gaussc(l,k,j,it)*z(l)
5305           enddo
5306           Ax(k,j)=Axk
5307         enddo
5308         expfac=0.0D0
5309         do k=1,3
5310           expfac=expfac+Ax(k,j)*z(k)
5311         enddo
5312         contr(j)=expfac
5313       enddo ! j
5314
5315 C As in the case of ebend, we want to avoid underflows in exponentiation and
5316 C subsequent NaNs and INFs in energy calculation.
5317 C Find the largest exponent
5318       emin=contr(1)
5319       do j=1,nlobit
5320         if (emin.gt.contr(j)) emin=contr(j)
5321       enddo
5322       emin=0.5D0*emin
5323
5324 C Compute the contribution to SC energy and derivatives
5325
5326       dersc12=0.0d0
5327       do j=1,nlobit
5328         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
5329         escloc_i=escloc_i+expfac
5330         do k=1,2
5331           dersc(k)=dersc(k)+Ax(k,j)*expfac
5332         enddo
5333         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5334      &            +gaussc(1,2,j,it))*expfac
5335         dersc(3)=0.0d0
5336       enddo
5337
5338       dersc(1)=dersc(1)/cos(theti)**2
5339       dersc12=dersc12/cos(theti)**2
5340       escloci=-(dlog(escloc_i)-emin)
5341       do j=1,2
5342         dersc(j)=dersc(j)/escloc_i
5343       enddo
5344       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5345       return
5346       end
5347 #else
5348 c----------------------------------------------------------------------------------
5349       subroutine esc(escloc)
5350 C Calculate the local energy of a side chain and its derivatives in the
5351 C corresponding virtual-bond valence angles THETA and the spherical angles
5352 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5353 C added by Urszula Kozlowska. 07/11/2007
5354 C
5355       implicit real*8 (a-h,o-z)
5356       include 'DIMENSIONS'
5357       include 'COMMON.GEO'
5358       include 'COMMON.LOCAL'
5359       include 'COMMON.VAR'
5360       include 'COMMON.SCROT'
5361       include 'COMMON.INTERACT'
5362       include 'COMMON.DERIV'
5363       include 'COMMON.CHAIN'
5364       include 'COMMON.IOUNITS'
5365       include 'COMMON.NAMES'
5366       include 'COMMON.FFIELD'
5367       include 'COMMON.CONTROL'
5368       include 'COMMON.VECTORS'
5369       double precision x_prime(3),y_prime(3),z_prime(3)
5370      &    , sumene,dsc_i,dp2_i,x(65),
5371      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5372      &    de_dxx,de_dyy,de_dzz,de_dt
5373       double precision s1_t,s1_6_t,s2_t,s2_6_t
5374       double precision
5375      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5376      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5377      & dt_dCi(3),dt_dCi1(3)
5378       common /sccalc/ time11,time12,time112,theti,it,nlobit
5379       delta=0.02d0*pi
5380       escloc=0.0D0
5381 c      write(iout,*) "ESC: loc_start",loc_start," loc_end",loc_end
5382       do i=loc_start,loc_end
5383         costtab(i+1) =dcos(theta(i+1))
5384         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5385         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5386         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5387         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5388         cosfac=dsqrt(cosfac2)
5389         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5390         sinfac=dsqrt(sinfac2)
5391         it=itype(i)
5392         if (it.eq.10) goto 1
5393 c
5394 C  Compute the axes of tghe local cartesian coordinates system; store in
5395 c   x_prime, y_prime and z_prime
5396 c
5397         do j=1,3
5398           x_prime(j) = 0.00
5399           y_prime(j) = 0.00
5400           z_prime(j) = 0.00
5401         enddo
5402 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5403 C     &   dc_norm(3,i+nres)
5404         do j = 1,3
5405           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5406           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5407         enddo
5408         do j = 1,3
5409           z_prime(j) = -uz(j,i-1)
5410         enddo
5411 c       write (2,*) "i",i
5412 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5413 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5414 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5415 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5416 c      & " xy",scalar(x_prime(1),y_prime(1)),
5417 c      & " xz",scalar(x_prime(1),z_prime(1)),
5418 c      & " yy",scalar(y_prime(1),y_prime(1)),
5419 c      & " yz",scalar(y_prime(1),z_prime(1)),
5420 c      & " zz",scalar(z_prime(1),z_prime(1))
5421 c
5422 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5423 C to local coordinate system. Store in xx, yy, zz.
5424 c
5425         xx=0.0d0
5426         yy=0.0d0
5427         zz=0.0d0
5428         do j = 1,3
5429           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5430           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5431           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5432         enddo
5433
5434         xxtab(i)=xx
5435         yytab(i)=yy
5436         zztab(i)=zz
5437 C
5438 C Compute the energy of the ith side cbain
5439 C
5440 c        write (2,*) "xx",xx," yy",yy," zz",zz
5441         it=itype(i)
5442         do j = 1,65
5443           x(j) = sc_parmin(j,it)
5444         enddo
5445 #ifdef CHECK_COORD
5446 Cc diagnostics - remove later
5447         xx1 = dcos(alph(2))
5448         yy1 = dsin(alph(2))*dcos(omeg(2))
5449         zz1 = -dsin(alph(2))*dsin(omeg(2))
5450         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5451      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5452      &    xx1,yy1,zz1
5453 C,"  --- ", xx_w,yy_w,zz_w
5454 c end diagnostics
5455 #endif
5456         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5457      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5458      &   + x(10)*yy*zz
5459         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5460      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5461      & + x(20)*yy*zz
5462         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5463      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5464      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5465      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5466      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5467      &  +x(40)*xx*yy*zz
5468         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5469      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5470      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5471      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5472      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5473      &  +x(60)*xx*yy*zz
5474         dsc_i   = 0.743d0+x(61)
5475         dp2_i   = 1.9d0+x(62)
5476         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5477      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5478         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5479      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5480         s1=(1+x(63))/(0.1d0 + dscp1)
5481         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5482         s2=(1+x(65))/(0.1d0 + dscp2)
5483         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5484         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5485      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5486 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5487 c     &   sumene4,
5488 c     &   dscp1,dscp2,sumene
5489 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5490         escloc = escloc + sumene
5491 c        write (2,*) "i",i," escloc",sumene,escloc
5492 #ifdef DEBUG
5493 C
5494 C This section to check the numerical derivatives of the energy of ith side
5495 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5496 C #define DEBUG in the code to turn it on.
5497 C
5498         write (2,*) "sumene               =",sumene
5499         aincr=1.0d-7
5500         xxsave=xx
5501         xx=xx+aincr
5502         write (2,*) xx,yy,zz
5503         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5504         de_dxx_num=(sumenep-sumene)/aincr
5505         xx=xxsave
5506         write (2,*) "xx+ sumene from enesc=",sumenep
5507         yysave=yy
5508         yy=yy+aincr
5509         write (2,*) xx,yy,zz
5510         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5511         de_dyy_num=(sumenep-sumene)/aincr
5512         yy=yysave
5513         write (2,*) "yy+ sumene from enesc=",sumenep
5514         zzsave=zz
5515         zz=zz+aincr
5516         write (2,*) xx,yy,zz
5517         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5518         de_dzz_num=(sumenep-sumene)/aincr
5519         zz=zzsave
5520         write (2,*) "zz+ sumene from enesc=",sumenep
5521         costsave=cost2tab(i+1)
5522         sintsave=sint2tab(i+1)
5523         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5524         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5525         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5526         de_dt_num=(sumenep-sumene)/aincr
5527         write (2,*) " t+ sumene from enesc=",sumenep
5528         cost2tab(i+1)=costsave
5529         sint2tab(i+1)=sintsave
5530 C End of diagnostics section.
5531 #endif
5532 C
5533 C Compute the gradient of esc
5534 C
5535         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5536         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5537         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5538         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5539         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5540         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5541         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5542         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5543         pom1=(sumene3*sint2tab(i+1)+sumene1)
5544      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5545         pom2=(sumene4*cost2tab(i+1)+sumene2)
5546      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5547         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5548         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5549      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5550      &  +x(40)*yy*zz
5551         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5552         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5553      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5554      &  +x(60)*yy*zz
5555         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5556      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5557      &        +(pom1+pom2)*pom_dx
5558 #ifdef DEBUG
5559         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5560 #endif
5561 C
5562         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5563         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5564      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5565      &  +x(40)*xx*zz
5566         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5567         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5568      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5569      &  +x(59)*zz**2 +x(60)*xx*zz
5570         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5571      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5572      &        +(pom1-pom2)*pom_dy
5573 #ifdef DEBUG
5574         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5575 #endif
5576 C
5577         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5578      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5579      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5580      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5581      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5582      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5583      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5584      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5585 #ifdef DEBUG
5586         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5587 #endif
5588 C
5589         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5590      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5591      &  +pom1*pom_dt1+pom2*pom_dt2
5592 #ifdef DEBUG
5593         write(2,*), "de_dt = ", de_dt,de_dt_num
5594 #endif
5595 c
5596 C
5597        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5598        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5599        cosfac2xx=cosfac2*xx
5600        sinfac2yy=sinfac2*yy
5601        do k = 1,3
5602          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5603      &      vbld_inv(i+1)
5604          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5605      &      vbld_inv(i)
5606          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5607          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5608 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5609 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5610 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5611 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5612          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5613          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5614          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5615          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5616          dZZ_Ci1(k)=0.0d0
5617          dZZ_Ci(k)=0.0d0
5618          do j=1,3
5619            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5620            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5621          enddo
5622
5623          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5624          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5625          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5626 c
5627          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5628          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5629        enddo
5630
5631        do k=1,3
5632          dXX_Ctab(k,i)=dXX_Ci(k)
5633          dXX_C1tab(k,i)=dXX_Ci1(k)
5634          dYY_Ctab(k,i)=dYY_Ci(k)
5635          dYY_C1tab(k,i)=dYY_Ci1(k)
5636          dZZ_Ctab(k,i)=dZZ_Ci(k)
5637          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5638          dXX_XYZtab(k,i)=dXX_XYZ(k)
5639          dYY_XYZtab(k,i)=dYY_XYZ(k)
5640          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5641        enddo
5642
5643        do k = 1,3
5644 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5645 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5646 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5647 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5648 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5649 c     &    dt_dci(k)
5650 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5651 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5652          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5653      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5654          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5655      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5656          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5657      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5658        enddo
5659 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5660 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5661
5662 C to check gradient call subroutine check_grad
5663
5664     1 continue
5665       enddo
5666       return
5667       end
5668 c------------------------------------------------------------------------------
5669       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5670       implicit none
5671       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5672      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5673       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5674      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5675      &   + x(10)*yy*zz
5676       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5677      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5678      & + x(20)*yy*zz
5679       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5680      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5681      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5682      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5683      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5684      &  +x(40)*xx*yy*zz
5685       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5686      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5687      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5688      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5689      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5690      &  +x(60)*xx*yy*zz
5691       dsc_i   = 0.743d0+x(61)
5692       dp2_i   = 1.9d0+x(62)
5693       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5694      &          *(xx*cost2+yy*sint2))
5695       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5696      &          *(xx*cost2-yy*sint2))
5697       s1=(1+x(63))/(0.1d0 + dscp1)
5698       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5699       s2=(1+x(65))/(0.1d0 + dscp2)
5700       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5701       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5702      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5703       enesc=sumene
5704       return
5705       end
5706 #endif
5707 c------------------------------------------------------------------------------
5708       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5709 C
5710 C This procedure calculates two-body contact function g(rij) and its derivative:
5711 C
5712 C           eps0ij                                     !       x < -1
5713 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5714 C            0                                         !       x > 1
5715 C
5716 C where x=(rij-r0ij)/delta
5717 C
5718 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5719 C
5720       implicit none
5721       double precision rij,r0ij,eps0ij,fcont,fprimcont
5722       double precision x,x2,x4,delta
5723 c     delta=0.02D0*r0ij
5724 c      delta=0.2D0*r0ij
5725       x=(rij-r0ij)/delta
5726       if (x.lt.-1.0D0) then
5727         fcont=eps0ij
5728         fprimcont=0.0D0
5729       else if (x.le.1.0D0) then
5730         x2=x*x
5731         x4=x2*x2
5732         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5733         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5734       else
5735         fcont=0.0D0
5736         fprimcont=0.0D0
5737       endif
5738       return
5739       end
5740 c------------------------------------------------------------------------------
5741       subroutine splinthet(theti,delta,ss,ssder)
5742       implicit real*8 (a-h,o-z)
5743       include 'DIMENSIONS'
5744       include 'COMMON.VAR'
5745       include 'COMMON.GEO'
5746       thetup=pi-delta
5747       thetlow=delta
5748       if (theti.gt.pipol) then
5749         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5750       else
5751         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5752         ssder=-ssder
5753       endif
5754       return
5755       end
5756 c------------------------------------------------------------------------------
5757       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5758       implicit none
5759       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5760       double precision ksi,ksi2,ksi3,a1,a2,a3
5761       a1=fprim0*delta/(f1-f0)
5762       a2=3.0d0-2.0d0*a1
5763       a3=a1-2.0d0
5764       ksi=(x-x0)/delta
5765       ksi2=ksi*ksi
5766       ksi3=ksi2*ksi
5767       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5768       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5769       return
5770       end
5771 c------------------------------------------------------------------------------
5772       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5773       implicit none
5774       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5775       double precision ksi,ksi2,ksi3,a1,a2,a3
5776       ksi=(x-x0)/delta
5777       ksi2=ksi*ksi
5778       ksi3=ksi2*ksi
5779       a1=fprim0x*delta
5780       a2=3*(f1x-f0x)-2*fprim0x*delta
5781       a3=fprim0x*delta-2*(f1x-f0x)
5782       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5783       return
5784       end
5785 C-----------------------------------------------------------------------------
5786 #ifdef CRYST_TOR
5787 C-----------------------------------------------------------------------------
5788       subroutine etor(etors,edihcnstr)
5789       implicit real*8 (a-h,o-z)
5790       include 'DIMENSIONS'
5791       include 'COMMON.VAR'
5792       include 'COMMON.GEO'
5793       include 'COMMON.LOCAL'
5794       include 'COMMON.TORSION'
5795       include 'COMMON.INTERACT'
5796       include 'COMMON.DERIV'
5797       include 'COMMON.CHAIN'
5798       include 'COMMON.NAMES'
5799       include 'COMMON.IOUNITS'
5800       include 'COMMON.FFIELD'
5801       include 'COMMON.TORCNSTR'
5802       include 'COMMON.CONTROL'
5803       logical lprn
5804 C Set lprn=.true. for debugging
5805       lprn=.false.
5806 c      lprn=.true.
5807       etors=0.0D0
5808       do i=iphi_start,iphi_end
5809       etors_ii=0.0D0
5810         itori=itortyp(itype(i-2))
5811         itori1=itortyp(itype(i-1))
5812         phii=phi(i)
5813         gloci=0.0D0
5814 C Proline-Proline pair is a special case...
5815         if (itori.eq.3 .and. itori1.eq.3) then
5816           if (phii.gt.-dwapi3) then
5817             cosphi=dcos(3*phii)
5818             fac=1.0D0/(1.0D0-cosphi)
5819             etorsi=v1(1,3,3)*fac
5820             etorsi=etorsi+etorsi
5821             etors=etors+etorsi-v1(1,3,3)
5822             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5823             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5824           endif
5825           do j=1,3
5826             v1ij=v1(j+1,itori,itori1)
5827             v2ij=v2(j+1,itori,itori1)
5828             cosphi=dcos(j*phii)
5829             sinphi=dsin(j*phii)
5830             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5831             if (energy_dec) etors_ii=etors_ii+
5832      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5833             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5834           enddo
5835         else
5836           do j=1,nterm_old
5837             v1ij=v1(j,itori,itori1)
5838             v2ij=v2(j,itori,itori1)
5839             cosphi=dcos(j*phii)
5840             sinphi=dsin(j*phii)
5841             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5842             if (energy_dec) etors_ii=etors_ii+
5843      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5844             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5845           enddo
5846         endif
5847         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5848      &        'etor',i,etors_ii
5849         if (lprn)
5850      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5851      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5852      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5853         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5854         write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5855       enddo
5856 ! 6/20/98 - dihedral angle constraints
5857       edihcnstr=0.0d0
5858       do i=1,ndih_constr
5859         itori=idih_constr(i)
5860         phii=phi(itori)
5861         difi=phii-phi0(i)
5862         if (difi.gt.drange(i)) then
5863           difi=difi-drange(i)
5864           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5865           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5866         else if (difi.lt.-drange(i)) then
5867           difi=difi+drange(i)
5868           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5869           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5870         endif
5871 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5872 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5873       enddo
5874 !      write (iout,*) 'edihcnstr',edihcnstr
5875       return
5876       end
5877 c------------------------------------------------------------------------------
5878 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
5879       subroutine e_modeller(ehomology_constr)
5880       ehomology_constr=0.0d0
5881       write (iout,*) "!!!!!UWAGA, JESTEM W DZIWNEJ PETLI, TEST!!!!!"
5882       return
5883       end
5884 C !!!!!!!! NIE CZYTANE !!!!!!!!!!!
5885
5886 c------------------------------------------------------------------------------
5887       subroutine etor_d(etors_d)
5888       etors_d=0.0d0
5889       return
5890       end
5891 c----------------------------------------------------------------------------
5892 #else
5893       subroutine etor(etors,edihcnstr)
5894       implicit real*8 (a-h,o-z)
5895       include 'DIMENSIONS'
5896       include 'COMMON.VAR'
5897       include 'COMMON.GEO'
5898       include 'COMMON.LOCAL'
5899       include 'COMMON.TORSION'
5900       include 'COMMON.INTERACT'
5901       include 'COMMON.DERIV'
5902       include 'COMMON.CHAIN'
5903       include 'COMMON.NAMES'
5904       include 'COMMON.IOUNITS'
5905       include 'COMMON.FFIELD'
5906       include 'COMMON.TORCNSTR'
5907       include 'COMMON.CONTROL'
5908       logical lprn
5909 C Set lprn=.true. for debugging
5910       lprn=.false.
5911 c     lprn=.true.
5912       etors=0.0D0
5913       do i=iphi_start,iphi_end
5914       etors_ii=0.0D0
5915         itori=itortyp(itype(i-2))
5916         itori1=itortyp(itype(i-1))
5917         phii=phi(i)
5918         gloci=0.0D0
5919 C Regular cosine and sine terms
5920         do j=1,nterm(itori,itori1)
5921           v1ij=v1(j,itori,itori1)
5922           v2ij=v2(j,itori,itori1)
5923           cosphi=dcos(j*phii)
5924           sinphi=dsin(j*phii)
5925           etors=etors+v1ij*cosphi+v2ij*sinphi
5926           if (energy_dec) etors_ii=etors_ii+
5927      &                v1ij*cosphi+v2ij*sinphi
5928           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5929         enddo
5930 C Lorentz terms
5931 C                         v1
5932 C  E = SUM ----------------------------------- - v1
5933 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5934 C
5935         cosphi=dcos(0.5d0*phii)
5936         sinphi=dsin(0.5d0*phii)
5937         do j=1,nlor(itori,itori1)
5938           vl1ij=vlor1(j,itori,itori1)
5939           vl2ij=vlor2(j,itori,itori1)
5940           vl3ij=vlor3(j,itori,itori1)
5941           pom=vl2ij*cosphi+vl3ij*sinphi
5942           pom1=1.0d0/(pom*pom+1.0d0)
5943           etors=etors+vl1ij*pom1
5944           if (energy_dec) etors_ii=etors_ii+
5945      &                vl1ij*pom1
5946           pom=-pom*pom1*pom1
5947           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5948         enddo
5949 C Subtract the constant term
5950         etors=etors-v0(itori,itori1)
5951           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5952      &         'etor',i,etors_ii-v0(itori,itori1)
5953         if (lprn)
5954      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5955      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5956      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5957         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5958 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5959       enddo
5960 ! 6/20/98 - dihedral angle constraints
5961       edihcnstr=0.0d0
5962 c      do i=1,ndih_constr
5963       do i=idihconstr_start,idihconstr_end
5964         itori=idih_constr(i)
5965         phii=phi(itori)
5966         difi=pinorm(phii-phi0(i))
5967         if (difi.gt.drange(i)) then
5968           difi=difi-drange(i)
5969           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5970           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5971         else if (difi.lt.-drange(i)) then
5972           difi=difi+drange(i)
5973           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5974           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5975         else
5976           difi=0.0
5977         endif
5978 c        write (iout,*) "gloci", gloc(i-3,icg)
5979 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5980 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5981 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5982       enddo
5983 cd       write (iout,*) 'edihcnstr',edihcnstr
5984       return
5985       end
5986 c----------------------------------------------------------------------------
5987 c MODELLER restraint function
5988       subroutine e_modeller(ehomology_constr)
5989       implicit real*8 (a-h,o-z)
5990       include 'DIMENSIONS'
5991
5992       integer nnn, i, j, k, ki, irec, l
5993       integer katy, odleglosci, test7
5994       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
5995       real*8 Eval,Erot
5996       real*8 distance(max_template),distancek(max_template),
5997      &    min_odl,godl(max_template),dih_diff(max_template)
5998
5999 c
6000 c     FP - 30/10/2014 Temporary specifications for homology restraints
6001 c
6002       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
6003      &                 sgtheta
6004       double precision, dimension (maxres) :: guscdiff,usc_diff
6005       double precision, dimension (max_template) ::
6006      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
6007      &           theta_diff
6008 c
6009
6010       include 'COMMON.SBRIDGE'
6011       include 'COMMON.CHAIN'
6012       include 'COMMON.GEO'
6013       include 'COMMON.DERIV'
6014       include 'COMMON.LOCAL'
6015       include 'COMMON.INTERACT'
6016       include 'COMMON.VAR'
6017       include 'COMMON.IOUNITS'
6018       include 'COMMON.MD'
6019       include 'COMMON.CONTROL'
6020 c
6021 c     From subroutine Econstr_back
6022 c
6023       include 'COMMON.NAMES'
6024       include 'COMMON.TIME1'
6025 c
6026
6027
6028       do i=1,max_template
6029         distancek(i)=9999999.9
6030       enddo
6031
6032
6033       odleg=0.0d0
6034
6035 c Pseudo-energy and gradient from homology restraints (MODELLER-like
6036 c function)
6037 C AL 5/2/14 - Introduce list of restraints
6038 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
6039 #ifdef DEBUG
6040       write(iout,*) "------- dist restrs start -------"
6041 #endif
6042       do ii = link_start_homo,link_end_homo
6043          i = ires_homo(ii)
6044          j = jres_homo(ii)
6045          dij=dist(i,j)
6046 c        write (iout,*) "dij(",i,j,") =",dij
6047          do k=1,constr_homology
6048 c           write(iout,*) ii,k,i,j,l_homo(k,ii),dij,odl(k,ii)
6049            if(.not.l_homo(k,ii)) cycle
6050            distance(k)=odl(k,ii)-dij
6051 c          write (iout,*) "distance(",k,") =",distance(k)
6052 c
6053 c          For Gaussian-type Urestr
6054 c
6055            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
6056 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
6057 c          write (iout,*) "distancek(",k,") =",distancek(k)
6058 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
6059 c
6060 c          For Lorentzian-type Urestr
6061 c
6062            if (waga_dist.lt.0.0d0) then
6063               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
6064               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
6065      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
6066            endif
6067          enddo
6068
6069          min_odl=minval(distancek)
6070 c        write (iout,* )"min_odl",min_odl
6071 #ifdef DEBUG
6072          write (iout,*) "ij dij",i,j,dij
6073          write (iout,*) "distance",(distance(k),k=1,constr_homology)
6074          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
6075          write (iout,* )"min_odl",min_odl
6076 #endif
6077          odleg2=0.0d0
6078          do k=1,constr_homology
6079 c Nie wiem po co to liczycie jeszcze raz!
6080 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
6081 c     &              (2*(sigma_odl(i,j,k))**2))
6082            if(.not.l_homo(k,ii)) cycle
6083            if (waga_dist.ge.0.0d0) then
6084 c
6085 c          For Gaussian-type Urestr
6086 c
6087             godl(k)=dexp(-distancek(k)+min_odl)
6088             odleg2=odleg2+godl(k)
6089 c
6090 c          For Lorentzian-type Urestr
6091 c
6092            else
6093             odleg2=odleg2+distancek(k)
6094            endif
6095
6096 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
6097 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
6098 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
6099 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
6100
6101          enddo
6102 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
6103 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
6104 #ifdef DEBUG
6105          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
6106          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
6107 #endif
6108            if (waga_dist.ge.0.0d0) then
6109 c
6110 c          For Gaussian-type Urestr
6111 c
6112               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
6113 c
6114 c          For Lorentzian-type Urestr
6115 c
6116            else
6117               odleg=odleg+odleg2/constr_homology
6118            endif
6119 c
6120 c        write (iout,*) "odleg",odleg ! sum of -ln-s
6121 c Gradient
6122 c
6123 c          For Gaussian-type Urestr
6124 c
6125          if (waga_dist.ge.0.0d0) sum_godl=odleg2
6126          sum_sgodl=0.0d0
6127          do k=1,constr_homology
6128 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
6129 c     &           *waga_dist)+min_odl
6130 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
6131 c
6132          if(.not.l_homo(k,ii)) cycle
6133          if (waga_dist.ge.0.0d0) then
6134 c          For Gaussian-type Urestr
6135 c
6136            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
6137 c
6138 c          For Lorentzian-type Urestr
6139 c
6140          else
6141            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
6142      &           sigma_odlir(k,ii)**2)**2)
6143          endif
6144            sum_sgodl=sum_sgodl+sgodl
6145
6146 c            sgodl2=sgodl2+sgodl
6147 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
6148 c      write(iout,*) "constr_homology=",constr_homology
6149 c      write(iout,*) i, j, k, "TEST K"
6150          enddo
6151          if (waga_dist.ge.0.0d0) then
6152 c
6153 c          For Gaussian-type Urestr
6154 c
6155             grad_odl3=waga_homology(iset)*waga_dist
6156      &                *sum_sgodl/(sum_godl*dij)
6157 c
6158 c          For Lorentzian-type Urestr
6159 c
6160          else
6161 c Original grad expr modified by analogy w Gaussian-type Urestr grad
6162 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
6163             grad_odl3=-waga_homology(iset)*waga_dist*
6164      &                sum_sgodl/(constr_homology*dij)
6165          endif
6166 c
6167 c        grad_odl3=sum_sgodl/(sum_godl*dij)
6168
6169
6170 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
6171 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
6172 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
6173
6174 ccc      write(iout,*) godl, sgodl, grad_odl3
6175
6176 c          grad_odl=grad_odl+grad_odl3
6177
6178          do jik=1,3
6179             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
6180 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
6181 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
6182 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
6183             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
6184             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
6185 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
6186 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
6187 c         if (i.eq.25.and.j.eq.27) then
6188 c         write(iout,*) "jik",jik,"i",i,"j",j
6189 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
6190 c         write(iout,*) "grad_odl3",grad_odl3
6191 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
6192 c         write(iout,*) "ggodl",ggodl
6193 c         write(iout,*) "ghpbc(",jik,i,")",
6194 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
6195 c     &                 ghpbc(jik,j)
6196 c         endif
6197          enddo
6198 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
6199 ccc     & dLOG(odleg2),"-odleg=", -odleg
6200
6201       enddo ! ii-loop for dist
6202 #ifdef DEBUG
6203       write(iout,*) "------- dist restrs end -------"
6204 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
6205 c    &     waga_d.eq.1.0d0) call sum_gradient
6206 #endif
6207 c Pseudo-energy and gradient from dihedral-angle restraints from
6208 c homology templates
6209 c      write (iout,*) "End of distance loop"
6210 c      call flush(iout)
6211       kat=0.0d0
6212 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
6213 #ifdef DEBUG
6214       write(iout,*) "------- dih restrs start -------"
6215       do i=idihconstr_start_homo,idihconstr_end_homo
6216         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
6217       enddo
6218 #endif
6219       do i=idihconstr_start_homo,idihconstr_end_homo
6220         kat2=0.0d0
6221 c        betai=beta(i,i+1,i+2,i+3)
6222         betai = phi(i+3)
6223 c       write (iout,*) "betai =",betai
6224         do k=1,constr_homology
6225           dih_diff(k)=pinorm(dih(k,i)-betai)
6226 c         write (iout,*) "dih_diff(",k,") =",dih_diff(k)
6227 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
6228 c     &                                   -(6.28318-dih_diff(i,k))
6229 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
6230 c     &                                   6.28318+dih_diff(i,k)
6231
6232           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
6233 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
6234           gdih(k)=dexp(kat3)
6235           kat2=kat2+gdih(k)
6236 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
6237 c          write(*,*)""
6238         enddo
6239 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
6240 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
6241 #ifdef DEBUG
6242         write (iout,*) "i",i," betai",betai," kat2",kat2
6243         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
6244 #endif
6245         if (kat2.le.1.0d-14) cycle
6246         kat=kat-dLOG(kat2/constr_homology)
6247 c       write (iout,*) "kat",kat ! sum of -ln-s
6248
6249 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
6250 ccc     & dLOG(kat2), "-kat=", -kat
6251
6252 c ----------------------------------------------------------------------
6253 c Gradient
6254 c ----------------------------------------------------------------------
6255
6256         sum_gdih=kat2
6257         sum_sgdih=0.0d0
6258         do k=1,constr_homology
6259           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
6260 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
6261           sum_sgdih=sum_sgdih+sgdih
6262         enddo
6263 c       grad_dih3=sum_sgdih/sum_gdih
6264         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
6265
6266 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
6267 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
6268 ccc     & gloc(nphi+i-3,icg)
6269         gloc(i,icg)=gloc(i,icg)+grad_dih3
6270 c        if (i.eq.25) then
6271 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
6272 c        endif
6273 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
6274 ccc     & gloc(nphi+i-3,icg)
6275
6276       enddo ! i-loop for dih
6277 #ifdef DEBUG
6278       write(iout,*) "------- dih restrs end -------"
6279 #endif
6280
6281 c Pseudo-energy and gradient for theta angle restraints from
6282 c homology templates
6283 c FP 01/15 - inserted from econstr_local_test.F, loop structure
6284 c adapted
6285
6286 c
6287 c     For constr_homology reference structures (FP)
6288 c
6289 c     Uconst_back_tot=0.0d0
6290       Eval=0.0d0
6291       Erot=0.0d0
6292 c     Econstr_back legacy
6293       do i=1,nres
6294 c     do i=ithet_start,ithet_end
6295        dutheta(i)=0.0d0
6296 c     enddo
6297 c     do i=loc_start,loc_end
6298         do j=1,3
6299           duscdiff(j,i)=0.0d0
6300           duscdiffx(j,i)=0.0d0
6301         enddo
6302       enddo
6303 c
6304 c     do iref=1,nref
6305 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
6306 c     write (iout,*) "waga_theta",waga_theta
6307       if (waga_theta.gt.0.0d0) then
6308 #ifdef DEBUG
6309       write (iout,*) "usampl",usampl
6310       write(iout,*) "------- theta restrs start -------"
6311 c     do i=ithet_start,ithet_end
6312 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
6313 c     enddo
6314 #endif
6315 c     write (iout,*) "maxres",maxres,"nres",nres
6316
6317       do i=ithet_start,ithet_end
6318 c
6319 c     do i=1,nfrag_back
6320 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
6321 c
6322 c Deviation of theta angles wrt constr_homology ref structures
6323 c
6324         utheta_i=0.0d0 ! argument of Gaussian for single k
6325         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
6326 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
6327 c       over residues in a fragment
6328 c       write (iout,*) "theta(",i,")=",theta(i)
6329         do k=1,constr_homology
6330 c
6331 c         dtheta_i=theta(j)-thetaref(j,iref)
6332 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
6333           theta_diff(k)=thetatpl(k,i)-theta(i)
6334 c
6335           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
6336 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
6337           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
6338           gutheta_i=gutheta_i+dexp(utheta_i)   ! Sum of Gaussians (pk)
6339 c         Gradient for single Gaussian restraint in subr Econstr_back
6340 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
6341 c
6342         enddo
6343 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
6344 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
6345
6346 c
6347 c         Gradient for multiple Gaussian restraint
6348         sum_gtheta=gutheta_i
6349         sum_sgtheta=0.0d0
6350         do k=1,constr_homology
6351 c        New generalized expr for multiple Gaussian from Econstr_back
6352          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
6353 c
6354 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
6355           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
6356         enddo
6357 c       Final value of gradient using same var as in Econstr_back
6358         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)
6359      &      +sum_sgtheta/sum_gtheta*waga_theta
6360      &               *waga_homology(iset)
6361 c        dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
6362 c     &               *waga_homology(iset)
6363 c       dutheta(i)=sum_sgtheta/sum_gtheta
6364 c
6365 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
6366         Eval=Eval-dLOG(gutheta_i/constr_homology)
6367 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
6368 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
6369 c       Uconst_back=Uconst_back+utheta(i)
6370       enddo ! (i-loop for theta)
6371 #ifdef DEBUG
6372       write(iout,*) "------- theta restrs end -------"
6373 #endif
6374       endif
6375 c
6376 c Deviation of local SC geometry
6377 c
6378 c Separation of two i-loops (instructed by AL - 11/3/2014)
6379 c
6380 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
6381 c     write (iout,*) "waga_d",waga_d
6382
6383 #ifdef DEBUG
6384       write(iout,*) "------- SC restrs start -------"
6385       write (iout,*) "Initial duscdiff,duscdiffx"
6386       do i=loc_start,loc_end
6387         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
6388      &                 (duscdiffx(jik,i),jik=1,3)
6389       enddo
6390 #endif
6391       do i=loc_start,loc_end
6392         usc_diff_i=0.0d0 ! argument of Gaussian for single k
6393         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
6394 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
6395 c       write(iout,*) "xxtab, yytab, zztab"
6396 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
6397         do k=1,constr_homology
6398 c
6399           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
6400 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
6401           dyy=-yytpl(k,i)+yytab(i) ! ibid y
6402           dzz=-zztpl(k,i)+zztab(i) ! ibid z
6403 c         write(iout,*) "dxx, dyy, dzz"
6404 c         write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
6405 c
6406           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
6407 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
6408 c         uscdiffk(k)=usc_diff(i)
6409           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
6410           guscdiff(i)=guscdiff(i)+dexp(usc_diff_i)   !Sum of Gaussians (pk)
6411 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
6412 c     &      xxref(j),yyref(j),zzref(j)
6413         enddo
6414 c
6415 c       Gradient
6416 c
6417 c       Generalized expression for multiple Gaussian acc to that for a single
6418 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
6419 c
6420 c       Original implementation
6421 c       sum_guscdiff=guscdiff(i)
6422 c
6423 c       sum_sguscdiff=0.0d0
6424 c       do k=1,constr_homology
6425 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
6426 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
6427 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
6428 c       enddo
6429 c
6430 c       Implementation of new expressions for gradient (Jan. 2015)
6431 c
6432 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
6433         do k=1,constr_homology
6434 c
6435 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
6436 c       before. Now the drivatives should be correct
6437 c
6438           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
6439 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
6440           dyy=-yytpl(k,i)+yytab(i) ! ibid y
6441           dzz=-zztpl(k,i)+zztab(i) ! ibid z
6442 c
6443 c         New implementation
6444 c
6445           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
6446      &                 sigma_d(k,i) ! for the grad wrt r'
6447 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
6448 c
6449 c
6450 c        New implementation
6451          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
6452          do jik=1,3
6453             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
6454      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
6455      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
6456             duscdiff(jik,i)=duscdiff(jik,i)+
6457      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
6458      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
6459             duscdiffx(jik,i)=duscdiffx(jik,i)+
6460      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
6461      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
6462 c
6463 #ifdef DEBUG
6464              write(iout,*) "jik",jik,"i",i
6465              write(iout,*) "dxx, dyy, dzz"
6466              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
6467              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
6468 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
6469 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
6470 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
6471 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
6472 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
6473 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
6474 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
6475 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
6476 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
6477 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
6478 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
6479 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
6480 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
6481 c            endif
6482 #endif
6483          enddo
6484         enddo
6485 c
6486 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
6487 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
6488 c
6489 c        write (iout,*) i," uscdiff",uscdiff(i)
6490 c
6491 c Put together deviations from local geometry
6492
6493 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
6494 c      &            wfrag_back(3,i,iset)*uscdiff(i)
6495         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
6496 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
6497 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
6498 c       Uconst_back=Uconst_back+usc_diff(i)
6499 c
6500 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
6501 c
6502 c     New implment: multiplied by sum_sguscdiff
6503 c
6504
6505       enddo ! (i-loop for dscdiff)
6506
6507 c      endif
6508
6509 #ifdef DEBUG
6510       write(iout,*) "------- SC restrs end -------"
6511         write (iout,*) "------ After SC loop in e_modeller ------"
6512         do i=loc_start,loc_end
6513          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
6514          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
6515         enddo
6516       if (waga_theta.eq.1.0d0) then
6517       write (iout,*) "in e_modeller after SC restr end: dutheta"
6518       do i=ithet_start,ithet_end
6519         write (iout,*) i,dutheta(i)
6520       enddo
6521       endif
6522       if (waga_d.eq.1.0d0) then
6523       write (iout,*) "e_modeller after SC loop: duscdiff/x"
6524       do i=1,nres
6525         write (iout,*) i,(duscdiff(j,i),j=1,3)
6526         write (iout,*) i,(duscdiffx(j,i),j=1,3)
6527       enddo
6528       endif
6529 #endif
6530
6531 c Total energy from homology restraints
6532 #ifdef DEBUG
6533       write (iout,*) "odleg",odleg," kat",kat
6534 #endif
6535 c
6536 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
6537 c
6538 c     ehomology_constr=odleg+kat
6539 c
6540 c     For Lorentzian-type Urestr
6541 c
6542
6543       if (waga_dist.ge.0.0d0) then
6544 c
6545 c          For Gaussian-type Urestr
6546 c
6547         ehomology_constr=(waga_dist*odleg+waga_angle*kat+
6548      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
6549 c     write (iout,*) "ehomology_constr=",ehomology_constr
6550       else
6551 c
6552 c          For Lorentzian-type Urestr
6553 c
6554         ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
6555      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
6556 c     write (iout,*) "ehomology_constr=",ehomology_constr
6557       endif
6558 #ifdef DEBUG
6559       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
6560      & "Eval",waga_theta,eval,
6561      &   "Erot",waga_d,Erot
6562       write (iout,*) "ehomology_constr",ehomology_constr
6563 #endif
6564       return
6565 c
6566 c FP 01/15 end
6567 c
6568   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
6569   747 format(a12,i4,i4,i4,f8.3,f8.3)
6570   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
6571   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
6572   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
6573      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
6574       end
6575
6576 c------------------------------------------------------------------------------
6577       subroutine etor_d(etors_d)
6578 C 6/23/01 Compute double torsional energy
6579       implicit real*8 (a-h,o-z)
6580       include 'DIMENSIONS'
6581       include 'COMMON.VAR'
6582       include 'COMMON.GEO'
6583       include 'COMMON.LOCAL'
6584       include 'COMMON.TORSION'
6585       include 'COMMON.INTERACT'
6586       include 'COMMON.DERIV'
6587       include 'COMMON.CHAIN'
6588       include 'COMMON.NAMES'
6589       include 'COMMON.IOUNITS'
6590       include 'COMMON.FFIELD'
6591       include 'COMMON.TORCNSTR'
6592       include 'COMMON.CONTROL'
6593       logical lprn
6594 C Set lprn=.true. for debugging
6595       lprn=.false.
6596 c     lprn=.true.
6597       etors_d=0.0D0
6598       do i=iphid_start,iphid_end
6599         etors_d_ii=0.0D0
6600         itori=itortyp(itype(i-2))
6601         itori1=itortyp(itype(i-1))
6602         itori2=itortyp(itype(i))
6603         phii=phi(i)
6604         phii1=phi(i+1)
6605         gloci1=0.0D0
6606         gloci2=0.0D0
6607         do j=1,ntermd_1(itori,itori1,itori2)
6608           v1cij=v1c(1,j,itori,itori1,itori2)
6609           v1sij=v1s(1,j,itori,itori1,itori2)
6610           v2cij=v1c(2,j,itori,itori1,itori2)
6611           v2sij=v1s(2,j,itori,itori1,itori2)
6612           cosphi1=dcos(j*phii)
6613           sinphi1=dsin(j*phii)
6614           cosphi2=dcos(j*phii1)
6615           sinphi2=dsin(j*phii1)
6616           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
6617      &     v2cij*cosphi2+v2sij*sinphi2
6618           if (energy_dec) etors_d_ii=etors_d_ii+
6619      &     v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
6620           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6621           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6622         enddo
6623         do k=2,ntermd_2(itori,itori1,itori2)
6624           do l=1,k-1
6625             v1cdij = v2c(k,l,itori,itori1,itori2)
6626             v2cdij = v2c(l,k,itori,itori1,itori2)
6627             v1sdij = v2s(k,l,itori,itori1,itori2)
6628             v2sdij = v2s(l,k,itori,itori1,itori2)
6629             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6630             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6631             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6632             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6633             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6634      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6635             if (energy_dec) etors_d_ii=etors_d_ii+
6636      &        v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6637      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6638             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
6639      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6640             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
6641      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6642           enddo
6643         enddo
6644         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6645      &        'etor_d',i,etors_d_ii
6646         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
6647         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
6648 c        write (iout,*) "gloci", gloc(i-3,icg)
6649       enddo
6650       return
6651       end
6652 #endif
6653 c------------------------------------------------------------------------------
6654       subroutine eback_sc_corr(esccor)
6655 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6656 c        conformational states; temporarily implemented as differences
6657 c        between UNRES torsional potentials (dependent on three types of
6658 c        residues) and the torsional potentials dependent on all 20 types
6659 c        of residues computed from AM1  energy surfaces of terminally-blocked
6660 c        amino-acid residues.
6661       implicit real*8 (a-h,o-z)
6662       include 'DIMENSIONS'
6663       include 'COMMON.VAR'
6664       include 'COMMON.GEO'
6665       include 'COMMON.LOCAL'
6666       include 'COMMON.TORSION'
6667       include 'COMMON.SCCOR'
6668       include 'COMMON.INTERACT'
6669       include 'COMMON.DERIV'
6670       include 'COMMON.CHAIN'
6671       include 'COMMON.NAMES'
6672       include 'COMMON.IOUNITS'
6673       include 'COMMON.FFIELD'
6674       include 'COMMON.CONTROL'
6675       logical lprn
6676 C Set lprn=.true. for debugging
6677       lprn=.false.
6678 c      lprn=.true.
6679 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
6680       esccor=0.0D0
6681       do i=itau_start,itau_end
6682         esccor_ii=0.0D0
6683         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6684         isccori=isccortyp(itype(i-2))
6685         isccori1=isccortyp(itype(i-1))
6686         phii=phi(i)
6687 cccc  Added 9 May 2012
6688 cc Tauangle is torsional engle depending on the value of first digit
6689 c(see comment below)
6690 cc Omicron is flat angle depending on the value of first digit
6691 c(see comment below)
6692
6693
6694         do intertyp=1,3 !intertyp
6695 cc Added 09 May 2012 (Adasko)
6696 cc  Intertyp means interaction type of backbone mainchain correlation:
6697 c   1 = SC...Ca...Ca...Ca
6698 c   2 = Ca...Ca...Ca...SC
6699 c   3 = SC...Ca...Ca...SCi
6700         gloci=0.0D0
6701         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6702      &      (itype(i-1).eq.10).or.(itype(i-2).eq.21).or.
6703      &      (itype(i-1).eq.21)))
6704      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6705      &     .or.(itype(i-2).eq.21)))
6706      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6707      &      (itype(i-1).eq.21)))) cycle
6708         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle
6709         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21))
6710      & cycle
6711         do j=1,nterm_sccor(isccori,isccori1)
6712           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6713           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6714           cosphi=dcos(j*tauangle(intertyp,i))
6715           sinphi=dsin(j*tauangle(intertyp,i))
6716           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6717           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6718         enddo
6719         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6720 c        write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
6721 c     &gloc_sc(intertyp,i-3,icg)
6722         if (lprn)
6723      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6724      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6725      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
6726      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
6727         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6728        enddo !intertyp
6729       enddo
6730 c        do i=1,nres
6731 c        write (iout,*) "W@T@F",  gloc_sc(1,i,icg),gloc(i,icg)
6732 c        enddo
6733       return
6734       end
6735 c----------------------------------------------------------------------------
6736       subroutine multibody(ecorr)
6737 C This subroutine calculates multi-body contributions to energy following
6738 C the idea of Skolnick et al. If side chains I and J make a contact and
6739 C at the same time side chains I+1 and J+1 make a contact, an extra
6740 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6741       implicit real*8 (a-h,o-z)
6742       include 'DIMENSIONS'
6743       include 'COMMON.IOUNITS'
6744       include 'COMMON.DERIV'
6745       include 'COMMON.INTERACT'
6746       include 'COMMON.CONTACTS'
6747       double precision gx(3),gx1(3)
6748       logical lprn
6749
6750 C Set lprn=.true. for debugging
6751       lprn=.false.
6752
6753       if (lprn) then
6754         write (iout,'(a)') 'Contact function values:'
6755         do i=nnt,nct-2
6756           write (iout,'(i2,20(1x,i2,f10.5))')
6757      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6758         enddo
6759       endif
6760       ecorr=0.0D0
6761       do i=nnt,nct
6762         do j=1,3
6763           gradcorr(j,i)=0.0D0
6764           gradxorr(j,i)=0.0D0
6765         enddo
6766       enddo
6767       do i=nnt,nct-2
6768
6769         DO ISHIFT = 3,4
6770
6771         i1=i+ishift
6772         num_conti=num_cont(i)
6773         num_conti1=num_cont(i1)
6774         do jj=1,num_conti
6775           j=jcont(jj,i)
6776           do kk=1,num_conti1
6777             j1=jcont(kk,i1)
6778             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6779 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6780 cd   &                   ' ishift=',ishift
6781 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6782 C The system gains extra energy.
6783               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6784             endif   ! j1==j+-ishift
6785           enddo     ! kk
6786         enddo       ! jj
6787
6788         ENDDO ! ISHIFT
6789
6790       enddo         ! i
6791       return
6792       end
6793 c------------------------------------------------------------------------------
6794       double precision function esccorr(i,j,k,l,jj,kk)
6795       implicit real*8 (a-h,o-z)
6796       include 'DIMENSIONS'
6797       include 'COMMON.IOUNITS'
6798       include 'COMMON.DERIV'
6799       include 'COMMON.INTERACT'
6800       include 'COMMON.CONTACTS'
6801       double precision gx(3),gx1(3)
6802       logical lprn
6803       lprn=.false.
6804       eij=facont(jj,i)
6805       ekl=facont(kk,k)
6806 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6807 C Calculate the multi-body contribution to energy.
6808 C Calculate multi-body contributions to the gradient.
6809 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6810 cd   & k,l,(gacont(m,kk,k),m=1,3)
6811       do m=1,3
6812         gx(m) =ekl*gacont(m,jj,i)
6813         gx1(m)=eij*gacont(m,kk,k)
6814         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6815         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6816         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6817         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6818       enddo
6819       do m=i,j-1
6820         do ll=1,3
6821           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6822         enddo
6823       enddo
6824       do m=k,l-1
6825         do ll=1,3
6826           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6827         enddo
6828       enddo
6829       esccorr=-eij*ekl
6830       return
6831       end
6832 c------------------------------------------------------------------------------
6833       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6834 C This subroutine calculates multi-body contributions to hydrogen-bonding
6835       implicit real*8 (a-h,o-z)
6836       include 'DIMENSIONS'
6837       include 'COMMON.IOUNITS'
6838 #ifdef MPI
6839       include "mpif.h"
6840       parameter (max_cont=maxconts)
6841       parameter (max_dim=26)
6842       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6843       double precision zapas(max_dim,maxconts,max_fg_procs),
6844      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6845       common /przechowalnia/ zapas
6846       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6847      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6848 #endif
6849       include 'COMMON.SETUP'
6850       include 'COMMON.FFIELD'
6851       include 'COMMON.DERIV'
6852       include 'COMMON.INTERACT'
6853       include 'COMMON.CONTACTS'
6854       include 'COMMON.CONTROL'
6855       include 'COMMON.LOCAL'
6856       double precision gx(3),gx1(3),time00
6857       logical lprn,ldone
6858
6859 C Set lprn=.true. for debugging
6860       lprn=.false.
6861 #ifdef MPI
6862       n_corr=0
6863       n_corr1=0
6864       if (nfgtasks.le.1) goto 30
6865       if (lprn) then
6866         write (iout,'(a)') 'Contact function values before RECEIVE:'
6867         do i=nnt,nct-2
6868           write (iout,'(2i3,50(1x,i2,f5.2))')
6869      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6870      &    j=1,num_cont_hb(i))
6871         enddo
6872       endif
6873       call flush(iout)
6874       do i=1,ntask_cont_from
6875         ncont_recv(i)=0
6876       enddo
6877       do i=1,ntask_cont_to
6878         ncont_sent(i)=0
6879       enddo
6880 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6881 c     & ntask_cont_to
6882 C Make the list of contacts to send to send to other procesors
6883 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6884 c      call flush(iout)
6885       do i=iturn3_start,iturn3_end
6886 c        write (iout,*) "make contact list turn3",i," num_cont",
6887 c     &    num_cont_hb(i)
6888         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6889       enddo
6890       do i=iturn4_start,iturn4_end
6891 c        write (iout,*) "make contact list turn4",i," num_cont",
6892 c     &   num_cont_hb(i)
6893         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6894       enddo
6895       do ii=1,nat_sent
6896         i=iat_sent(ii)
6897 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6898 c     &    num_cont_hb(i)
6899         do j=1,num_cont_hb(i)
6900         do k=1,4
6901           jjc=jcont_hb(j,i)
6902           iproc=iint_sent_local(k,jjc,ii)
6903 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6904           if (iproc.gt.0) then
6905             ncont_sent(iproc)=ncont_sent(iproc)+1
6906             nn=ncont_sent(iproc)
6907             zapas(1,nn,iproc)=i
6908             zapas(2,nn,iproc)=jjc
6909             zapas(3,nn,iproc)=facont_hb(j,i)
6910             zapas(4,nn,iproc)=ees0p(j,i)
6911             zapas(5,nn,iproc)=ees0m(j,i)
6912             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6913             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6914             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6915             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6916             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6917             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6918             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6919             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6920             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6921             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6922             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6923             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6924             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6925             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6926             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6927             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6928             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6929             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6930             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6931             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6932             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6933           endif
6934         enddo
6935         enddo
6936       enddo
6937       if (lprn) then
6938       write (iout,*)
6939      &  "Numbers of contacts to be sent to other processors",
6940      &  (ncont_sent(i),i=1,ntask_cont_to)
6941       write (iout,*) "Contacts sent"
6942       do ii=1,ntask_cont_to
6943         nn=ncont_sent(ii)
6944         iproc=itask_cont_to(ii)
6945         write (iout,*) nn," contacts to processor",iproc,
6946      &   " of CONT_TO_COMM group"
6947         do i=1,nn
6948           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6949         enddo
6950       enddo
6951       call flush(iout)
6952       endif
6953       CorrelType=477
6954       CorrelID=fg_rank+1
6955       CorrelType1=478
6956       CorrelID1=nfgtasks+fg_rank+1
6957       ireq=0
6958 C Receive the numbers of needed contacts from other processors
6959       do ii=1,ntask_cont_from
6960         iproc=itask_cont_from(ii)
6961         ireq=ireq+1
6962         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6963      &    FG_COMM,req(ireq),IERR)
6964       enddo
6965 c      write (iout,*) "IRECV ended"
6966 c      call flush(iout)
6967 C Send the number of contacts needed by other processors
6968       do ii=1,ntask_cont_to
6969         iproc=itask_cont_to(ii)
6970         ireq=ireq+1
6971         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6972      &    FG_COMM,req(ireq),IERR)
6973       enddo
6974 c      write (iout,*) "ISEND ended"
6975 c      write (iout,*) "number of requests (nn)",ireq
6976       call flush(iout)
6977       if (ireq.gt.0)
6978      &  call MPI_Waitall(ireq,req,status_array,ierr)
6979 c      write (iout,*)
6980 c     &  "Numbers of contacts to be received from other processors",
6981 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6982 c      call flush(iout)
6983 C Receive contacts
6984       ireq=0
6985       do ii=1,ntask_cont_from
6986         iproc=itask_cont_from(ii)
6987         nn=ncont_recv(ii)
6988 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6989 c     &   " of CONT_TO_COMM group"
6990         call flush(iout)
6991         if (nn.gt.0) then
6992           ireq=ireq+1
6993           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6994      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6995 c          write (iout,*) "ireq,req",ireq,req(ireq)
6996         endif
6997       enddo
6998 C Send the contacts to processors that need them
6999       do ii=1,ntask_cont_to
7000         iproc=itask_cont_to(ii)
7001         nn=ncont_sent(ii)
7002 c        write (iout,*) nn," contacts to processor",iproc,
7003 c     &   " of CONT_TO_COMM group"
7004         if (nn.gt.0) then
7005           ireq=ireq+1
7006           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
7007      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7008 c          write (iout,*) "ireq,req",ireq,req(ireq)
7009 c          do i=1,nn
7010 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7011 c          enddo
7012         endif
7013       enddo
7014 c      write (iout,*) "number of requests (contacts)",ireq
7015 c      write (iout,*) "req",(req(i),i=1,4)
7016 c      call flush(iout)
7017       if (ireq.gt.0)
7018      & call MPI_Waitall(ireq,req,status_array,ierr)
7019       do iii=1,ntask_cont_from
7020         iproc=itask_cont_from(iii)
7021         nn=ncont_recv(iii)
7022         if (lprn) then
7023         write (iout,*) "Received",nn," contacts from processor",iproc,
7024      &   " of CONT_FROM_COMM group"
7025         call flush(iout)
7026         do i=1,nn
7027           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
7028         enddo
7029         call flush(iout)
7030         endif
7031         do i=1,nn
7032           ii=zapas_recv(1,i,iii)
7033 c Flag the received contacts to prevent double-counting
7034           jj=-zapas_recv(2,i,iii)
7035 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7036 c          call flush(iout)
7037           nnn=num_cont_hb(ii)+1
7038           num_cont_hb(ii)=nnn
7039           jcont_hb(nnn,ii)=jj
7040           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
7041           ees0p(nnn,ii)=zapas_recv(4,i,iii)
7042           ees0m(nnn,ii)=zapas_recv(5,i,iii)
7043           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
7044           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
7045           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
7046           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
7047           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
7048           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
7049           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
7050           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
7051           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
7052           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
7053           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
7054           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
7055           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
7056           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
7057           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
7058           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
7059           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
7060           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
7061           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
7062           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
7063           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
7064         enddo
7065       enddo
7066       call flush(iout)
7067       if (lprn) then
7068         write (iout,'(a)') 'Contact function values after receive:'
7069         do i=nnt,nct-2
7070           write (iout,'(2i3,50(1x,i3,f5.2))')
7071      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7072      &    j=1,num_cont_hb(i))
7073         enddo
7074         call flush(iout)
7075       endif
7076    30 continue
7077 #endif
7078       if (lprn) then
7079         write (iout,'(a)') 'Contact function values:'
7080         do i=nnt,nct-2
7081           write (iout,'(2i3,50(1x,i3,f5.2))')
7082      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7083      &    j=1,num_cont_hb(i))
7084         enddo
7085       endif
7086       ecorr=0.0D0
7087 C Remove the loop below after debugging !!!
7088       do i=nnt,nct
7089         do j=1,3
7090           gradcorr(j,i)=0.0D0
7091           gradxorr(j,i)=0.0D0
7092         enddo
7093       enddo
7094 C Calculate the local-electrostatic correlation terms
7095       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
7096         i1=i+1
7097         num_conti=num_cont_hb(i)
7098         num_conti1=num_cont_hb(i+1)
7099         do jj=1,num_conti
7100           j=jcont_hb(jj,i)
7101           jp=iabs(j)
7102           do kk=1,num_conti1
7103             j1=jcont_hb(kk,i1)
7104             jp1=iabs(j1)
7105 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7106 c     &         ' jj=',jj,' kk=',kk
7107             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7108      &          .or. j.lt.0 .and. j1.gt.0) .and.
7109      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7110 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7111 C The system gains extra energy.
7112               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7113               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
7114      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
7115               n_corr=n_corr+1
7116             else if (j1.eq.j) then
7117 C Contacts I-J and I-(J+1) occur simultaneously.
7118 C The system loses extra energy.
7119 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7120             endif
7121           enddo ! kk
7122           do kk=1,num_conti
7123             j1=jcont_hb(kk,i)
7124 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7125 c    &         ' jj=',jj,' kk=',kk
7126             if (j1.eq.j+1) then
7127 C Contacts I-J and (I+1)-J occur simultaneously.
7128 C The system loses extra energy.
7129 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7130             endif ! j1==j+1
7131           enddo ! kk
7132         enddo ! jj
7133       enddo ! i
7134       return
7135       end
7136 c------------------------------------------------------------------------------
7137       subroutine add_hb_contact(ii,jj,itask)
7138       implicit real*8 (a-h,o-z)
7139       include "DIMENSIONS"
7140       include "COMMON.IOUNITS"
7141       integer max_cont
7142       integer max_dim
7143       parameter (max_cont=maxconts)
7144       parameter (max_dim=26)
7145       include "COMMON.CONTACTS"
7146       double precision zapas(max_dim,maxconts,max_fg_procs),
7147      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7148       common /przechowalnia/ zapas
7149       integer i,j,ii,jj,iproc,itask(4),nn
7150 c      write (iout,*) "itask",itask
7151       do i=1,2
7152         iproc=itask(i)
7153         if (iproc.gt.0) then
7154           do j=1,num_cont_hb(ii)
7155             jjc=jcont_hb(j,ii)
7156 c            write (iout,*) "i",ii," j",jj," jjc",jjc
7157             if (jjc.eq.jj) then
7158               ncont_sent(iproc)=ncont_sent(iproc)+1
7159               nn=ncont_sent(iproc)
7160               zapas(1,nn,iproc)=ii
7161               zapas(2,nn,iproc)=jjc
7162               zapas(3,nn,iproc)=facont_hb(j,ii)
7163               zapas(4,nn,iproc)=ees0p(j,ii)
7164               zapas(5,nn,iproc)=ees0m(j,ii)
7165               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
7166               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
7167               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
7168               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
7169               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
7170               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
7171               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
7172               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
7173               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
7174               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
7175               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
7176               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
7177               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
7178               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
7179               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
7180               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
7181               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
7182               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
7183               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
7184               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
7185               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
7186               exit
7187             endif
7188           enddo
7189         endif
7190       enddo
7191       return
7192       end
7193 c------------------------------------------------------------------------------
7194       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
7195      &  n_corr1)
7196 C This subroutine calculates multi-body contributions to hydrogen-bonding
7197       implicit real*8 (a-h,o-z)
7198       include 'DIMENSIONS'
7199       include 'COMMON.IOUNITS'
7200 #ifdef MPI
7201       include "mpif.h"
7202       parameter (max_cont=maxconts)
7203       parameter (max_dim=70)
7204       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7205       double precision zapas(max_dim,maxconts,max_fg_procs),
7206      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7207       common /przechowalnia/ zapas
7208       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7209      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7210 #endif
7211       include 'COMMON.SETUP'
7212       include 'COMMON.FFIELD'
7213       include 'COMMON.DERIV'
7214       include 'COMMON.LOCAL'
7215       include 'COMMON.INTERACT'
7216       include 'COMMON.CONTACTS'
7217       include 'COMMON.CHAIN'
7218       include 'COMMON.CONTROL'
7219       double precision gx(3),gx1(3)
7220       integer num_cont_hb_old(maxres)
7221       logical lprn,ldone
7222       double precision eello4,eello5,eelo6,eello_turn6
7223       external eello4,eello5,eello6,eello_turn6
7224 C Set lprn=.true. for debugging
7225       lprn=.false.
7226       eturn6=0.0d0
7227 #ifdef MPI
7228       do i=1,nres
7229         num_cont_hb_old(i)=num_cont_hb(i)
7230       enddo
7231       n_corr=0
7232       n_corr1=0
7233       if (nfgtasks.le.1) goto 30
7234       if (lprn) then
7235         write (iout,'(a)') 'Contact function values before RECEIVE:'
7236         do i=nnt,nct-2
7237           write (iout,'(2i3,50(1x,i2,f5.2))')
7238      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7239      &    j=1,num_cont_hb(i))
7240         enddo
7241       endif
7242       call flush(iout)
7243       do i=1,ntask_cont_from
7244         ncont_recv(i)=0
7245       enddo
7246       do i=1,ntask_cont_to
7247         ncont_sent(i)=0
7248       enddo
7249 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7250 c     & ntask_cont_to
7251 C Make the list of contacts to send to send to other procesors
7252       do i=iturn3_start,iturn3_end
7253 c        write (iout,*) "make contact list turn3",i," num_cont",
7254 c     &    num_cont_hb(i)
7255         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
7256       enddo
7257       do i=iturn4_start,iturn4_end
7258 c        write (iout,*) "make contact list turn4",i," num_cont",
7259 c     &   num_cont_hb(i)
7260         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
7261       enddo
7262       do ii=1,nat_sent
7263         i=iat_sent(ii)
7264 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7265 c     &    num_cont_hb(i)
7266         do j=1,num_cont_hb(i)
7267         do k=1,4
7268           jjc=jcont_hb(j,i)
7269           iproc=iint_sent_local(k,jjc,ii)
7270 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7271           if (iproc.ne.0) then
7272             ncont_sent(iproc)=ncont_sent(iproc)+1
7273             nn=ncont_sent(iproc)
7274             zapas(1,nn,iproc)=i
7275             zapas(2,nn,iproc)=jjc
7276             zapas(3,nn,iproc)=d_cont(j,i)
7277             ind=3
7278             do kk=1,3
7279               ind=ind+1
7280               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
7281             enddo
7282             do kk=1,2
7283               do ll=1,2
7284                 ind=ind+1
7285                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
7286               enddo
7287             enddo
7288             do jj=1,5
7289               do kk=1,3
7290                 do ll=1,2
7291                   do mm=1,2
7292                     ind=ind+1
7293                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
7294                   enddo
7295                 enddo
7296               enddo
7297             enddo
7298           endif
7299         enddo
7300         enddo
7301       enddo
7302       if (lprn) then
7303       write (iout,*)
7304      &  "Numbers of contacts to be sent to other processors",
7305      &  (ncont_sent(i),i=1,ntask_cont_to)
7306       write (iout,*) "Contacts sent"
7307       do ii=1,ntask_cont_to
7308         nn=ncont_sent(ii)
7309         iproc=itask_cont_to(ii)
7310         write (iout,*) nn," contacts to processor",iproc,
7311      &   " of CONT_TO_COMM group"
7312         do i=1,nn
7313           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
7314         enddo
7315       enddo
7316       call flush(iout)
7317       endif
7318       CorrelType=477
7319       CorrelID=fg_rank+1
7320       CorrelType1=478
7321       CorrelID1=nfgtasks+fg_rank+1
7322       ireq=0
7323 C Receive the numbers of needed contacts from other processors
7324       do ii=1,ntask_cont_from
7325         iproc=itask_cont_from(ii)
7326         ireq=ireq+1
7327         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7328      &    FG_COMM,req(ireq),IERR)
7329       enddo
7330 c      write (iout,*) "IRECV ended"
7331 c      call flush(iout)
7332 C Send the number of contacts needed by other processors
7333       do ii=1,ntask_cont_to
7334         iproc=itask_cont_to(ii)
7335         ireq=ireq+1
7336         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7337      &    FG_COMM,req(ireq),IERR)
7338       enddo
7339 c      write (iout,*) "ISEND ended"
7340 c      write (iout,*) "number of requests (nn)",ireq
7341       call flush(iout)
7342       if (ireq.gt.0)
7343      &  call MPI_Waitall(ireq,req,status_array,ierr)
7344 c      write (iout,*)
7345 c     &  "Numbers of contacts to be received from other processors",
7346 c     &  (ncont_recv(i),i=1,ntask_cont_from)
7347 c      call flush(iout)
7348 C Receive contacts
7349       ireq=0
7350       do ii=1,ntask_cont_from
7351         iproc=itask_cont_from(ii)
7352         nn=ncont_recv(ii)
7353 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7354 c     &   " of CONT_TO_COMM group"
7355         call flush(iout)
7356         if (nn.gt.0) then
7357           ireq=ireq+1
7358           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
7359      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7360 c          write (iout,*) "ireq,req",ireq,req(ireq)
7361         endif
7362       enddo
7363 C Send the contacts to processors that need them
7364       do ii=1,ntask_cont_to
7365         iproc=itask_cont_to(ii)
7366         nn=ncont_sent(ii)
7367 c        write (iout,*) nn," contacts to processor",iproc,
7368 c     &   " of CONT_TO_COMM group"
7369         if (nn.gt.0) then
7370           ireq=ireq+1
7371           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
7372      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7373 c          write (iout,*) "ireq,req",ireq,req(ireq)
7374 c          do i=1,nn
7375 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7376 c          enddo
7377         endif
7378       enddo
7379 c      write (iout,*) "number of requests (contacts)",ireq
7380 c      write (iout,*) "req",(req(i),i=1,4)
7381 c      call flush(iout)
7382       if (ireq.gt.0)
7383      & call MPI_Waitall(ireq,req,status_array,ierr)
7384       do iii=1,ntask_cont_from
7385         iproc=itask_cont_from(iii)
7386         nn=ncont_recv(iii)
7387         if (lprn) then
7388         write (iout,*) "Received",nn," contacts from processor",iproc,
7389      &   " of CONT_FROM_COMM group"
7390         call flush(iout)
7391         do i=1,nn
7392           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
7393         enddo
7394         call flush(iout)
7395         endif
7396         do i=1,nn
7397           ii=zapas_recv(1,i,iii)
7398 c Flag the received contacts to prevent double-counting
7399           jj=-zapas_recv(2,i,iii)
7400 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7401 c          call flush(iout)
7402           nnn=num_cont_hb(ii)+1
7403           num_cont_hb(ii)=nnn
7404           jcont_hb(nnn,ii)=jj
7405           d_cont(nnn,ii)=zapas_recv(3,i,iii)
7406           ind=3
7407           do kk=1,3
7408             ind=ind+1
7409             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
7410           enddo
7411           do kk=1,2
7412             do ll=1,2
7413               ind=ind+1
7414               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
7415             enddo
7416           enddo
7417           do jj=1,5
7418             do kk=1,3
7419               do ll=1,2
7420                 do mm=1,2
7421                   ind=ind+1
7422                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
7423                 enddo
7424               enddo
7425             enddo
7426           enddo
7427         enddo
7428       enddo
7429       call flush(iout)
7430       if (lprn) then
7431         write (iout,'(a)') 'Contact function values after receive:'
7432         do i=nnt,nct-2
7433           write (iout,'(2i3,50(1x,i3,5f6.3))')
7434      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7435      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7436         enddo
7437         call flush(iout)
7438       endif
7439    30 continue
7440 #endif
7441       if (lprn) then
7442         write (iout,'(a)') 'Contact function values:'
7443         do i=nnt,nct-2
7444           write (iout,'(2i3,50(1x,i2,5f6.3))')
7445      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7446      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7447         enddo
7448       endif
7449       ecorr=0.0D0
7450       ecorr5=0.0d0
7451       ecorr6=0.0d0
7452 C Remove the loop below after debugging !!!
7453       do i=nnt,nct
7454         do j=1,3
7455           gradcorr(j,i)=0.0D0
7456           gradxorr(j,i)=0.0D0
7457         enddo
7458       enddo
7459 C Calculate the dipole-dipole interaction energies
7460       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7461       do i=iatel_s,iatel_e+1
7462         num_conti=num_cont_hb(i)
7463         do jj=1,num_conti
7464           j=jcont_hb(jj,i)
7465 #ifdef MOMENT
7466           call dipole(i,j,jj)
7467 #endif
7468         enddo
7469       enddo
7470       endif
7471 C Calculate the local-electrostatic correlation terms
7472 c                write (iout,*) "gradcorr5 in eello5 before loop"
7473 c                do iii=1,nres
7474 c                  write (iout,'(i5,3f10.5)')
7475 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7476 c                enddo
7477       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7478 c        write (iout,*) "corr loop i",i
7479         i1=i+1
7480         num_conti=num_cont_hb(i)
7481         num_conti1=num_cont_hb(i+1)
7482         do jj=1,num_conti
7483           j=jcont_hb(jj,i)
7484           jp=iabs(j)
7485           do kk=1,num_conti1
7486             j1=jcont_hb(kk,i1)
7487             jp1=iabs(j1)
7488 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7489 c     &         ' jj=',jj,' kk=',kk
7490 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
7491             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7492      &          .or. j.lt.0 .and. j1.gt.0) .and.
7493      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7494 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7495 C The system gains extra energy.
7496               n_corr=n_corr+1
7497               sqd1=dsqrt(d_cont(jj,i))
7498               sqd2=dsqrt(d_cont(kk,i1))
7499               sred_geom = sqd1*sqd2
7500               IF (sred_geom.lt.cutoff_corr) THEN
7501                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
7502      &            ekont,fprimcont)
7503 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7504 cd     &         ' jj=',jj,' kk=',kk
7505                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7506                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7507                 do l=1,3
7508                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7509                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7510                 enddo
7511                 n_corr1=n_corr1+1
7512 cd               write (iout,*) 'sred_geom=',sred_geom,
7513 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
7514 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7515 cd               write (iout,*) "g_contij",g_contij
7516 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7517 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7518                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7519                 if (wcorr4.gt.0.0d0)
7520      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7521                   if (energy_dec.and.wcorr4.gt.0.0d0)
7522      1                 write (iout,'(a6,4i5,0pf7.3)')
7523      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7524 c                write (iout,*) "gradcorr5 before eello5"
7525 c                do iii=1,nres
7526 c                  write (iout,'(i5,3f10.5)')
7527 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7528 c                enddo
7529                 if (wcorr5.gt.0.0d0)
7530      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7531 c                write (iout,*) "gradcorr5 after eello5"
7532 c                do iii=1,nres
7533 c                  write (iout,'(i5,3f10.5)')
7534 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7535 c                enddo
7536                   if (energy_dec.and.wcorr5.gt.0.0d0)
7537      1                 write (iout,'(a6,4i5,0pf7.3)')
7538      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7539 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7540 cd                write(2,*)'ijkl',i,jp,i+1,jp1
7541                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
7542      &               .or. wturn6.eq.0.0d0))then
7543 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7544                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7545                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7546      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7547 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7548 cd     &            'ecorr6=',ecorr6
7549 cd                write (iout,'(4e15.5)') sred_geom,
7550 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7551 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7552 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7553                 else if (wturn6.gt.0.0d0
7554      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7555 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7556                   eturn6=eturn6+eello_turn6(i,jj,kk)
7557                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7558      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7559 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
7560                 endif
7561               ENDIF
7562 1111          continue
7563             endif
7564           enddo ! kk
7565         enddo ! jj
7566       enddo ! i
7567       do i=1,nres
7568         num_cont_hb(i)=num_cont_hb_old(i)
7569       enddo
7570 c                write (iout,*) "gradcorr5 in eello5"
7571 c                do iii=1,nres
7572 c                  write (iout,'(i5,3f10.5)')
7573 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7574 c                enddo
7575       return
7576       end
7577 c------------------------------------------------------------------------------
7578       subroutine add_hb_contact_eello(ii,jj,itask)
7579       implicit real*8 (a-h,o-z)
7580       include "DIMENSIONS"
7581       include "COMMON.IOUNITS"
7582       integer max_cont
7583       integer max_dim
7584       parameter (max_cont=maxconts)
7585       parameter (max_dim=70)
7586       include "COMMON.CONTACTS"
7587       double precision zapas(max_dim,maxconts,max_fg_procs),
7588      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7589       common /przechowalnia/ zapas
7590       integer i,j,ii,jj,iproc,itask(4),nn
7591 c      write (iout,*) "itask",itask
7592       do i=1,2
7593         iproc=itask(i)
7594         if (iproc.gt.0) then
7595           do j=1,num_cont_hb(ii)
7596             jjc=jcont_hb(j,ii)
7597 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
7598             if (jjc.eq.jj) then
7599               ncont_sent(iproc)=ncont_sent(iproc)+1
7600               nn=ncont_sent(iproc)
7601               zapas(1,nn,iproc)=ii
7602               zapas(2,nn,iproc)=jjc
7603               zapas(3,nn,iproc)=d_cont(j,ii)
7604               ind=3
7605               do kk=1,3
7606                 ind=ind+1
7607                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
7608               enddo
7609               do kk=1,2
7610                 do ll=1,2
7611                   ind=ind+1
7612                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
7613                 enddo
7614               enddo
7615               do jj=1,5
7616                 do kk=1,3
7617                   do ll=1,2
7618                     do mm=1,2
7619                       ind=ind+1
7620                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
7621                     enddo
7622                   enddo
7623                 enddo
7624               enddo
7625               exit
7626             endif
7627           enddo
7628         endif
7629       enddo
7630       return
7631       end
7632 c------------------------------------------------------------------------------
7633       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7634       implicit real*8 (a-h,o-z)
7635       include 'DIMENSIONS'
7636       include 'COMMON.IOUNITS'
7637       include 'COMMON.DERIV'
7638       include 'COMMON.INTERACT'
7639       include 'COMMON.CONTACTS'
7640       double precision gx(3),gx1(3)
7641       logical lprn
7642       lprn=.false.
7643       eij=facont_hb(jj,i)
7644       ekl=facont_hb(kk,k)
7645       ees0pij=ees0p(jj,i)
7646       ees0pkl=ees0p(kk,k)
7647       ees0mij=ees0m(jj,i)
7648       ees0mkl=ees0m(kk,k)
7649       ekont=eij*ekl
7650       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7651 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7652 C Following 4 lines for diagnostics.
7653 cd    ees0pkl=0.0D0
7654 cd    ees0pij=1.0D0
7655 cd    ees0mkl=0.0D0
7656 cd    ees0mij=1.0D0
7657 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7658 c     & 'Contacts ',i,j,
7659 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7660 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7661 c     & 'gradcorr_long'
7662 C Calculate the multi-body contribution to energy.
7663 c      ecorr=ecorr+ekont*ees
7664 C Calculate multi-body contributions to the gradient.
7665       coeffpees0pij=coeffp*ees0pij
7666       coeffmees0mij=coeffm*ees0mij
7667       coeffpees0pkl=coeffp*ees0pkl
7668       coeffmees0mkl=coeffm*ees0mkl
7669       do ll=1,3
7670 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7671         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
7672      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
7673      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
7674         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
7675      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
7676      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
7677 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7678         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
7679      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
7680      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
7681         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
7682      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
7683      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
7684         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
7685      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
7686      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
7687         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7688         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7689         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
7690      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
7691      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
7692         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7693         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7694 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7695       enddo
7696 c      write (iout,*)
7697 cgrad      do m=i+1,j-1
7698 cgrad        do ll=1,3
7699 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7700 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7701 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7702 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7703 cgrad        enddo
7704 cgrad      enddo
7705 cgrad      do m=k+1,l-1
7706 cgrad        do ll=1,3
7707 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7708 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7709 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7710 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7711 cgrad        enddo
7712 cgrad      enddo
7713 c      write (iout,*) "ehbcorr",ekont*ees
7714       ehbcorr=ekont*ees
7715       return
7716       end
7717 #ifdef MOMENT
7718 C---------------------------------------------------------------------------
7719       subroutine dipole(i,j,jj)
7720       implicit real*8 (a-h,o-z)
7721       include 'DIMENSIONS'
7722       include 'COMMON.IOUNITS'
7723       include 'COMMON.CHAIN'
7724       include 'COMMON.FFIELD'
7725       include 'COMMON.DERIV'
7726       include 'COMMON.INTERACT'
7727       include 'COMMON.CONTACTS'
7728       include 'COMMON.TORSION'
7729       include 'COMMON.VAR'
7730       include 'COMMON.GEO'
7731       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7732      &  auxmat(2,2)
7733       iti1 = itortyp(itype(i+1))
7734       if (j.lt.nres-1) then
7735         itj1 = itortyp(itype(j+1))
7736       else
7737         itj1=ntortyp+1
7738       endif
7739       do iii=1,2
7740         dipi(iii,1)=Ub2(iii,i)
7741         dipderi(iii)=Ub2der(iii,i)
7742         dipi(iii,2)=b1(iii,iti1)
7743         dipj(iii,1)=Ub2(iii,j)
7744         dipderj(iii)=Ub2der(iii,j)
7745         dipj(iii,2)=b1(iii,itj1)
7746       enddo
7747       kkk=0
7748       do iii=1,2
7749         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7750         do jjj=1,2
7751           kkk=kkk+1
7752           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7753         enddo
7754       enddo
7755       do kkk=1,5
7756         do lll=1,3
7757           mmm=0
7758           do iii=1,2
7759             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7760      &        auxvec(1))
7761             do jjj=1,2
7762               mmm=mmm+1
7763               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7764             enddo
7765           enddo
7766         enddo
7767       enddo
7768       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7769       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7770       do iii=1,2
7771         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7772       enddo
7773       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7774       do iii=1,2
7775         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7776       enddo
7777       return
7778       end
7779 #endif
7780 C---------------------------------------------------------------------------
7781       subroutine calc_eello(i,j,k,l,jj,kk)
7782 C
7783 C This subroutine computes matrices and vectors needed to calculate
7784 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7785 C
7786       implicit real*8 (a-h,o-z)
7787       include 'DIMENSIONS'
7788       include 'COMMON.IOUNITS'
7789       include 'COMMON.CHAIN'
7790       include 'COMMON.DERIV'
7791       include 'COMMON.INTERACT'
7792       include 'COMMON.CONTACTS'
7793       include 'COMMON.TORSION'
7794       include 'COMMON.VAR'
7795       include 'COMMON.GEO'
7796       include 'COMMON.FFIELD'
7797       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7798      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7799       logical lprn
7800       common /kutas/ lprn
7801 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7802 cd     & ' jj=',jj,' kk=',kk
7803 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7804 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7805 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7806       do iii=1,2
7807         do jjj=1,2
7808           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7809           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7810         enddo
7811       enddo
7812       call transpose2(aa1(1,1),aa1t(1,1))
7813       call transpose2(aa2(1,1),aa2t(1,1))
7814       do kkk=1,5
7815         do lll=1,3
7816           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7817      &      aa1tder(1,1,lll,kkk))
7818           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7819      &      aa2tder(1,1,lll,kkk))
7820         enddo
7821       enddo
7822       if (l.eq.j+1) then
7823 C parallel orientation of the two CA-CA-CA frames.
7824         if (i.gt.1) then
7825           iti=itortyp(itype(i))
7826         else
7827           iti=ntortyp+1
7828         endif
7829         itk1=itortyp(itype(k+1))
7830         itj=itortyp(itype(j))
7831         if (l.lt.nres-1) then
7832           itl1=itortyp(itype(l+1))
7833         else
7834           itl1=ntortyp+1
7835         endif
7836 C A1 kernel(j+1) A2T
7837 cd        do iii=1,2
7838 cd          write (iout,'(3f10.5,5x,3f10.5)')
7839 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7840 cd        enddo
7841         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7842      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7843      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7844 C Following matrices are needed only for 6-th order cumulants
7845         IF (wcorr6.gt.0.0d0) THEN
7846         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7847      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7848      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7849         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7850      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7851      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7852      &   ADtEAderx(1,1,1,1,1,1))
7853         lprn=.false.
7854         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7855      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7856      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7857      &   ADtEA1derx(1,1,1,1,1,1))
7858         ENDIF
7859 C End 6-th order cumulants
7860 cd        lprn=.false.
7861 cd        if (lprn) then
7862 cd        write (2,*) 'In calc_eello6'
7863 cd        do iii=1,2
7864 cd          write (2,*) 'iii=',iii
7865 cd          do kkk=1,5
7866 cd            write (2,*) 'kkk=',kkk
7867 cd            do jjj=1,2
7868 cd              write (2,'(3(2f10.5),5x)')
7869 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7870 cd            enddo
7871 cd          enddo
7872 cd        enddo
7873 cd        endif
7874         call transpose2(EUgder(1,1,k),auxmat(1,1))
7875         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7876         call transpose2(EUg(1,1,k),auxmat(1,1))
7877         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7878         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7879         do iii=1,2
7880           do kkk=1,5
7881             do lll=1,3
7882               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7883      &          EAEAderx(1,1,lll,kkk,iii,1))
7884             enddo
7885           enddo
7886         enddo
7887 C A1T kernel(i+1) A2
7888         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7889      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7890      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7891 C Following matrices are needed only for 6-th order cumulants
7892         IF (wcorr6.gt.0.0d0) THEN
7893         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7894      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7895      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7896         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7897      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7898      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7899      &   ADtEAderx(1,1,1,1,1,2))
7900         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7901      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7902      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7903      &   ADtEA1derx(1,1,1,1,1,2))
7904         ENDIF
7905 C End 6-th order cumulants
7906         call transpose2(EUgder(1,1,l),auxmat(1,1))
7907         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7908         call transpose2(EUg(1,1,l),auxmat(1,1))
7909         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7910         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7911         do iii=1,2
7912           do kkk=1,5
7913             do lll=1,3
7914               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7915      &          EAEAderx(1,1,lll,kkk,iii,2))
7916             enddo
7917           enddo
7918         enddo
7919 C AEAb1 and AEAb2
7920 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7921 C They are needed only when the fifth- or the sixth-order cumulants are
7922 C indluded.
7923         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7924         call transpose2(AEA(1,1,1),auxmat(1,1))
7925         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7926         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7927         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7928         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7929         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7930         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7931         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7932         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7933         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7934         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7935         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7936         call transpose2(AEA(1,1,2),auxmat(1,1))
7937         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7938         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7939         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7940         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7941         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7942         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7943         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7944         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7945         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7946         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7947         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7948 C Calculate the Cartesian derivatives of the vectors.
7949         do iii=1,2
7950           do kkk=1,5
7951             do lll=1,3
7952               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7953               call matvec2(auxmat(1,1),b1(1,iti),
7954      &          AEAb1derx(1,lll,kkk,iii,1,1))
7955               call matvec2(auxmat(1,1),Ub2(1,i),
7956      &          AEAb2derx(1,lll,kkk,iii,1,1))
7957               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7958      &          AEAb1derx(1,lll,kkk,iii,2,1))
7959               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7960      &          AEAb2derx(1,lll,kkk,iii,2,1))
7961               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7962               call matvec2(auxmat(1,1),b1(1,itj),
7963      &          AEAb1derx(1,lll,kkk,iii,1,2))
7964               call matvec2(auxmat(1,1),Ub2(1,j),
7965      &          AEAb2derx(1,lll,kkk,iii,1,2))
7966               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7967      &          AEAb1derx(1,lll,kkk,iii,2,2))
7968               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7969      &          AEAb2derx(1,lll,kkk,iii,2,2))
7970             enddo
7971           enddo
7972         enddo
7973         ENDIF
7974 C End vectors
7975       else
7976 C Antiparallel orientation of the two CA-CA-CA frames.
7977         if (i.gt.1) then
7978           iti=itortyp(itype(i))
7979         else
7980           iti=ntortyp+1
7981         endif
7982         itk1=itortyp(itype(k+1))
7983         itl=itortyp(itype(l))
7984         itj=itortyp(itype(j))
7985         if (j.lt.nres-1) then
7986           itj1=itortyp(itype(j+1))
7987         else
7988           itj1=ntortyp+1
7989         endif
7990 C A2 kernel(j-1)T A1T
7991         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7992      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7993      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7994 C Following matrices are needed only for 6-th order cumulants
7995         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7996      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7997         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7998      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7999      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8000         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8001      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
8002      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8003      &   ADtEAderx(1,1,1,1,1,1))
8004         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8005      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
8006      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8007      &   ADtEA1derx(1,1,1,1,1,1))
8008         ENDIF
8009 C End 6-th order cumulants
8010         call transpose2(EUgder(1,1,k),auxmat(1,1))
8011         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8012         call transpose2(EUg(1,1,k),auxmat(1,1))
8013         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8014         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8015         do iii=1,2
8016           do kkk=1,5
8017             do lll=1,3
8018               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8019      &          EAEAderx(1,1,lll,kkk,iii,1))
8020             enddo
8021           enddo
8022         enddo
8023 C A2T kernel(i+1)T A1
8024         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8025      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
8026      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8027 C Following matrices are needed only for 6-th order cumulants
8028         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8029      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8030         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8031      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
8032      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8033         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8034      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
8035      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8036      &   ADtEAderx(1,1,1,1,1,2))
8037         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8038      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
8039      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8040      &   ADtEA1derx(1,1,1,1,1,2))
8041         ENDIF
8042 C End 6-th order cumulants
8043         call transpose2(EUgder(1,1,j),auxmat(1,1))
8044         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
8045         call transpose2(EUg(1,1,j),auxmat(1,1))
8046         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8047         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8048         do iii=1,2
8049           do kkk=1,5
8050             do lll=1,3
8051               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8052      &          EAEAderx(1,1,lll,kkk,iii,2))
8053             enddo
8054           enddo
8055         enddo
8056 C AEAb1 and AEAb2
8057 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8058 C They are needed only when the fifth- or the sixth-order cumulants are
8059 C indluded.
8060         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
8061      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
8062         call transpose2(AEA(1,1,1),auxmat(1,1))
8063         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
8064         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8065         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8066         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8067         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
8068         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8069         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
8070         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
8071         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8072         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8073         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8074         call transpose2(AEA(1,1,2),auxmat(1,1))
8075         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
8076         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
8077         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
8078         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8079         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
8080         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
8081         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
8082         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
8083         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
8084         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
8085         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
8086 C Calculate the Cartesian derivatives of the vectors.
8087         do iii=1,2
8088           do kkk=1,5
8089             do lll=1,3
8090               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8091               call matvec2(auxmat(1,1),b1(1,iti),
8092      &          AEAb1derx(1,lll,kkk,iii,1,1))
8093               call matvec2(auxmat(1,1),Ub2(1,i),
8094      &          AEAb2derx(1,lll,kkk,iii,1,1))
8095               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8096      &          AEAb1derx(1,lll,kkk,iii,2,1))
8097               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8098      &          AEAb2derx(1,lll,kkk,iii,2,1))
8099               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8100               call matvec2(auxmat(1,1),b1(1,itl),
8101      &          AEAb1derx(1,lll,kkk,iii,1,2))
8102               call matvec2(auxmat(1,1),Ub2(1,l),
8103      &          AEAb2derx(1,lll,kkk,iii,1,2))
8104               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
8105      &          AEAb1derx(1,lll,kkk,iii,2,2))
8106               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
8107      &          AEAb2derx(1,lll,kkk,iii,2,2))
8108             enddo
8109           enddo
8110         enddo
8111         ENDIF
8112 C End vectors
8113       endif
8114       return
8115       end
8116 C---------------------------------------------------------------------------
8117       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
8118      &  KK,KKderg,AKA,AKAderg,AKAderx)
8119       implicit none
8120       integer nderg
8121       logical transp
8122       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
8123      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
8124      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
8125       integer iii,kkk,lll
8126       integer jjj,mmm
8127       logical lprn
8128       common /kutas/ lprn
8129       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
8130       do iii=1,nderg
8131         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
8132      &    AKAderg(1,1,iii))
8133       enddo
8134 cd      if (lprn) write (2,*) 'In kernel'
8135       do kkk=1,5
8136 cd        if (lprn) write (2,*) 'kkk=',kkk
8137         do lll=1,3
8138           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
8139      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
8140 cd          if (lprn) then
8141 cd            write (2,*) 'lll=',lll
8142 cd            write (2,*) 'iii=1'
8143 cd            do jjj=1,2
8144 cd              write (2,'(3(2f10.5),5x)')
8145 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
8146 cd            enddo
8147 cd          endif
8148           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
8149      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
8150 cd          if (lprn) then
8151 cd            write (2,*) 'lll=',lll
8152 cd            write (2,*) 'iii=2'
8153 cd            do jjj=1,2
8154 cd              write (2,'(3(2f10.5),5x)')
8155 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
8156 cd            enddo
8157 cd          endif
8158         enddo
8159       enddo
8160       return
8161       end
8162 C---------------------------------------------------------------------------
8163       double precision function eello4(i,j,k,l,jj,kk)
8164       implicit real*8 (a-h,o-z)
8165       include 'DIMENSIONS'
8166       include 'COMMON.IOUNITS'
8167       include 'COMMON.CHAIN'
8168       include 'COMMON.DERIV'
8169       include 'COMMON.INTERACT'
8170       include 'COMMON.CONTACTS'
8171       include 'COMMON.TORSION'
8172       include 'COMMON.VAR'
8173       include 'COMMON.GEO'
8174       double precision pizda(2,2),ggg1(3),ggg2(3)
8175 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8176 cd        eello4=0.0d0
8177 cd        return
8178 cd      endif
8179 cd      print *,'eello4:',i,j,k,l,jj,kk
8180 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
8181 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
8182 cold      eij=facont_hb(jj,i)
8183 cold      ekl=facont_hb(kk,k)
8184 cold      ekont=eij*ekl
8185       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8186 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8187       gcorr_loc(k-1)=gcorr_loc(k-1)
8188      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8189       if (l.eq.j+1) then
8190         gcorr_loc(l-1)=gcorr_loc(l-1)
8191      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8192       else
8193         gcorr_loc(j-1)=gcorr_loc(j-1)
8194      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8195       endif
8196       do iii=1,2
8197         do kkk=1,5
8198           do lll=1,3
8199             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
8200      &                        -EAEAderx(2,2,lll,kkk,iii,1)
8201 cd            derx(lll,kkk,iii)=0.0d0
8202           enddo
8203         enddo
8204       enddo
8205 cd      gcorr_loc(l-1)=0.0d0
8206 cd      gcorr_loc(j-1)=0.0d0
8207 cd      gcorr_loc(k-1)=0.0d0
8208 cd      eel4=1.0d0
8209 cd      write (iout,*)'Contacts have occurred for peptide groups',
8210 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
8211 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8212       if (j.lt.nres-1) then
8213         j1=j+1
8214         j2=j-1
8215       else
8216         j1=j-1
8217         j2=j-2
8218       endif
8219       if (l.lt.nres-1) then
8220         l1=l+1
8221         l2=l-1
8222       else
8223         l1=l-1
8224         l2=l-2
8225       endif
8226       do ll=1,3
8227 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
8228 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
8229         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8230         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8231 cgrad        ghalf=0.5d0*ggg1(ll)
8232         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8233         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8234         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8235         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8236         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8237         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8238 cgrad        ghalf=0.5d0*ggg2(ll)
8239         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8240         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8241         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8242         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8243         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8244         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8245       enddo
8246 cgrad      do m=i+1,j-1
8247 cgrad        do ll=1,3
8248 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
8249 cgrad        enddo
8250 cgrad      enddo
8251 cgrad      do m=k+1,l-1
8252 cgrad        do ll=1,3
8253 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
8254 cgrad        enddo
8255 cgrad      enddo
8256 cgrad      do m=i+2,j2
8257 cgrad        do ll=1,3
8258 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8259 cgrad        enddo
8260 cgrad      enddo
8261 cgrad      do m=k+2,l2
8262 cgrad        do ll=1,3
8263 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8264 cgrad        enddo
8265 cgrad      enddo
8266 cd      do iii=1,nres-3
8267 cd        write (2,*) iii,gcorr_loc(iii)
8268 cd      enddo
8269       eello4=ekont*eel4
8270 cd      write (2,*) 'ekont',ekont
8271 cd      write (iout,*) 'eello4',ekont*eel4
8272       return
8273       end
8274 C---------------------------------------------------------------------------
8275       double precision function eello5(i,j,k,l,jj,kk)
8276       implicit real*8 (a-h,o-z)
8277       include 'DIMENSIONS'
8278       include 'COMMON.IOUNITS'
8279       include 'COMMON.CHAIN'
8280       include 'COMMON.DERIV'
8281       include 'COMMON.INTERACT'
8282       include 'COMMON.CONTACTS'
8283       include 'COMMON.TORSION'
8284       include 'COMMON.VAR'
8285       include 'COMMON.GEO'
8286       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
8287       double precision ggg1(3),ggg2(3)
8288 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8289 C                                                                              C
8290 C                            Parallel chains                                   C
8291 C                                                                              C
8292 C          o             o                   o             o                   C
8293 C         /l\           / \             \   / \           / \   /              C
8294 C        /   \         /   \             \ /   \         /   \ /               C
8295 C       j| o |l1       | o |              o| o |         | o |o                C
8296 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8297 C      \i/   \         /   \ /             /   \         /   \                 C
8298 C       o    k1             o                                                  C
8299 C         (I)          (II)                (III)          (IV)                 C
8300 C                                                                              C
8301 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8302 C                                                                              C
8303 C                            Antiparallel chains                               C
8304 C                                                                              C
8305 C          o             o                   o             o                   C
8306 C         /j\           / \             \   / \           / \   /              C
8307 C        /   \         /   \             \ /   \         /   \ /               C
8308 C      j1| o |l        | o |              o| o |         | o |o                C
8309 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8310 C      \i/   \         /   \ /             /   \         /   \                 C
8311 C       o     k1            o                                                  C
8312 C         (I)          (II)                (III)          (IV)                 C
8313 C                                                                              C
8314 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8315 C                                                                              C
8316 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
8317 C                                                                              C
8318 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8319 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8320 cd        eello5=0.0d0
8321 cd        return
8322 cd      endif
8323 cd      write (iout,*)
8324 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8325 cd     &   ' and',k,l
8326       itk=itortyp(itype(k))
8327       itl=itortyp(itype(l))
8328       itj=itortyp(itype(j))
8329       eello5_1=0.0d0
8330       eello5_2=0.0d0
8331       eello5_3=0.0d0
8332       eello5_4=0.0d0
8333 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8334 cd     &   eel5_3_num,eel5_4_num)
8335       do iii=1,2
8336         do kkk=1,5
8337           do lll=1,3
8338             derx(lll,kkk,iii)=0.0d0
8339           enddo
8340         enddo
8341       enddo
8342 cd      eij=facont_hb(jj,i)
8343 cd      ekl=facont_hb(kk,k)
8344 cd      ekont=eij*ekl
8345 cd      write (iout,*)'Contacts have occurred for peptide groups',
8346 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
8347 cd      goto 1111
8348 C Contribution from the graph I.
8349 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8350 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8351       call transpose2(EUg(1,1,k),auxmat(1,1))
8352       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8353       vv(1)=pizda(1,1)-pizda(2,2)
8354       vv(2)=pizda(1,2)+pizda(2,1)
8355       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
8356      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8357 C Explicit gradient in virtual-dihedral angles.
8358       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
8359      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
8360      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8361       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8362       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8363       vv(1)=pizda(1,1)-pizda(2,2)
8364       vv(2)=pizda(1,2)+pizda(2,1)
8365       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8366      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
8367      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8368       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8369       vv(1)=pizda(1,1)-pizda(2,2)
8370       vv(2)=pizda(1,2)+pizda(2,1)
8371       if (l.eq.j+1) then
8372         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
8373      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8374      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8375       else
8376         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
8377      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8378      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8379       endif
8380 C Cartesian gradient
8381       do iii=1,2
8382         do kkk=1,5
8383           do lll=1,3
8384             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
8385      &        pizda(1,1))
8386             vv(1)=pizda(1,1)-pizda(2,2)
8387             vv(2)=pizda(1,2)+pizda(2,1)
8388             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8389      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
8390      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8391           enddo
8392         enddo
8393       enddo
8394 c      goto 1112
8395 c1111  continue
8396 C Contribution from graph II
8397       call transpose2(EE(1,1,itk),auxmat(1,1))
8398       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8399       vv(1)=pizda(1,1)+pizda(2,2)
8400       vv(2)=pizda(2,1)-pizda(1,2)
8401       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
8402      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
8403 C Explicit gradient in virtual-dihedral angles.
8404       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8405      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8406       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8407       vv(1)=pizda(1,1)+pizda(2,2)
8408       vv(2)=pizda(2,1)-pizda(1,2)
8409       if (l.eq.j+1) then
8410         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8411      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
8412      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8413       else
8414         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8415      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
8416      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8417       endif
8418 C Cartesian gradient
8419       do iii=1,2
8420         do kkk=1,5
8421           do lll=1,3
8422             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8423      &        pizda(1,1))
8424             vv(1)=pizda(1,1)+pizda(2,2)
8425             vv(2)=pizda(2,1)-pizda(1,2)
8426             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8427      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
8428      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
8429           enddo
8430         enddo
8431       enddo
8432 cd      goto 1112
8433 cd1111  continue
8434       if (l.eq.j+1) then
8435 cd        goto 1110
8436 C Parallel orientation
8437 C Contribution from graph III
8438         call transpose2(EUg(1,1,l),auxmat(1,1))
8439         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8440         vv(1)=pizda(1,1)-pizda(2,2)
8441         vv(2)=pizda(1,2)+pizda(2,1)
8442         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
8443      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8444 C Explicit gradient in virtual-dihedral angles.
8445         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8446      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
8447      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8448         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8449         vv(1)=pizda(1,1)-pizda(2,2)
8450         vv(2)=pizda(1,2)+pizda(2,1)
8451         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8452      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
8453      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8454         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8455         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8456         vv(1)=pizda(1,1)-pizda(2,2)
8457         vv(2)=pizda(1,2)+pizda(2,1)
8458         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8459      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
8460      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8461 C Cartesian gradient
8462         do iii=1,2
8463           do kkk=1,5
8464             do lll=1,3
8465               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8466      &          pizda(1,1))
8467               vv(1)=pizda(1,1)-pizda(2,2)
8468               vv(2)=pizda(1,2)+pizda(2,1)
8469               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8470      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
8471      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8472             enddo
8473           enddo
8474         enddo
8475 cd        goto 1112
8476 C Contribution from graph IV
8477 cd1110    continue
8478         call transpose2(EE(1,1,itl),auxmat(1,1))
8479         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8480         vv(1)=pizda(1,1)+pizda(2,2)
8481         vv(2)=pizda(2,1)-pizda(1,2)
8482         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
8483      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
8484 C Explicit gradient in virtual-dihedral angles.
8485         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8486      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8487         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8488         vv(1)=pizda(1,1)+pizda(2,2)
8489         vv(2)=pizda(2,1)-pizda(1,2)
8490         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8491      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
8492      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8493 C Cartesian gradient
8494         do iii=1,2
8495           do kkk=1,5
8496             do lll=1,3
8497               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8498      &          pizda(1,1))
8499               vv(1)=pizda(1,1)+pizda(2,2)
8500               vv(2)=pizda(2,1)-pizda(1,2)
8501               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8502      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
8503      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
8504             enddo
8505           enddo
8506         enddo
8507       else
8508 C Antiparallel orientation
8509 C Contribution from graph III
8510 c        goto 1110
8511         call transpose2(EUg(1,1,j),auxmat(1,1))
8512         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8513         vv(1)=pizda(1,1)-pizda(2,2)
8514         vv(2)=pizda(1,2)+pizda(2,1)
8515         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
8516      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8517 C Explicit gradient in virtual-dihedral angles.
8518         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8519      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
8520      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8521         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8522         vv(1)=pizda(1,1)-pizda(2,2)
8523         vv(2)=pizda(1,2)+pizda(2,1)
8524         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8525      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
8526      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8527         call transpose2(EUgder(1,1,j),auxmat1(1,1))
8528         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8529         vv(1)=pizda(1,1)-pizda(2,2)
8530         vv(2)=pizda(1,2)+pizda(2,1)
8531         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8532      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
8533      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8534 C Cartesian gradient
8535         do iii=1,2
8536           do kkk=1,5
8537             do lll=1,3
8538               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8539      &          pizda(1,1))
8540               vv(1)=pizda(1,1)-pizda(2,2)
8541               vv(2)=pizda(1,2)+pizda(2,1)
8542               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8543      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
8544      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8545             enddo
8546           enddo
8547         enddo
8548 cd        goto 1112
8549 C Contribution from graph IV
8550 1110    continue
8551         call transpose2(EE(1,1,itj),auxmat(1,1))
8552         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8553         vv(1)=pizda(1,1)+pizda(2,2)
8554         vv(2)=pizda(2,1)-pizda(1,2)
8555         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
8556      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
8557 C Explicit gradient in virtual-dihedral angles.
8558         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8559      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
8560         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8561         vv(1)=pizda(1,1)+pizda(2,2)
8562         vv(2)=pizda(2,1)-pizda(1,2)
8563         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8564      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
8565      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
8566 C Cartesian gradient
8567         do iii=1,2
8568           do kkk=1,5
8569             do lll=1,3
8570               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8571      &          pizda(1,1))
8572               vv(1)=pizda(1,1)+pizda(2,2)
8573               vv(2)=pizda(2,1)-pizda(1,2)
8574               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8575      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
8576      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
8577             enddo
8578           enddo
8579         enddo
8580       endif
8581 1112  continue
8582       eel5=eello5_1+eello5_2+eello5_3+eello5_4
8583 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
8584 cd        write (2,*) 'ijkl',i,j,k,l
8585 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
8586 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
8587 cd      endif
8588 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
8589 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
8590 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
8591 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
8592       if (j.lt.nres-1) then
8593         j1=j+1
8594         j2=j-1
8595       else
8596         j1=j-1
8597         j2=j-2
8598       endif
8599       if (l.lt.nres-1) then
8600         l1=l+1
8601         l2=l-1
8602       else
8603         l1=l-1
8604         l2=l-2
8605       endif
8606 cd      eij=1.0d0
8607 cd      ekl=1.0d0
8608 cd      ekont=1.0d0
8609 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
8610 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
8611 C        summed up outside the subrouine as for the other subroutines
8612 C        handling long-range interactions. The old code is commented out
8613 C        with "cgrad" to keep track of changes.
8614       do ll=1,3
8615 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
8616 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
8617         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
8618         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
8619 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
8620 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
8621 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
8622 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
8623 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
8624 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
8625 c     &   gradcorr5ij,
8626 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
8627 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
8628 cgrad        ghalf=0.5d0*ggg1(ll)
8629 cd        ghalf=0.0d0
8630         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
8631         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
8632         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
8633         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
8634         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
8635         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
8636 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
8637 cgrad        ghalf=0.5d0*ggg2(ll)
8638 cd        ghalf=0.0d0
8639         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
8640         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
8641         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
8642         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
8643         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
8644         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
8645       enddo
8646 cd      goto 1112
8647 cgrad      do m=i+1,j-1
8648 cgrad        do ll=1,3
8649 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
8650 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
8651 cgrad        enddo
8652 cgrad      enddo
8653 cgrad      do m=k+1,l-1
8654 cgrad        do ll=1,3
8655 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
8656 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
8657 cgrad        enddo
8658 cgrad      enddo
8659 c1112  continue
8660 cgrad      do m=i+2,j2
8661 cgrad        do ll=1,3
8662 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
8663 cgrad        enddo
8664 cgrad      enddo
8665 cgrad      do m=k+2,l2
8666 cgrad        do ll=1,3
8667 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
8668 cgrad        enddo
8669 cgrad      enddo
8670 cd      do iii=1,nres-3
8671 cd        write (2,*) iii,g_corr5_loc(iii)
8672 cd      enddo
8673       eello5=ekont*eel5
8674 cd      write (2,*) 'ekont',ekont
8675 cd      write (iout,*) 'eello5',ekont*eel5
8676       return
8677       end
8678 c--------------------------------------------------------------------------
8679       double precision function eello6(i,j,k,l,jj,kk)
8680       implicit real*8 (a-h,o-z)
8681       include 'DIMENSIONS'
8682       include 'COMMON.IOUNITS'
8683       include 'COMMON.CHAIN'
8684       include 'COMMON.DERIV'
8685       include 'COMMON.INTERACT'
8686       include 'COMMON.CONTACTS'
8687       include 'COMMON.TORSION'
8688       include 'COMMON.VAR'
8689       include 'COMMON.GEO'
8690       include 'COMMON.FFIELD'
8691       double precision ggg1(3),ggg2(3)
8692 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8693 cd        eello6=0.0d0
8694 cd        return
8695 cd      endif
8696 cd      write (iout,*)
8697 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8698 cd     &   ' and',k,l
8699       eello6_1=0.0d0
8700       eello6_2=0.0d0
8701       eello6_3=0.0d0
8702       eello6_4=0.0d0
8703       eello6_5=0.0d0
8704       eello6_6=0.0d0
8705 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8706 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8707       do iii=1,2
8708         do kkk=1,5
8709           do lll=1,3
8710             derx(lll,kkk,iii)=0.0d0
8711           enddo
8712         enddo
8713       enddo
8714 cd      eij=facont_hb(jj,i)
8715 cd      ekl=facont_hb(kk,k)
8716 cd      ekont=eij*ekl
8717 cd      eij=1.0d0
8718 cd      ekl=1.0d0
8719 cd      ekont=1.0d0
8720       if (l.eq.j+1) then
8721         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8722         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8723         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8724         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8725         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8726         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8727       else
8728         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8729         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8730         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8731         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8732         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8733           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8734         else
8735           eello6_5=0.0d0
8736         endif
8737         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8738       endif
8739 C If turn contributions are considered, they will be handled separately.
8740       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8741 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8742 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8743 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8744 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8745 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8746 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8747 cd      goto 1112
8748       if (j.lt.nres-1) then
8749         j1=j+1
8750         j2=j-1
8751       else
8752         j1=j-1
8753         j2=j-2
8754       endif
8755       if (l.lt.nres-1) then
8756         l1=l+1
8757         l2=l-1
8758       else
8759         l1=l-1
8760         l2=l-2
8761       endif
8762       do ll=1,3
8763 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8764 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8765 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8766 cgrad        ghalf=0.5d0*ggg1(ll)
8767 cd        ghalf=0.0d0
8768         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8769         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8770         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8771         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8772         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8773         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8774         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8775         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8776 cgrad        ghalf=0.5d0*ggg2(ll)
8777 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8778 cd        ghalf=0.0d0
8779         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8780         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8781         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8782         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8783         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8784         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8785       enddo
8786 cd      goto 1112
8787 cgrad      do m=i+1,j-1
8788 cgrad        do ll=1,3
8789 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8790 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8791 cgrad        enddo
8792 cgrad      enddo
8793 cgrad      do m=k+1,l-1
8794 cgrad        do ll=1,3
8795 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8796 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8797 cgrad        enddo
8798 cgrad      enddo
8799 cgrad1112  continue
8800 cgrad      do m=i+2,j2
8801 cgrad        do ll=1,3
8802 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8803 cgrad        enddo
8804 cgrad      enddo
8805 cgrad      do m=k+2,l2
8806 cgrad        do ll=1,3
8807 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8808 cgrad        enddo
8809 cgrad      enddo
8810 cd      do iii=1,nres-3
8811 cd        write (2,*) iii,g_corr6_loc(iii)
8812 cd      enddo
8813       eello6=ekont*eel6
8814 cd      write (2,*) 'ekont',ekont
8815 cd      write (iout,*) 'eello6',ekont*eel6
8816       return
8817       end
8818 c--------------------------------------------------------------------------
8819       double precision function eello6_graph1(i,j,k,l,imat,swap)
8820       implicit real*8 (a-h,o-z)
8821       include 'DIMENSIONS'
8822       include 'COMMON.IOUNITS'
8823       include 'COMMON.CHAIN'
8824       include 'COMMON.DERIV'
8825       include 'COMMON.INTERACT'
8826       include 'COMMON.CONTACTS'
8827       include 'COMMON.TORSION'
8828       include 'COMMON.VAR'
8829       include 'COMMON.GEO'
8830       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8831       logical swap
8832       logical lprn
8833       common /kutas/ lprn
8834 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8835 C
8836 C      Parallel       Antiparallel
8837 C
8838 C          o             o
8839 C         /l\           /j\
8840 C        /   \         /   \
8841 C       /| o |         | o |\
8842 C     \ j|/k\|  /   \  |/k\|l /
8843 C      \ /   \ /     \ /   \ /
8844 C       o     o       o     o
8845 C       i             i
8846 C
8847 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8848       itk=itortyp(itype(k))
8849       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8850       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8851       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8852       call transpose2(EUgC(1,1,k),auxmat(1,1))
8853       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8854       vv1(1)=pizda1(1,1)-pizda1(2,2)
8855       vv1(2)=pizda1(1,2)+pizda1(2,1)
8856       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8857       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8858       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8859       s5=scalar2(vv(1),Dtobr2(1,i))
8860 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8861       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8862       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8863      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8864      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8865      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8866      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8867      & +scalar2(vv(1),Dtobr2der(1,i)))
8868       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8869       vv1(1)=pizda1(1,1)-pizda1(2,2)
8870       vv1(2)=pizda1(1,2)+pizda1(2,1)
8871       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8872       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8873       if (l.eq.j+1) then
8874         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8875      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8876      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8877      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8878      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8879       else
8880         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8881      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8882      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8883      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8884      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8885       endif
8886       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8887       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8888       vv1(1)=pizda1(1,1)-pizda1(2,2)
8889       vv1(2)=pizda1(1,2)+pizda1(2,1)
8890       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8891      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8892      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8893      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8894       do iii=1,2
8895         if (swap) then
8896           ind=3-iii
8897         else
8898           ind=iii
8899         endif
8900         do kkk=1,5
8901           do lll=1,3
8902             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8903             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8904             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8905             call transpose2(EUgC(1,1,k),auxmat(1,1))
8906             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8907      &        pizda1(1,1))
8908             vv1(1)=pizda1(1,1)-pizda1(2,2)
8909             vv1(2)=pizda1(1,2)+pizda1(2,1)
8910             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8911             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8912      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8913             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8914      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8915             s5=scalar2(vv(1),Dtobr2(1,i))
8916             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8917           enddo
8918         enddo
8919       enddo
8920       return
8921       end
8922 c----------------------------------------------------------------------------
8923       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8924       implicit real*8 (a-h,o-z)
8925       include 'DIMENSIONS'
8926       include 'COMMON.IOUNITS'
8927       include 'COMMON.CHAIN'
8928       include 'COMMON.DERIV'
8929       include 'COMMON.INTERACT'
8930       include 'COMMON.CONTACTS'
8931       include 'COMMON.TORSION'
8932       include 'COMMON.VAR'
8933       include 'COMMON.GEO'
8934       logical swap
8935       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8936      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8937       logical lprn
8938       common /kutas/ lprn
8939 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8940 C                                                                              C
8941 C      Parallel       Antiparallel                                             C
8942 C                                                                              C
8943 C          o             o                                                     C
8944 C     \   /l\           /j\   /                                                C
8945 C      \ /   \         /   \ /                                                 C
8946 C       o| o |         | o |o                                                  C
8947 C     \ j|/k\|      \  |/k\|l                                                  C
8948 C      \ /   \       \ /   \                                                   C
8949 C       o             o                                                        C
8950 C       i             i                                                        C
8951 C                                                                              C
8952 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8953 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8954 C AL 7/4/01 s1 would occur in the sixth-order moment,
8955 C           but not in a cluster cumulant
8956 #ifdef MOMENT
8957       s1=dip(1,jj,i)*dip(1,kk,k)
8958 #endif
8959       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8960       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8961       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8962       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8963       call transpose2(EUg(1,1,k),auxmat(1,1))
8964       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8965       vv(1)=pizda(1,1)-pizda(2,2)
8966       vv(2)=pizda(1,2)+pizda(2,1)
8967       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8968 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8969 #ifdef MOMENT
8970       eello6_graph2=-(s1+s2+s3+s4)
8971 #else
8972       eello6_graph2=-(s2+s3+s4)
8973 #endif
8974 c      eello6_graph2=-s3
8975 C Derivatives in gamma(i-1)
8976       if (i.gt.1) then
8977 #ifdef MOMENT
8978         s1=dipderg(1,jj,i)*dip(1,kk,k)
8979 #endif
8980         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8981         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8982         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8983         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8984 #ifdef MOMENT
8985         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8986 #else
8987         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8988 #endif
8989 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8990       endif
8991 C Derivatives in gamma(k-1)
8992 #ifdef MOMENT
8993       s1=dip(1,jj,i)*dipderg(1,kk,k)
8994 #endif
8995       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8996       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8997       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8998       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8999       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9000       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
9001       vv(1)=pizda(1,1)-pizda(2,2)
9002       vv(2)=pizda(1,2)+pizda(2,1)
9003       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9004 #ifdef MOMENT
9005       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9006 #else
9007       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9008 #endif
9009 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
9010 C Derivatives in gamma(j-1) or gamma(l-1)
9011       if (j.gt.1) then
9012 #ifdef MOMENT
9013         s1=dipderg(3,jj,i)*dip(1,kk,k)
9014 #endif
9015         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
9016         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9017         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
9018         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
9019         vv(1)=pizda(1,1)-pizda(2,2)
9020         vv(2)=pizda(1,2)+pizda(2,1)
9021         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9022 #ifdef MOMENT
9023         if (swap) then
9024           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9025         else
9026           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9027         endif
9028 #endif
9029         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
9030 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
9031       endif
9032 C Derivatives in gamma(l-1) or gamma(j-1)
9033       if (l.gt.1) then
9034 #ifdef MOMENT
9035         s1=dip(1,jj,i)*dipderg(3,kk,k)
9036 #endif
9037         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
9038         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9039         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
9040         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9041         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
9042         vv(1)=pizda(1,1)-pizda(2,2)
9043         vv(2)=pizda(1,2)+pizda(2,1)
9044         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9045 #ifdef MOMENT
9046         if (swap) then
9047           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9048         else
9049           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9050         endif
9051 #endif
9052         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
9053 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
9054       endif
9055 C Cartesian derivatives.
9056       if (lprn) then
9057         write (2,*) 'In eello6_graph2'
9058         do iii=1,2
9059           write (2,*) 'iii=',iii
9060           do kkk=1,5
9061             write (2,*) 'kkk=',kkk
9062             do jjj=1,2
9063               write (2,'(3(2f10.5),5x)')
9064      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9065             enddo
9066           enddo
9067         enddo
9068       endif
9069       do iii=1,2
9070         do kkk=1,5
9071           do lll=1,3
9072 #ifdef MOMENT
9073             if (iii.eq.1) then
9074               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
9075             else
9076               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
9077             endif
9078 #endif
9079             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
9080      &        auxvec(1))
9081             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9082             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
9083      &        auxvec(1))
9084             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
9085             call transpose2(EUg(1,1,k),auxmat(1,1))
9086             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
9087      &        pizda(1,1))
9088             vv(1)=pizda(1,1)-pizda(2,2)
9089             vv(2)=pizda(1,2)+pizda(2,1)
9090             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9091 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
9092 #ifdef MOMENT
9093             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9094 #else
9095             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9096 #endif
9097             if (swap) then
9098               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9099             else
9100               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9101             endif
9102           enddo
9103         enddo
9104       enddo
9105       return
9106       end
9107 c----------------------------------------------------------------------------
9108       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
9109       implicit real*8 (a-h,o-z)
9110       include 'DIMENSIONS'
9111       include 'COMMON.IOUNITS'
9112       include 'COMMON.CHAIN'
9113       include 'COMMON.DERIV'
9114       include 'COMMON.INTERACT'
9115       include 'COMMON.CONTACTS'
9116       include 'COMMON.TORSION'
9117       include 'COMMON.VAR'
9118       include 'COMMON.GEO'
9119       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
9120       logical swap
9121 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9122 C                                                                              C
9123 C      Parallel       Antiparallel                                             C
9124 C                                                                              C
9125 C          o             o                                                     C
9126 C         /l\   /   \   /j\                                                    C
9127 C        /   \ /     \ /   \                                                   C
9128 C       /| o |o       o| o |\                                                  C
9129 C       j|/k\|  /      |/k\|l /                                                C
9130 C        /   \ /       /   \ /                                                 C
9131 C       /     o       /     o                                                  C
9132 C       i             i                                                        C
9133 C                                                                              C
9134 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9135 C
9136 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9137 C           energy moment and not to the cluster cumulant.
9138       iti=itortyp(itype(i))
9139       if (j.lt.nres-1) then
9140         itj1=itortyp(itype(j+1))
9141       else
9142         itj1=ntortyp+1
9143       endif
9144       itk=itortyp(itype(k))
9145       itk1=itortyp(itype(k+1))
9146       if (l.lt.nres-1) then
9147         itl1=itortyp(itype(l+1))
9148       else
9149         itl1=ntortyp+1
9150       endif
9151 #ifdef MOMENT
9152       s1=dip(4,jj,i)*dip(4,kk,k)
9153 #endif
9154       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
9155       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9156       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
9157       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9158       call transpose2(EE(1,1,itk),auxmat(1,1))
9159       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
9160       vv(1)=pizda(1,1)+pizda(2,2)
9161       vv(2)=pizda(2,1)-pizda(1,2)
9162       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9163 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9164 cd     & "sum",-(s2+s3+s4)
9165 #ifdef MOMENT
9166       eello6_graph3=-(s1+s2+s3+s4)
9167 #else
9168       eello6_graph3=-(s2+s3+s4)
9169 #endif
9170 c      eello6_graph3=-s4
9171 C Derivatives in gamma(k-1)
9172       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
9173       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9174       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9175       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9176 C Derivatives in gamma(l-1)
9177       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
9178       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9179       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9180       vv(1)=pizda(1,1)+pizda(2,2)
9181       vv(2)=pizda(2,1)-pizda(1,2)
9182       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9183       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9184 C Cartesian derivatives.
9185       do iii=1,2
9186         do kkk=1,5
9187           do lll=1,3
9188 #ifdef MOMENT
9189             if (iii.eq.1) then
9190               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9191             else
9192               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9193             endif
9194 #endif
9195             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
9196      &        auxvec(1))
9197             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9198             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
9199      &        auxvec(1))
9200             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9201             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
9202      &        pizda(1,1))
9203             vv(1)=pizda(1,1)+pizda(2,2)
9204             vv(2)=pizda(2,1)-pizda(1,2)
9205             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9206 #ifdef MOMENT
9207             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9208 #else
9209             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9210 #endif
9211             if (swap) then
9212               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9213             else
9214               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9215             endif
9216 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9217           enddo
9218         enddo
9219       enddo
9220       return
9221       end
9222 c----------------------------------------------------------------------------
9223       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
9224       implicit real*8 (a-h,o-z)
9225       include 'DIMENSIONS'
9226       include 'COMMON.IOUNITS'
9227       include 'COMMON.CHAIN'
9228       include 'COMMON.DERIV'
9229       include 'COMMON.INTERACT'
9230       include 'COMMON.CONTACTS'
9231       include 'COMMON.TORSION'
9232       include 'COMMON.VAR'
9233       include 'COMMON.GEO'
9234       include 'COMMON.FFIELD'
9235       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9236      & auxvec1(2),auxmat1(2,2)
9237       logical swap
9238 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9239 C                                                                              C
9240 C      Parallel       Antiparallel                                             C
9241 C                                                                              C
9242 C          o             o                                                     C
9243 C         /l\   /   \   /j\                                                    C
9244 C        /   \ /     \ /   \                                                   C
9245 C       /| o |o       o| o |\                                                  C
9246 C     \ j|/k\|      \  |/k\|l                                                  C
9247 C      \ /   \       \ /   \                                                   C
9248 C       o     \       o     \                                                  C
9249 C       i             i                                                        C
9250 C                                                                              C
9251 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9252 C
9253 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9254 C           energy moment and not to the cluster cumulant.
9255 cd      write (2,*) 'eello_graph4: wturn6',wturn6
9256       iti=itortyp(itype(i))
9257       itj=itortyp(itype(j))
9258       if (j.lt.nres-1) then
9259         itj1=itortyp(itype(j+1))
9260       else
9261         itj1=ntortyp+1
9262       endif
9263       itk=itortyp(itype(k))
9264       if (k.lt.nres-1) then
9265         itk1=itortyp(itype(k+1))
9266       else
9267         itk1=ntortyp+1
9268       endif
9269       itl=itortyp(itype(l))
9270       if (l.lt.nres-1) then
9271         itl1=itortyp(itype(l+1))
9272       else
9273         itl1=ntortyp+1
9274       endif
9275 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9276 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9277 cd     & ' itl',itl,' itl1',itl1
9278 #ifdef MOMENT
9279       if (imat.eq.1) then
9280         s1=dip(3,jj,i)*dip(3,kk,k)
9281       else
9282         s1=dip(2,jj,j)*dip(2,kk,l)
9283       endif
9284 #endif
9285       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9286       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9287       if (j.eq.l+1) then
9288         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
9289         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9290       else
9291         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
9292         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9293       endif
9294       call transpose2(EUg(1,1,k),auxmat(1,1))
9295       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9296       vv(1)=pizda(1,1)-pizda(2,2)
9297       vv(2)=pizda(2,1)+pizda(1,2)
9298       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9299 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9300 #ifdef MOMENT
9301       eello6_graph4=-(s1+s2+s3+s4)
9302 #else
9303       eello6_graph4=-(s2+s3+s4)
9304 #endif
9305 C Derivatives in gamma(i-1)
9306       if (i.gt.1) then
9307 #ifdef MOMENT
9308         if (imat.eq.1) then
9309           s1=dipderg(2,jj,i)*dip(3,kk,k)
9310         else
9311           s1=dipderg(4,jj,j)*dip(2,kk,l)
9312         endif
9313 #endif
9314         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9315         if (j.eq.l+1) then
9316           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
9317           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9318         else
9319           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
9320           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9321         endif
9322         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9323         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9324 cd          write (2,*) 'turn6 derivatives'
9325 #ifdef MOMENT
9326           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9327 #else
9328           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9329 #endif
9330         else
9331 #ifdef MOMENT
9332           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9333 #else
9334           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9335 #endif
9336         endif
9337       endif
9338 C Derivatives in gamma(k-1)
9339 #ifdef MOMENT
9340       if (imat.eq.1) then
9341         s1=dip(3,jj,i)*dipderg(2,kk,k)
9342       else
9343         s1=dip(2,jj,j)*dipderg(4,kk,l)
9344       endif
9345 #endif
9346       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9347       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9348       if (j.eq.l+1) then
9349         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
9350         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9351       else
9352         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
9353         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9354       endif
9355       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9356       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9357       vv(1)=pizda(1,1)-pizda(2,2)
9358       vv(2)=pizda(2,1)+pizda(1,2)
9359       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9360       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9361 #ifdef MOMENT
9362         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9363 #else
9364         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9365 #endif
9366       else
9367 #ifdef MOMENT
9368         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9369 #else
9370         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9371 #endif
9372       endif
9373 C Derivatives in gamma(j-1) or gamma(l-1)
9374       if (l.eq.j+1 .and. l.gt.1) then
9375         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9376         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9377         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9378         vv(1)=pizda(1,1)-pizda(2,2)
9379         vv(2)=pizda(2,1)+pizda(1,2)
9380         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9381         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9382       else if (j.gt.1) then
9383         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9384         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9385         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9386         vv(1)=pizda(1,1)-pizda(2,2)
9387         vv(2)=pizda(2,1)+pizda(1,2)
9388         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9389         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9390           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9391         else
9392           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9393         endif
9394       endif
9395 C Cartesian derivatives.
9396       do iii=1,2
9397         do kkk=1,5
9398           do lll=1,3
9399 #ifdef MOMENT
9400             if (iii.eq.1) then
9401               if (imat.eq.1) then
9402                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9403               else
9404                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9405               endif
9406             else
9407               if (imat.eq.1) then
9408                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9409               else
9410                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9411               endif
9412             endif
9413 #endif
9414             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
9415      &        auxvec(1))
9416             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9417             if (j.eq.l+1) then
9418               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9419      &          b1(1,itj1),auxvec(1))
9420               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
9421             else
9422               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9423      &          b1(1,itl1),auxvec(1))
9424               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
9425             endif
9426             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9427      &        pizda(1,1))
9428             vv(1)=pizda(1,1)-pizda(2,2)
9429             vv(2)=pizda(2,1)+pizda(1,2)
9430             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9431             if (swap) then
9432               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9433 #ifdef MOMENT
9434                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9435      &             -(s1+s2+s4)
9436 #else
9437                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9438      &             -(s2+s4)
9439 #endif
9440                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9441               else
9442 #ifdef MOMENT
9443                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9444 #else
9445                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9446 #endif
9447                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9448               endif
9449             else
9450 #ifdef MOMENT
9451               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9452 #else
9453               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9454 #endif
9455               if (l.eq.j+1) then
9456                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9457               else
9458                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9459               endif
9460             endif
9461           enddo
9462         enddo
9463       enddo
9464       return
9465       end
9466 c----------------------------------------------------------------------------
9467       double precision function eello_turn6(i,jj,kk)
9468       implicit real*8 (a-h,o-z)
9469       include 'DIMENSIONS'
9470       include 'COMMON.IOUNITS'
9471       include 'COMMON.CHAIN'
9472       include 'COMMON.DERIV'
9473       include 'COMMON.INTERACT'
9474       include 'COMMON.CONTACTS'
9475       include 'COMMON.TORSION'
9476       include 'COMMON.VAR'
9477       include 'COMMON.GEO'
9478       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
9479      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
9480      &  ggg1(3),ggg2(3)
9481       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
9482      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
9483 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9484 C           the respective energy moment and not to the cluster cumulant.
9485       s1=0.0d0
9486       s8=0.0d0
9487       s13=0.0d0
9488 c
9489       eello_turn6=0.0d0
9490       j=i+4
9491       k=i+1
9492       l=i+3
9493       iti=itortyp(itype(i))
9494       itk=itortyp(itype(k))
9495       itk1=itortyp(itype(k+1))
9496       itl=itortyp(itype(l))
9497       itj=itortyp(itype(j))
9498 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9499 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
9500 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9501 cd        eello6=0.0d0
9502 cd        return
9503 cd      endif
9504 cd      write (iout,*)
9505 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9506 cd     &   ' and',k,l
9507 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
9508       do iii=1,2
9509         do kkk=1,5
9510           do lll=1,3
9511             derx_turn(lll,kkk,iii)=0.0d0
9512           enddo
9513         enddo
9514       enddo
9515 cd      eij=1.0d0
9516 cd      ekl=1.0d0
9517 cd      ekont=1.0d0
9518       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9519 cd      eello6_5=0.0d0
9520 cd      write (2,*) 'eello6_5',eello6_5
9521 #ifdef MOMENT
9522       call transpose2(AEA(1,1,1),auxmat(1,1))
9523       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
9524       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
9525       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
9526 #endif
9527       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9528       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
9529       s2 = scalar2(b1(1,itk),vtemp1(1))
9530 #ifdef MOMENT
9531       call transpose2(AEA(1,1,2),atemp(1,1))
9532       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
9533       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
9534       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9535 #endif
9536       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
9537       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
9538       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
9539 #ifdef MOMENT
9540       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
9541       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
9542       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
9543       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
9544       ss13 = scalar2(b1(1,itk),vtemp4(1))
9545       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
9546 #endif
9547 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
9548 c      s1=0.0d0
9549 c      s2=0.0d0
9550 c      s8=0.0d0
9551 c      s12=0.0d0
9552 c      s13=0.0d0
9553       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
9554 C Derivatives in gamma(i+2)
9555       s1d =0.0d0
9556       s8d =0.0d0
9557 #ifdef MOMENT
9558       call transpose2(AEA(1,1,1),auxmatd(1,1))
9559       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9560       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9561       call transpose2(AEAderg(1,1,2),atempd(1,1))
9562       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9563       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9564 #endif
9565       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
9566       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9567       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9568 c      s1d=0.0d0
9569 c      s2d=0.0d0
9570 c      s8d=0.0d0
9571 c      s12d=0.0d0
9572 c      s13d=0.0d0
9573       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
9574 C Derivatives in gamma(i+3)
9575 #ifdef MOMENT
9576       call transpose2(AEA(1,1,1),auxmatd(1,1))
9577       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9578       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
9579       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
9580 #endif
9581       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
9582       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
9583       s2d = scalar2(b1(1,itk),vtemp1d(1))
9584 #ifdef MOMENT
9585       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
9586       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
9587 #endif
9588       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
9589 #ifdef MOMENT
9590       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
9591       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9592       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9593 #endif
9594 c      s1d=0.0d0
9595 c      s2d=0.0d0
9596 c      s8d=0.0d0
9597 c      s12d=0.0d0
9598 c      s13d=0.0d0
9599 #ifdef MOMENT
9600       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9601      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9602 #else
9603       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9604      &               -0.5d0*ekont*(s2d+s12d)
9605 #endif
9606 C Derivatives in gamma(i+4)
9607       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
9608       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9609       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9610 #ifdef MOMENT
9611       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
9612       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
9613       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9614 #endif
9615 c      s1d=0.0d0
9616 c      s2d=0.0d0
9617 c      s8d=0.0d0
9618 C      s12d=0.0d0
9619 c      s13d=0.0d0
9620 #ifdef MOMENT
9621       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
9622 #else
9623       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
9624 #endif
9625 C Derivatives in gamma(i+5)
9626 #ifdef MOMENT
9627       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
9628       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9629       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9630 #endif
9631       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
9632       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
9633       s2d = scalar2(b1(1,itk),vtemp1d(1))
9634 #ifdef MOMENT
9635       call transpose2(AEA(1,1,2),atempd(1,1))
9636       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
9637       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9638 #endif
9639       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
9640       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9641 #ifdef MOMENT
9642       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
9643       ss13d = scalar2(b1(1,itk),vtemp4d(1))
9644       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9645 #endif
9646 c      s1d=0.0d0
9647 c      s2d=0.0d0
9648 c      s8d=0.0d0
9649 c      s12d=0.0d0
9650 c      s13d=0.0d0
9651 #ifdef MOMENT
9652       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9653      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9654 #else
9655       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9656      &               -0.5d0*ekont*(s2d+s12d)
9657 #endif
9658 C Cartesian derivatives
9659       do iii=1,2
9660         do kkk=1,5
9661           do lll=1,3
9662 #ifdef MOMENT
9663             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
9664             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9665             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9666 #endif
9667             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9668             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
9669      &          vtemp1d(1))
9670             s2d = scalar2(b1(1,itk),vtemp1d(1))
9671 #ifdef MOMENT
9672             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
9673             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9674             s8d = -(atempd(1,1)+atempd(2,2))*
9675      &           scalar2(cc(1,1,itl),vtemp2(1))
9676 #endif
9677             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
9678      &           auxmatd(1,1))
9679             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9680             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9681 c      s1d=0.0d0
9682 c      s2d=0.0d0
9683 c      s8d=0.0d0
9684 c      s12d=0.0d0
9685 c      s13d=0.0d0
9686 #ifdef MOMENT
9687             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9688      &        - 0.5d0*(s1d+s2d)
9689 #else
9690             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9691      &        - 0.5d0*s2d
9692 #endif
9693 #ifdef MOMENT
9694             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9695      &        - 0.5d0*(s8d+s12d)
9696 #else
9697             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9698      &        - 0.5d0*s12d
9699 #endif
9700           enddo
9701         enddo
9702       enddo
9703 #ifdef MOMENT
9704       do kkk=1,5
9705         do lll=1,3
9706           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9707      &      achuj_tempd(1,1))
9708           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9709           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9710           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9711           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9712           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9713      &      vtemp4d(1))
9714           ss13d = scalar2(b1(1,itk),vtemp4d(1))
9715           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9716           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9717         enddo
9718       enddo
9719 #endif
9720 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9721 cd     &  16*eel_turn6_num
9722 cd      goto 1112
9723       if (j.lt.nres-1) then
9724         j1=j+1
9725         j2=j-1
9726       else
9727         j1=j-1
9728         j2=j-2
9729       endif
9730       if (l.lt.nres-1) then
9731         l1=l+1
9732         l2=l-1
9733       else
9734         l1=l-1
9735         l2=l-2
9736       endif
9737       do ll=1,3
9738 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9739 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9740 cgrad        ghalf=0.5d0*ggg1(ll)
9741 cd        ghalf=0.0d0
9742         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9743         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9744         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9745      &    +ekont*derx_turn(ll,2,1)
9746         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9747         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9748      &    +ekont*derx_turn(ll,4,1)
9749         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9750         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9751         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9752 cgrad        ghalf=0.5d0*ggg2(ll)
9753 cd        ghalf=0.0d0
9754         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9755      &    +ekont*derx_turn(ll,2,2)
9756         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9757         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9758      &    +ekont*derx_turn(ll,4,2)
9759         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9760         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9761         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9762       enddo
9763 cd      goto 1112
9764 cgrad      do m=i+1,j-1
9765 cgrad        do ll=1,3
9766 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9767 cgrad        enddo
9768 cgrad      enddo
9769 cgrad      do m=k+1,l-1
9770 cgrad        do ll=1,3
9771 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9772 cgrad        enddo
9773 cgrad      enddo
9774 cgrad1112  continue
9775 cgrad      do m=i+2,j2
9776 cgrad        do ll=1,3
9777 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9778 cgrad        enddo
9779 cgrad      enddo
9780 cgrad      do m=k+2,l2
9781 cgrad        do ll=1,3
9782 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9783 cgrad        enddo
9784 cgrad      enddo
9785 cd      do iii=1,nres-3
9786 cd        write (2,*) iii,g_corr6_loc(iii)
9787 cd      enddo
9788       eello_turn6=ekont*eel_turn6
9789 cd      write (2,*) 'ekont',ekont
9790 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9791       return
9792       end
9793
9794 C-----------------------------------------------------------------------------
9795       double precision function scalar(u,v)
9796 !DIR$ INLINEALWAYS scalar
9797 #ifndef OSF
9798 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9799 #endif
9800       implicit none
9801       double precision u(3),v(3)
9802 cd      double precision sc
9803 cd      integer i
9804 cd      sc=0.0d0
9805 cd      do i=1,3
9806 cd        sc=sc+u(i)*v(i)
9807 cd      enddo
9808 cd      scalar=sc
9809
9810       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9811       return
9812       end
9813 crc-------------------------------------------------
9814       SUBROUTINE MATVEC2(A1,V1,V2)
9815 !DIR$ INLINEALWAYS MATVEC2
9816 #ifndef OSF
9817 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9818 #endif
9819       implicit real*8 (a-h,o-z)
9820       include 'DIMENSIONS'
9821       DIMENSION A1(2,2),V1(2),V2(2)
9822 c      DO 1 I=1,2
9823 c        VI=0.0
9824 c        DO 3 K=1,2
9825 c    3     VI=VI+A1(I,K)*V1(K)
9826 c        Vaux(I)=VI
9827 c    1 CONTINUE
9828
9829       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9830       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9831
9832       v2(1)=vaux1
9833       v2(2)=vaux2
9834       END
9835 C---------------------------------------
9836       SUBROUTINE MATMAT2(A1,A2,A3)
9837 #ifndef OSF
9838 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9839 #endif
9840       implicit real*8 (a-h,o-z)
9841       include 'DIMENSIONS'
9842       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9843 c      DIMENSION AI3(2,2)
9844 c        DO  J=1,2
9845 c          A3IJ=0.0
9846 c          DO K=1,2
9847 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9848 c          enddo
9849 c          A3(I,J)=A3IJ
9850 c       enddo
9851 c      enddo
9852
9853       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9854       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9855       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9856       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9857
9858       A3(1,1)=AI3_11
9859       A3(2,1)=AI3_21
9860       A3(1,2)=AI3_12
9861       A3(2,2)=AI3_22
9862       END
9863
9864 c-------------------------------------------------------------------------
9865       double precision function scalar2(u,v)
9866 !DIR$ INLINEALWAYS scalar2
9867       implicit none
9868       double precision u(2),v(2)
9869       double precision sc
9870       integer i
9871       scalar2=u(1)*v(1)+u(2)*v(2)
9872       return
9873       end
9874
9875 C-----------------------------------------------------------------------------
9876
9877       subroutine transpose2(a,at)
9878 !DIR$ INLINEALWAYS transpose2
9879 #ifndef OSF
9880 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9881 #endif
9882       implicit none
9883       double precision a(2,2),at(2,2)
9884       at(1,1)=a(1,1)
9885       at(1,2)=a(2,1)
9886       at(2,1)=a(1,2)
9887       at(2,2)=a(2,2)
9888       return
9889       end
9890 c--------------------------------------------------------------------------
9891       subroutine transpose(n,a,at)
9892       implicit none
9893       integer n,i,j
9894       double precision a(n,n),at(n,n)
9895       do i=1,n
9896         do j=1,n
9897           at(j,i)=a(i,j)
9898         enddo
9899       enddo
9900       return
9901       end
9902 C---------------------------------------------------------------------------
9903       subroutine prodmat3(a1,a2,kk,transp,prod)
9904 !DIR$ INLINEALWAYS prodmat3
9905 #ifndef OSF
9906 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9907 #endif
9908       implicit none
9909       integer i,j
9910       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9911       logical transp
9912 crc      double precision auxmat(2,2),prod_(2,2)
9913
9914       if (transp) then
9915 crc        call transpose2(kk(1,1),auxmat(1,1))
9916 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9917 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9918
9919            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9920      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9921            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9922      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9923            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9924      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9925            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9926      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9927
9928       else
9929 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9930 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9931
9932            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9933      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9934            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9935      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9936            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9937      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9938            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9939      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9940
9941       endif
9942 c      call transpose2(a2(1,1),a2t(1,1))
9943
9944 crc      print *,transp
9945 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9946 crc      print *,((prod(i,j),i=1,2),j=1,2)
9947
9948       return
9949       end
9950