source/unres/src_MD/energy_p_new_barrier.F

   1       subroutine etotal(energia)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4 #ifndef ISNAN
   5       external proc_proc
   6 #ifdef WINPGI
   7 cMS$ATTRIBUTES C ::  proc_proc
   8 #endif
   9 #endif
  10 #ifdef MPI
  11       include "mpif.h"
  12       double precision weights_(n_ene)
  13 #endif
  14       include 'COMMON.SETUP'
  15       include 'COMMON.IOUNITS'
  16       double precision energia(0:n_ene)
  17       include 'COMMON.LOCAL'
  18       include 'COMMON.FFIELD'
  19       include 'COMMON.DERIV'
  20       include 'COMMON.INTERACT'
  21       include 'COMMON.SBRIDGE'
  22       include 'COMMON.CHAIN'
  23       include 'COMMON.VAR'
  24       include 'COMMON.MD'
  25       include 'COMMON.CONTROL'
  26       include 'COMMON.TIME1'
  27 #ifdef MPI
  28 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  29 c     & " nfgtasks",nfgtasks
  30       call flush(iout)
  31       if (nfgtasks.gt.1) then
  32 #ifdef MPI
  33         time00=MPI_Wtime()
  34 #else
  35         time00=tcpu()
  36 #endif
  37 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  38         if (fg_rank.eq.0) then
  39           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  40 c          print *,"Processor",myrank," BROADCAST iorder"
  41 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  42 C FG slaves as WEIGHTS array.
  43           weights_(1)=wsc
  44           weights_(2)=wscp
  45           weights_(3)=welec
  46           weights_(4)=wcorr
  47           weights_(5)=wcorr5
  48           weights_(6)=wcorr6
  49           weights_(7)=wel_loc
  50           weights_(8)=wturn3
  51           weights_(9)=wturn4
  52           weights_(10)=wturn6
  53           weights_(11)=wang
  54           weights_(12)=wscloc
  55           weights_(13)=wtor
  56           weights_(14)=wtor_d
  57           weights_(15)=wstrain
  58           weights_(16)=wvdwpp
  59           weights_(17)=wbond
  60           weights_(18)=scal14
  61           weights_(21)=wsccor
  62           weights_(22)=wsct
  63 C FG Master broadcasts the WEIGHTS_ array
  64           call MPI_Bcast(weights_(1),n_ene,
  65      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  66         else
  67 C FG slaves receive the WEIGHTS array
  68           call MPI_Bcast(weights(1),n_ene,
  69      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  70           wsc=weights(1)
  71           wscp=weights(2)
  72           welec=weights(3)
  73           wcorr=weights(4)
  74           wcorr5=weights(5)
  75           wcorr6=weights(6)
  76           wel_loc=weights(7)
  77           wturn3=weights(8)
  78           wturn4=weights(9)
  79           wturn6=weights(10)
  80           wang=weights(11)
  81           wscloc=weights(12)
  82           wtor=weights(13)
  83           wtor_d=weights(14)
  84           wstrain=weights(15)
  85           wvdwpp=weights(16)
  86           wbond=weights(17)
  87           scal14=weights(18)
  88           wsccor=weights(21)
  89           wsct=weights(22)
  90         endif
  91         time_Bcast=time_Bcast+MPI_Wtime()-time00
  92         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  93 c        call chainbuild_cart
  94       endif
  95 c      write(iout,*) 'Processor',myrank,' calling etotal ipot=',ipot
  96 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  97 #else
  98 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  99 c        call int_from_cart1(.false.)
 100 c      endif
 101 #endif
 102 #ifndef DFA
 103       edfadis=0.0d0
 104       edfator=0.0d0
 105       edfanei=0.0d0
 106       edfabet=0.0d0
 107 #endif
 108 #ifdef TIMING
 109 #ifdef MPI
 110       time00=MPI_Wtime()
 111 #else
 112       time00=tcpu()
 113 #endif
 114 #endif
 115 C
 116 C Compute the side-chain and electrostatic interaction energy
 117 C
 118       goto (101,102,103,104,105,106) ipot
 119 C Lennard-Jones potential.
 120   101 call elj(evdw,evdw_p,evdw_m)
 121 cd    print '(a)','Exit ELJ'
 122       goto 107
 123 C Lennard-Jones-Kihara potential (shifted).
 124   102 call eljk(evdw,evdw_p,evdw_m)
 125       goto 107
 126 C Berne-Pechukas potential (dilated LJ, angular dependence).
 127   103 call ebp(evdw,evdw_p,evdw_m)
 128       goto 107
 129 C Gay-Berne potential (shifted LJ, angular dependence).
 130   104 call egb(evdw,evdw_p,evdw_m)
 131       goto 107
 132 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 133   105 call egbv(evdw,evdw_p,evdw_m)
 134       goto 107
 135 C Soft-sphere potential
 136   106 call e_softsphere(evdw)
 137 C
 138 C Calculate electrostatic (H-bonding) energy of the main chain.
 139 C
 140   107 continue
 141 #ifdef DFA
 142 C     BARTEK for dfa test!
 143       if (wdfa_dist.gt.0) then
 144         call edfad(edfadis)
 145       else
 146         edfadis=0
 147       endif
 148 c      print*, 'edfad is finished!', edfadis
 149       if (wdfa_tor.gt.0) then
 150         call edfat(edfator)
 151       else
 152         edfator=0
 153       endif
 154 c      print*, 'edfat is finished!', edfator
 155       if (wdfa_nei.gt.0) then
 156         call edfan(edfanei)
 157       else
 158         edfanei=0
 159       endif
 160 c      print*, 'edfan is finished!', edfanei
 161       if (wdfa_beta.gt.0) then
 162         call edfab(edfabet)
 163       else
 164         edfabet=0
 165       endif
 166 #endif
 167 c      print*, 'edfab is finished!', edfabet
 168 cmc
 169 cmc Sep-06: egb takes care of dynamic ss bonds too
 170 cmc
 171 c      if (dyn_ss) call dyn_set_nss
 172
 173 c      print *,"Processor",myrank," computed USCSC"
 174 #ifdef TIMING
 175 #ifdef MPI
 176       time01=MPI_Wtime()
 177 #else
 178       time00=tcpu()
 179 #endif
 180 #endif
 181       call vec_and_deriv
 182 #ifdef TIMING
 183 #ifdef MPI
 184       time_vec=time_vec+MPI_Wtime()-time01
 185 #else
 186       time_vec=time_vec+tcpu()-time01
 187 #endif
 188 #endif
 189 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 190       if (ipot.lt.6) then
 191 #ifdef SPLITELE
 192          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 193      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 194      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 195      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 196 #else
 197          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 198      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 199      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 200      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 201 #endif
 202             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 203          else
 204             ees=0.0d0
 205             evdw1=0.0d0
 206             eel_loc=0.0d0
 207             eello_turn3=0.0d0
 208             eello_turn4=0.0d0
 209          endif
 210       else
 211 c        write (iout,*) "Soft-spheer ELEC potential"
 212         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 213      &   eello_turn4)
 214       endif
 215 c      print *,"Processor",myrank," computed UELEC"
 216 C
 217 C Calculate excluded-volume interaction energy between peptide groups
 218 C and side chains.
 219 C
 220       if (ipot.lt.6) then
 221        if(wscp.gt.0d0) then
 222         call escp(evdw2,evdw2_14)
 223        else
 224         evdw2=0
 225         evdw2_14=0
 226        endif
 227       else
 228 c        write (iout,*) "Soft-sphere SCP potential"
 229         call escp_soft_sphere(evdw2,evdw2_14)
 230       endif
 231 c
 232 c Calculate the bond-stretching energy
 233 c
 234       call ebond(estr)
 235 C
 236 C Calculate the disulfide-bridge and other energy and the contributions
 237 C from other distance constraints.
 238 cd    print *,'Calling EHPB'
 239       call edis(ehpb)
 240 cd    print *,'EHPB exitted succesfully.'
 241 C
 242 C Calculate the virtual-bond-angle energy.
 243 C
 244       if (wang.gt.0d0) then
 245         call ebend(ebe)
 246       else
 247         ebe=0
 248       endif
 249 c      print *,"Processor",myrank," computed UB"
 250 C
 251 C Calculate the SC local energy.
 252 C
 253       call esc(escloc)
 254 c      print *,"Processor",myrank," computed USC"
 255 C
 256 C Calculate the virtual-bond torsional energy.
 257 C
 258 cd    print *,'nterm=',nterm
 259       if (wtor.gt.0) then
 260        call etor(etors,edihcnstr)
 261       else
 262        etors=0
 263        edihcnstr=0
 264       endif
 265
 266       if (constr_homology.ge.1.and.waga_homology(iset).ne.0d0) then
 267         call e_modeller(ehomology_constr)
 268 c        print *,'iset=',iset,'me=',me,ehomology_constr,
 269 c     &  'Processor',fg_rank,' CG group',kolor,
 270 c     &  ' absolute rank',MyRank
 271       else
 272         ehomology_constr=0.0d0
 273       endif
 274
 275
 276 c      write(iout,*) ehomology_constr
 277 c      print *,"Processor",myrank," computed Utor"
 278 C
 279 C 6/23/01 Calculate double-torsional energy
 280 C
 281       if (wtor_d.gt.0) then
 282        call etor_d(etors_d)
 283       else
 284        etors_d=0
 285       endif
 286 c      print *,"Processor",myrank," computed Utord"
 287 C
 288 C 21/5/07 Calculate local sicdechain correlation energy
 289 C
 290       if (wsccor.gt.0.0d0) then
 291         call eback_sc_corr(esccor)
 292       else
 293         esccor=0.0d0
 294       endif
 295 c      print *,"Processor",myrank," computed Usccorr"
 296 C
 297 C 12/1/95 Multi-body terms
 298 C
 299       n_corr=0
 300       n_corr1=0
 301       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 302      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 303          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 304 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 305 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 306       else
 307          ecorr=0.0d0
 308          ecorr5=0.0d0
 309          ecorr6=0.0d0
 310          eturn6=0.0d0
 311       endif
 312       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 313          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 314 cd         write (iout,*) "multibody_hb ecorr",ecorr
 315       endif
 316 c      print *,"Processor",myrank," computed Ucorr"
 317 C
 318 C If performing constraint dynamics, call the constraint energy
 319 C  after the equilibration time
 320       if(usampl.and.totT.gt.eq_time) then
 321 c         write (iout,*) "CALL TO ECONSTR_BACK"
 322          call EconstrQ
 323          call Econstr_back
 324       else
 325          Uconst=0.0d0
 326          Uconst_back=0.0d0
 327       endif
 328 #ifdef TIMING
 329 #ifdef MPI
 330       time_enecalc=time_enecalc+MPI_Wtime()-time00
 331 #else
 332       time_enecalc=time_enecalc+tcpu()-time00
 333 #endif
 334 #endif
 335 c      print *,"Processor",myrank," computed Uconstr"
 336 #ifdef TIMING
 337 #ifdef MPI
 338       time00=MPI_Wtime()
 339 #else
 340       time00=tcpu()
 341 #endif
 342 #endif
 343 c
 344 C Sum the energies
 345 C
 346       energia(1)=evdw
 347 #ifdef SCP14
 348       energia(2)=evdw2-evdw2_14
 349       energia(18)=evdw2_14
 350 #else
 351       energia(2)=evdw2
 352       energia(18)=0.0d0
 353 #endif
 354 #ifdef SPLITELE
 355       energia(3)=ees
 356       energia(16)=evdw1
 357 #else
 358       energia(3)=ees+evdw1
 359       energia(16)=0.0d0
 360 #endif
 361       energia(4)=ecorr
 362       energia(5)=ecorr5
 363       energia(6)=ecorr6
 364       energia(7)=eel_loc
 365       energia(8)=eello_turn3
 366       energia(9)=eello_turn4
 367       energia(10)=eturn6
 368       energia(11)=ebe
 369       energia(12)=escloc
 370       energia(13)=etors
 371       energia(14)=etors_d
 372       energia(15)=ehpb
 373       energia(19)=edihcnstr
 374       energia(17)=estr
 375       energia(20)=Uconst+Uconst_back
 376       energia(21)=esccor
 377       energia(22)=evdw_p
 378       energia(23)=evdw_m
 379       energia(24)=ehomology_constr
 380       energia(25)=edfadis
 381       energia(26)=edfator
 382       energia(27)=edfanei
 383       energia(28)=edfabet
 384 c      print *," Processor",myrank," calls SUM_ENERGY"
 385       call sum_energy(energia,.true.)
 386       if (dyn_ss) call dyn_set_nss
 387 c      print *," Processor",myrank," left SUM_ENERGY"
 388 #ifdef TIMING
 389 #ifdef MPI
 390       time_sumene=time_sumene+MPI_Wtime()-time00
 391 #else
 392       time_sumene=time_sumene+tcpu()-time00
 393 #endif
 394 #endif
 395       return
 396       end
 397 c-------------------------------------------------------------------------------
 398       subroutine sum_energy(energia,reduce)
 399       implicit real*8 (a-h,o-z)
 400       include 'DIMENSIONS'
 401 #ifndef ISNAN
 402       external proc_proc
 403 #ifdef WINPGI
 404 cMS$ATTRIBUTES C ::  proc_proc
 405 #endif
 406 #endif
 407 #ifdef MPI
 408       include "mpif.h"
 409 #endif
 410       include 'COMMON.SETUP'
 411       include 'COMMON.IOUNITS'
 412       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 413       include 'COMMON.FFIELD'
 414       include 'COMMON.DERIV'
 415       include 'COMMON.INTERACT'
 416       include 'COMMON.SBRIDGE'
 417       include 'COMMON.CHAIN'
 418       include 'COMMON.VAR'
 419       include 'COMMON.CONTROL'
 420       include 'COMMON.TIME1'
 421       logical reduce
 422 #ifdef MPI
 423       if (nfgtasks.gt.1 .and. reduce) then
 424 #ifdef DEBUG
 425         write (iout,*) "energies before REDUCE"
 426         call enerprint(energia)
 427         call flush(iout)
 428 #endif
 429         do i=0,n_ene
 430           enebuff(i)=energia(i)
 431         enddo
 432         time00=MPI_Wtime()
 433         call MPI_Barrier(FG_COMM,IERR)
 434         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 435         time00=MPI_Wtime()
 436         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 437      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 438 #ifdef DEBUG
 439         write (iout,*) "energies after REDUCE"
 440         call enerprint(energia)
 441         call flush(iout)
 442 #endif
 443         time_Reduce=time_Reduce+MPI_Wtime()-time00
 444       endif
 445       if (fg_rank.eq.0) then
 446 #endif
 447 #ifdef TSCSC
 448       evdw=energia(22)+wsct*energia(23)
 449 #else
 450       evdw=energia(1)
 451 #endif
 452 #ifdef SCP14
 453       evdw2=energia(2)+energia(18)
 454       evdw2_14=energia(18)
 455 #else
 456       evdw2=energia(2)
 457 #endif
 458 #ifdef SPLITELE
 459       ees=energia(3)
 460       evdw1=energia(16)
 461 #else
 462       ees=energia(3)
 463       evdw1=0.0d0
 464 #endif
 465       ecorr=energia(4)
 466       ecorr5=energia(5)
 467       ecorr6=energia(6)
 468       eel_loc=energia(7)
 469       eello_turn3=energia(8)
 470       eello_turn4=energia(9)
 471       eturn6=energia(10)
 472       ebe=energia(11)
 473       escloc=energia(12)
 474       etors=energia(13)
 475       etors_d=energia(14)
 476       ehpb=energia(15)
 477       edihcnstr=energia(19)
 478       estr=energia(17)
 479       Uconst=energia(20)
 480       esccor=energia(21)
 481       ehomology_constr=energia(24)
 482       edfadis=energia(25)
 483       edfator=energia(26)
 484       edfanei=energia(27)
 485       edfabet=energia(28)
 486 #ifdef SPLITELE
 487       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 488      & +wang*ebe+wtor*etors+wscloc*escloc
 489      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 490      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 491      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 492      & +wbond*estr+Uconst+wsccor*esccor+ehomology_constr
 493      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 494      & +wdfa_beta*edfabet
 495 #else
 496       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 497      & +wang*ebe+wtor*etors+wscloc*escloc
 498      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 499      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 500      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 501      & +wbond*estr+Uconst+wsccor*esccor+ehomology_constr
 502      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 503      & +wdfa_beta*edfabet
 504 #endif
 505       energia(0)=etot
 506 c detecting NaNQ
 507 #ifdef ISNAN
 508 #ifdef AIX
 509       if (isnan(etot).ne.0) energia(0)=1.0d+99
 510 #else
 511       if (isnan(etot)) energia(0)=1.0d+99
 512 #endif
 513 #else
 514       i=0
 515 #ifdef WINPGI
 516       idumm=proc_proc(etot,i)
 517 #else
 518       call proc_proc(etot,i)
 519 #endif
 520       if(i.eq.1)energia(0)=1.0d+99
 521 #endif
 522 #ifdef MPI
 523       endif
 524 #endif
 525       return
 526       end
 527 c-------------------------------------------------------------------------------
 528       subroutine sum_gradient
 529       implicit real*8 (a-h,o-z)
 530       include 'DIMENSIONS'
 531 #ifndef ISNAN
 532       external proc_proc
 533 #ifdef WINPGI
 534 cMS$ATTRIBUTES C ::  proc_proc
 535 #endif
 536 #endif
 537 #ifdef MPI
 538       include 'mpif.h'
 539 #endif
 540       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 541      &  glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres)
 542       include 'COMMON.SETUP'
 543       include 'COMMON.IOUNITS'
 544       include 'COMMON.FFIELD'
 545       include 'COMMON.DERIV'
 546       include 'COMMON.INTERACT'
 547       include 'COMMON.SBRIDGE'
 548       include 'COMMON.CHAIN'
 549       include 'COMMON.VAR'
 550       include 'COMMON.CONTROL'
 551       include 'COMMON.TIME1'
 552       include 'COMMON.MAXGRAD'
 553       include 'COMMON.SCCOR'
 554       include 'COMMON.MD'
 555 #ifdef TIMING
 556 #ifdef MPI
 557       time01=MPI_Wtime()
 558 #else
 559       time01=tcpu()
 560 #endif
 561 #endif
 562 #ifdef DEBUG
 563       write (iout,*) "sum_gradient gvdwc, gvdwx"
 564       do i=1,nres
 565         write (iout,'(i3,3f10.5,5x,3f10.5,5x,3f10.5,5x,3f10.5)')
 566      &   i,(gvdwx(j,i),j=1,3),(gvdwcT(j,i),j=1,3),(gvdwc(j,i),j=1,3),
 567      &   (gvdwcT(j,i),j=1,3)
 568       enddo
 569       call flush(iout)
 570 #endif
 571 #ifdef MPI
 572 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 573         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 574      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 575 #endif
 576 C
 577 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 578 C            in virtual-bond-vector coordinates
 579 C
 580 #ifdef DEBUG
 581 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 582 c      do i=1,nres-1
 583 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 584 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 585 c      enddo
 586 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 587 c      do i=1,nres-1
 588 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 589 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 590 c      enddo
 591       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 592       do i=1,nres
 593         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 594      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 595      &   g_corr5_loc(i)
 596       enddo
 597       call flush(iout)
 598 #endif
 599 #ifdef SPLITELE
 600 #ifdef TSCSC
 601       do i=1,nct
 602         do j=1,3
 603           gradbufc(j,i)=wsc*gvdwc(j,i)+wsc*wscT*gvdwcT(j,i)+
 604      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 605      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 606      &                wel_loc*gel_loc_long(j,i)+
 607      &                wcorr*gradcorr_long(j,i)+
 608      &                wcorr5*gradcorr5_long(j,i)+
 609      &                wcorr6*gradcorr6_long(j,i)+
 610      &                wturn6*gcorr6_turn_long(j,i)+
 611      &                wstrain*ghpbc(j,i)+
 612      &                wdfa_dist*gdfad(j,i)+
 613      &                wdfa_tor*gdfat(j,i)+
 614      &                wdfa_nei*gdfan(j,i)+
 615      &                wdfa_beta*gdfab(j,i)
 616         enddo
 617       enddo
 618 #else
 619       do i=1,nct
 620         do j=1,3
 621           gradbufc(j,i)=wsc*gvdwc(j,i)+
 622      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 623      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 624      &                wel_loc*gel_loc_long(j,i)+
 625      &                wcorr*gradcorr_long(j,i)+
 626      &                wcorr5*gradcorr5_long(j,i)+
 627      &                wcorr6*gradcorr6_long(j,i)+
 628      &                wturn6*gcorr6_turn_long(j,i)+
 629      &                wstrain*ghpbc(j,i)+
 630      &                wdfa_dist*gdfad(j,i)+
 631      &                wdfa_tor*gdfat(j,i)+
 632      &                wdfa_nei*gdfan(j,i)+
 633      &                wdfa_beta*gdfab(j,i)
 634         enddo
 635       enddo
 636 #endif
 637 #else
 638       do i=1,nct
 639         do j=1,3
 640           gradbufc(j,i)=wsc*gvdwc(j,i)+
 641      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 642      &                welec*gelc_long(j,i)+
 643      &                wbond*gradb(j,i)+
 644      &                wel_loc*gel_loc_long(j,i)+
 645      &                wcorr*gradcorr_long(j,i)+
 646      &                wcorr5*gradcorr5_long(j,i)+
 647      &                wcorr6*gradcorr6_long(j,i)+
 648      &                wturn6*gcorr6_turn_long(j,i)+
 649      &                wstrain*ghpbc(j,i)+
 650      &                wdfa_dist*gdfad(j,i)+
 651      &                wdfa_tor*gdfat(j,i)+
 652      &                wdfa_nei*gdfan(j,i)+
 653      &                wdfa_beta*gdfab(j,i)
 654         enddo
 655       enddo
 656 #endif
 657 #ifdef MPI
 658       if (nfgtasks.gt.1) then
 659       time00=MPI_Wtime()
 660 #ifdef DEBUG
 661       write (iout,*) "gradbufc before allreduce"
 662       do i=1,nres
 663         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 664       enddo
 665       call flush(iout)
 666 #endif
 667       do i=1,nres
 668         do j=1,3
 669           gradbufc_sum(j,i)=gradbufc(j,i)
 670         enddo
 671       enddo
 672 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 673 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 674 c      time_reduce=time_reduce+MPI_Wtime()-time00
 675 #ifdef DEBUG
 676 c      write (iout,*) "gradbufc_sum after allreduce"
 677 c      do i=1,nres
 678 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 679 c      enddo
 680 c      call flush(iout)
 681 #endif
 682 #ifdef TIMING
 683 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 684 #endif
 685       do i=nnt,nres
 686         do k=1,3
 687           gradbufc(k,i)=0.0d0
 688         enddo
 689       enddo
 690 #ifdef DEBUG
 691       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 692       write (iout,*) (i," jgrad_start",jgrad_start(i),
 693      &                  " jgrad_end  ",jgrad_end(i),
 694      &                  i=igrad_start,igrad_end)
 695 #endif
 696 c
 697 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 698 c do not parallelize this part.
 699 c
 700 c      do i=igrad_start,igrad_end
 701 c        do j=jgrad_start(i),jgrad_end(i)
 702 c          do k=1,3
 703 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 704 c          enddo
 705 c        enddo
 706 c      enddo
 707       do j=1,3
 708         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 709       enddo
 710       do i=nres-2,nnt,-1
 711         do j=1,3
 712           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 713         enddo
 714       enddo
 715 #ifdef DEBUG
 716       write (iout,*) "gradbufc after summing"
 717       do i=1,nres
 718         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 719       enddo
 720       call flush(iout)
 721 #endif
 722       else
 723 #endif
 724 #ifdef DEBUG
 725       write (iout,*) "gradbufc"
 726       do i=1,nres
 727         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 728       enddo
 729       call flush(iout)
 730 #endif
 731       do i=1,nres
 732         do j=1,3
 733           gradbufc_sum(j,i)=gradbufc(j,i)
 734           gradbufc(j,i)=0.0d0
 735         enddo
 736       enddo
 737       do j=1,3
 738         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 739       enddo
 740       do i=nres-2,nnt,-1
 741         do j=1,3
 742           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 743         enddo
 744       enddo
 745 c      do i=nnt,nres-1
 746 c        do k=1,3
 747 c          gradbufc(k,i)=0.0d0
 748 c        enddo
 749 c        do j=i+1,nres
 750 c          do k=1,3
 751 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 752 c          enddo
 753 c        enddo
 754 c      enddo
 755 #ifdef DEBUG
 756       write (iout,*) "gradbufc after summing"
 757       do i=1,nres
 758         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 759       enddo
 760       call flush(iout)
 761 #endif
 762 #ifdef MPI
 763       endif
 764 #endif
 765       do k=1,3
 766         gradbufc(k,nres)=0.0d0
 767       enddo
 768       do i=1,nct
 769         do j=1,3
 770 #ifdef SPLITELE
 771           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 772      &                wel_loc*gel_loc(j,i)+
 773      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 774      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 775      &                wel_loc*gel_loc_long(j,i)+
 776      &                wcorr*gradcorr_long(j,i)+
 777      &                wcorr5*gradcorr5_long(j,i)+
 778      &                wcorr6*gradcorr6_long(j,i)+
 779      &                wturn6*gcorr6_turn_long(j,i))+
 780      &                wbond*gradb(j,i)+
 781      &                wcorr*gradcorr(j,i)+
 782      &                wturn3*gcorr3_turn(j,i)+
 783      &                wturn4*gcorr4_turn(j,i)+
 784      &                wcorr5*gradcorr5(j,i)+
 785      &                wcorr6*gradcorr6(j,i)+
 786      &                wturn6*gcorr6_turn(j,i)+
 787      &                wsccor*gsccorc(j,i)
 788      &               +wscloc*gscloc(j,i)
 789 #else
 790           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 791      &                wel_loc*gel_loc(j,i)+
 792      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 793      &                welec*gelc_long(j,i)+
 794      &                wel_loc*gel_loc_long(j,i)+
 795      &                wcorr*gcorr_long(j,i)+
 796      &                wcorr5*gradcorr5_long(j,i)+
 797      &                wcorr6*gradcorr6_long(j,i)+
 798      &                wturn6*gcorr6_turn_long(j,i))+
 799      &                wbond*gradb(j,i)+
 800      &                wcorr*gradcorr(j,i)+
 801      &                wturn3*gcorr3_turn(j,i)+
 802      &                wturn4*gcorr4_turn(j,i)+
 803      &                wcorr5*gradcorr5(j,i)+
 804      &                wcorr6*gradcorr6(j,i)+
 805      &                wturn6*gcorr6_turn(j,i)+
 806      &                wsccor*gsccorc(j,i)
 807      &               +wscloc*gscloc(j,i)
 808 #endif
 809 #ifdef TSCSC
 810           gradx(j,i,icg)=wsc*gvdwx(j,i)+wsc*wscT*gvdwxT(j,i)+
 811      &                  wscp*gradx_scp(j,i)+
 812      &                  wbond*gradbx(j,i)+
 813      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 814      &                  wsccor*gsccorx(j,i)
 815      &                 +wscloc*gsclocx(j,i)
 816 #else
 817           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 818      &                  wbond*gradbx(j,i)+
 819      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 820      &                  wsccor*gsccorx(j,i)
 821      &                 +wscloc*gsclocx(j,i)
 822 #endif
 823         enddo
 824       enddo
 825       if (constr_homology.gt.0.and.waga_homology(iset).ne.0d0) then
 826         do i=1,nct
 827           do j=1,3
 828             gradc(j,i,icg)=gradc(j,i,icg)+duscdiff(j,i)
 829             gradx(j,i,icg)=gradx(j,i,icg)+duscdiffx(j,i)
 830           enddo
 831         enddo
 832       endif
 833 #ifdef DEBUG
 834       write (iout,*) "gloc before adding corr"
 835       do i=1,4*nres
 836         write (iout,*) i,gloc(i,icg)
 837       enddo
 838 #endif
 839       do i=1,nres-3
 840         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 841      &   +wcorr5*g_corr5_loc(i)
 842      &   +wcorr6*g_corr6_loc(i)
 843      &   +wturn4*gel_loc_turn4(i)
 844      &   +wturn3*gel_loc_turn3(i)
 845      &   +wturn6*gel_loc_turn6(i)
 846      &   +wel_loc*gel_loc_loc(i)
 847       enddo
 848 #ifdef DEBUG
 849       write (iout,*) "gloc after adding corr"
 850       do i=1,4*nres
 851         write (iout,*) i,gloc(i,icg)
 852       enddo
 853 #endif
 854 #ifdef MPI
 855       if (nfgtasks.gt.1) then
 856         do j=1,3
 857           do i=1,nres
 858             gradbufc(j,i)=gradc(j,i,icg)
 859             gradbufx(j,i)=gradx(j,i,icg)
 860           enddo
 861         enddo
 862         do i=1,4*nres
 863           glocbuf(i)=gloc(i,icg)
 864         enddo
 865 #ifdef DEBUG
 866       write (iout,*) "gloc_sc before reduce"
 867       do i=1,nres
 868        do j=1,3
 869         write (iout,*) i,j,gloc_sc(j,i,icg)
 870        enddo
 871       enddo
 872 #endif
 873         do i=1,nres
 874          do j=1,3
 875           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 876          enddo
 877         enddo
 878         time00=MPI_Wtime()
 879         call MPI_Barrier(FG_COMM,IERR)
 880         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 881         time00=MPI_Wtime()
 882         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 883      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 884         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 885      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 886         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 887      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 888         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 889      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 890         time_reduce=time_reduce+MPI_Wtime()-time00
 891 #ifdef DEBUG
 892       write (iout,*) "gloc_sc after reduce"
 893       do i=1,nres
 894        do j=1,3
 895         write (iout,*) i,j,gloc_sc(j,i,icg)
 896        enddo
 897       enddo
 898 #endif
 899 #ifdef DEBUG
 900       write (iout,*) "gloc after reduce"
 901       do i=1,4*nres
 902         write (iout,*) i,gloc(i,icg)
 903       enddo
 904 #endif
 905       endif
 906 #endif
 907       if (gnorm_check) then
 908 c
 909 c Compute the maximum elements of the gradient
 910 c
 911       gvdwc_max=0.0d0
 912       gvdwc_scp_max=0.0d0
 913       gelc_max=0.0d0
 914       gvdwpp_max=0.0d0
 915       gradb_max=0.0d0
 916       ghpbc_max=0.0d0
 917       gradcorr_max=0.0d0
 918       gel_loc_max=0.0d0
 919       gcorr3_turn_max=0.0d0
 920       gcorr4_turn_max=0.0d0
 921       gradcorr5_max=0.0d0
 922       gradcorr6_max=0.0d0
 923       gcorr6_turn_max=0.0d0
 924       gsccorc_max=0.0d0
 925       gscloc_max=0.0d0
 926       gvdwx_max=0.0d0
 927       gradx_scp_max=0.0d0
 928       ghpbx_max=0.0d0
 929       gradxorr_max=0.0d0
 930       gsccorx_max=0.0d0
 931       gsclocx_max=0.0d0
 932       do i=1,nct
 933         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 934         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 935 #ifdef TSCSC
 936         gvdwc_norm=dsqrt(scalar(gvdwcT(1,i),gvdwcT(1,i)))
 937         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 938 #endif
 939         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 940         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 941      &   gvdwc_scp_max=gvdwc_scp_norm
 942         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 943         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 944         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 945         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 946         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 947         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 948         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 949         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 950         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 951         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 952         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 953         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 954         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 955      &    gcorr3_turn(1,i)))
 956         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 957      &    gcorr3_turn_max=gcorr3_turn_norm
 958         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 959      &    gcorr4_turn(1,i)))
 960         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 961      &    gcorr4_turn_max=gcorr4_turn_norm
 962         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 963         if (gradcorr5_norm.gt.gradcorr5_max)
 964      &    gradcorr5_max=gradcorr5_norm
 965         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 966         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 967         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 968      &    gcorr6_turn(1,i)))
 969         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 970      &    gcorr6_turn_max=gcorr6_turn_norm
 971         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 972         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 973         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 974         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 975         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 976         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 977 #ifdef TSCSC
 978         gvdwx_norm=dsqrt(scalar(gvdwxT(1,i),gvdwxT(1,i)))
 979         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 980 #endif
 981         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 982         if (gradx_scp_norm.gt.gradx_scp_max)
 983      &    gradx_scp_max=gradx_scp_norm
 984         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 985         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 986         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 987         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 988         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 989         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 990         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 991         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 992       enddo
 993       if (gradout) then
 994 #ifdef AIX
 995         open(istat,file=statname,position="append")
 996 #else
 997         open(istat,file=statname,access="append")
 998 #endif
 999         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
1000      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
1001      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
1002      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
1003      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
1004      &     gsccorx_max,gsclocx_max
1005         close(istat)
1006         if (gvdwc_max.gt.1.0d4) then
1007           write (iout,*) "gvdwc gvdwx gradb gradbx"
1008           do i=nnt,nct
1009             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
1010      &        gradb(j,i),gradbx(j,i),j=1,3)
1011           enddo
1012           call pdbout(0.0d0,'cipiszcze',iout)
1013           call flush(iout)
1014         endif
1015       endif
1016       endif
1017 #ifdef DEBUG
1018       write (iout,*) "gradc gradx gloc"
1019       do i=1,nres
1020         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
1021      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
1022       enddo
1023 #endif
1024 #ifdef TIMING
1025 #ifdef MPI
1026       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
1027 #else
1028       time_sumgradient=time_sumgradient+tcpu()-time01
1029 #endif
1030 #endif
1031       return
1032       end
1033 c-------------------------------------------------------------------------------
1034       subroutine rescale_weights(t_bath)
1035       implicit real*8 (a-h,o-z)
1036       include 'DIMENSIONS'
1037       include 'COMMON.IOUNITS'
1038       include 'COMMON.FFIELD'
1039       include 'COMMON.SBRIDGE'
1040       double precision kfac /2.4d0/
1041       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
1042 c      facT=temp0/t_bath
1043 c      facT=2*temp0/(t_bath+temp0)
1044       if (rescale_mode.eq.0) then
1045         facT=1.0d0
1046         facT2=1.0d0
1047         facT3=1.0d0
1048         facT4=1.0d0
1049         facT5=1.0d0
1050       else if (rescale_mode.eq.1) then
1051         facT=kfac/(kfac-1.0d0+t_bath/temp0)
1052         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1053         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1054         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1055         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1056       else if (rescale_mode.eq.2) then
1057         x=t_bath/temp0
1058         x2=x*x
1059         x3=x2*x
1060         x4=x3*x
1061         x5=x4*x
1062         facT=licznik/dlog(dexp(x)+dexp(-x))
1063         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
1064         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
1065         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
1066         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
1067       else
1068         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1069         write (*,*) "Wrong RESCALE_MODE",rescale_mode
1070 #ifdef MPI
1071        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1072 #endif
1073        stop 555
1074       endif
1075       welec=weights(3)*fact
1076       wcorr=weights(4)*fact3
1077       wcorr5=weights(5)*fact4
1078       wcorr6=weights(6)*fact5
1079       wel_loc=weights(7)*fact2
1080       wturn3=weights(8)*fact2
1081       wturn4=weights(9)*fact3
1082       wturn6=weights(10)*fact5
1083       wtor=weights(13)*fact
1084       wtor_d=weights(14)*fact2
1085       wsccor=weights(21)*fact
1086 #ifdef TSCSC
1087 c      wsct=t_bath/temp0
1088       wsct=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
1089 #endif
1090       return
1091       end
1092 C------------------------------------------------------------------------
1093       subroutine enerprint(energia)
1094       implicit real*8 (a-h,o-z)
1095       include 'DIMENSIONS'
1096       include 'COMMON.IOUNITS'
1097       include 'COMMON.FFIELD'
1098       include 'COMMON.SBRIDGE'
1099       include 'COMMON.MD'
1100       double precision energia(0:n_ene)
1101       etot=energia(0)
1102 #ifdef TSCSC
1103       evdw=energia(22)+wsct*energia(23)
1104 #else
1105       evdw=energia(1)
1106 #endif
1107       evdw2=energia(2)
1108 #ifdef SCP14
1109       evdw2=energia(2)+energia(18)
1110 #else
1111       evdw2=energia(2)
1112 #endif
1113       ees=energia(3)
1114 #ifdef SPLITELE
1115       evdw1=energia(16)
1116 #endif
1117       ecorr=energia(4)
1118       ecorr5=energia(5)
1119       ecorr6=energia(6)
1120       eel_loc=energia(7)
1121       eello_turn3=energia(8)
1122       eello_turn4=energia(9)
1123       eello_turn6=energia(10)
1124       ebe=energia(11)
1125       escloc=energia(12)
1126       etors=energia(13)
1127       etors_d=energia(14)
1128       ehpb=energia(15)
1129       edihcnstr=energia(19)
1130       estr=energia(17)
1131       Uconst=energia(20)
1132       esccor=energia(21)
1133       ehomology_constr=energia(24)
1134 C     Bartek
1135       edfadis = energia(25)
1136       edfator = energia(26)
1137       edfanei = energia(27)
1138       edfabet = energia(28)
1139
1140 #ifdef SPLITELE
1141       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1142      &  estr,wbond,ebe,wang,
1143      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1144      &  ecorr,wcorr,
1145      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1146      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
1147      &  edihcnstr,ehomology_constr, ebr*nss,
1148      &  Uconst,edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
1149      &  edfabet,wdfa_beta,etot
1150    10 format (/'Virtual-chain energies:'//
1151      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
1152      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
1153      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
1154      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pE16.6,' (p-p VDW)'/
1155      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
1156      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
1157      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
1158      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
1159      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
1160      & 'EHPB=  ',1pE16.6,' WEIGHT=',1pE16.6,
1161      & ' (SS bridges & dist. cnstr.)'/
1162      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1163      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1164      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1165      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
1166      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
1167      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
1168      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
1169      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
1170      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1171      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1172      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1173      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1174      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
1175      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
1176      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
1177      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
1178      & 'ETOT=  ',1pE16.6,' (total)')
1179 #else
1180       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1181      &  estr,wbond,ebe,wang,
1182      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1183      &  ecorr,wcorr,
1184      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1185      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1186      &  ehomology_constr,ebr*nss,Uconst,edfadis,wdfa_dist,edfator,
1187      &  wdfa_tor,edfanei,wdfa_nei,edfabet,wdfa_beta,
1188      &  etot
1189    10 format (/'Virtual-chain energies:'//
1190      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1191      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1192      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1193      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1194      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1195      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1196      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1197      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1198      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1199      & ' (SS bridges & dist. cnstr.)'/
1200      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1201      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1202      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1203      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1204      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1205      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1206      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1207      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1208      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1209      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1210      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1211      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1212      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA distance energy)'/
1213      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA torsion energy)'/
1214      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA NCa energy)'/
1215      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA Beta energy)'/
1216      & 'ETOT=  ',1pE16.6,' (total)')
1217 #endif
1218       return
1219       end
1220 C-----------------------------------------------------------------------
1221       subroutine elj(evdw,evdw_p,evdw_m)
1222 C
1223 C This subroutine calculates the interaction energy of nonbonded side chains
1224 C assuming the LJ potential of interaction.
1225 C
1226       implicit real*8 (a-h,o-z)
1227       include 'DIMENSIONS'
1228       parameter (accur=1.0d-10)
1229       include 'COMMON.GEO'
1230       include 'COMMON.VAR'
1231       include 'COMMON.LOCAL'
1232       include 'COMMON.CHAIN'
1233       include 'COMMON.DERIV'
1234       include 'COMMON.INTERACT'
1235       include 'COMMON.TORSION'
1236       include 'COMMON.SBRIDGE'
1237       include 'COMMON.NAMES'
1238       include 'COMMON.IOUNITS'
1239       include 'COMMON.CONTACTS'
1240       dimension gg(3)
1241 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1242       evdw=0.0D0
1243       do i=iatsc_s,iatsc_e
1244         itypi=itype(i)
1245         itypi1=itype(i+1)
1246         xi=c(1,nres+i)
1247         yi=c(2,nres+i)
1248         zi=c(3,nres+i)
1249 C Change 12/1/95
1250         num_conti=0
1251 C
1252 C Calculate SC interaction energy.
1253 C
1254         do iint=1,nint_gr(i)
1255 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1256 cd   &                  'iend=',iend(i,iint)
1257           do j=istart(i,iint),iend(i,iint)
1258             itypj=itype(j)
1259             xj=c(1,nres+j)-xi
1260             yj=c(2,nres+j)-yi
1261             zj=c(3,nres+j)-zi
1262 C Change 12/1/95 to calculate four-body interactions
1263             rij=xj*xj+yj*yj+zj*zj
1264             rrij=1.0D0/rij
1265 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1266             eps0ij=eps(itypi,itypj)
1267             fac=rrij**expon2
1268             e1=fac*fac*aa(itypi,itypj)
1269             e2=fac*bb(itypi,itypj)
1270             evdwij=e1+e2
1271 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1272 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1273 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1274 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1275 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1276 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1277 #ifdef TSCSC
1278             if (bb(itypi,itypj).gt.0) then
1279                evdw_p=evdw_p+evdwij
1280             else
1281                evdw_m=evdw_m+evdwij
1282             endif
1283 #else
1284             evdw=evdw+evdwij
1285 #endif
1286 C
1287 C Calculate the components of the gradient in DC and X
1288 C
1289             fac=-rrij*(e1+evdwij)
1290             gg(1)=xj*fac
1291             gg(2)=yj*fac
1292             gg(3)=zj*fac
1293 #ifdef TSCSC
1294             if (bb(itypi,itypj).gt.0.0d0) then
1295               do k=1,3
1296                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1297                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1298                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1299                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1300               enddo
1301             else
1302               do k=1,3
1303                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1304                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1305                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1306                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1307               enddo
1308             endif
1309 #else
1310             do k=1,3
1311               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1312               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1313               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1314               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1315             enddo
1316 #endif
1317 cgrad            do k=i,j-1
1318 cgrad              do l=1,3
1319 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1320 cgrad              enddo
1321 cgrad            enddo
1322 C
1323 C 12/1/95, revised on 5/20/97
1324 C
1325 C Calculate the contact function. The ith column of the array JCONT will
1326 C contain the numbers of atoms that make contacts with the atom I (of numbers
1327 C greater than I). The arrays FACONT and GACONT will contain the values of
1328 C the contact function and its derivative.
1329 C
1330 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1331 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1332 C Uncomment next line, if the correlation interactions are contact function only
1333             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1334               rij=dsqrt(rij)
1335               sigij=sigma(itypi,itypj)
1336               r0ij=rs0(itypi,itypj)
1337 C
1338 C Check whether the SC's are not too far to make a contact.
1339 C
1340               rcut=1.5d0*r0ij
1341               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1342 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1343 C
1344               if (fcont.gt.0.0D0) then
1345 C If the SC-SC distance if close to sigma, apply spline.
1346 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1347 cAdam &             fcont1,fprimcont1)
1348 cAdam           fcont1=1.0d0-fcont1
1349 cAdam           if (fcont1.gt.0.0d0) then
1350 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1351 cAdam             fcont=fcont*fcont1
1352 cAdam           endif
1353 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1354 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1355 cga             do k=1,3
1356 cga               gg(k)=gg(k)*eps0ij
1357 cga             enddo
1358 cga             eps0ij=-evdwij*eps0ij
1359 C Uncomment for AL's type of SC correlation interactions.
1360 cadam           eps0ij=-evdwij
1361                 num_conti=num_conti+1
1362                 jcont(num_conti,i)=j
1363                 facont(num_conti,i)=fcont*eps0ij
1364                 fprimcont=eps0ij*fprimcont/rij
1365                 fcont=expon*fcont
1366 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1367 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1368 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1369 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1370                 gacont(1,num_conti,i)=-fprimcont*xj
1371                 gacont(2,num_conti,i)=-fprimcont*yj
1372                 gacont(3,num_conti,i)=-fprimcont*zj
1373 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1374 cd              write (iout,'(2i3,3f10.5)')
1375 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1376               endif
1377             endif
1378           enddo      ! j
1379         enddo        ! iint
1380 C Change 12/1/95
1381         num_cont(i)=num_conti
1382       enddo          ! i
1383       do i=1,nct
1384         do j=1,3
1385           gvdwc(j,i)=expon*gvdwc(j,i)
1386           gvdwx(j,i)=expon*gvdwx(j,i)
1387         enddo
1388       enddo
1389 C******************************************************************************
1390 C
1391 C                              N O T E !!!
1392 C
1393 C To save time, the factor of EXPON has been extracted from ALL components
1394 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1395 C use!
1396 C
1397 C******************************************************************************
1398       return
1399       end
1400 C-----------------------------------------------------------------------------
1401       subroutine eljk(evdw,evdw_p,evdw_m)
1402 C
1403 C This subroutine calculates the interaction energy of nonbonded side chains
1404 C assuming the LJK potential of interaction.
1405 C
1406       implicit real*8 (a-h,o-z)
1407       include 'DIMENSIONS'
1408       include 'COMMON.GEO'
1409       include 'COMMON.VAR'
1410       include 'COMMON.LOCAL'
1411       include 'COMMON.CHAIN'
1412       include 'COMMON.DERIV'
1413       include 'COMMON.INTERACT'
1414       include 'COMMON.IOUNITS'
1415       include 'COMMON.NAMES'
1416       dimension gg(3)
1417       logical scheck
1418 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1419       evdw=0.0D0
1420       do i=iatsc_s,iatsc_e
1421         itypi=itype(i)
1422         itypi1=itype(i+1)
1423         xi=c(1,nres+i)
1424         yi=c(2,nres+i)
1425         zi=c(3,nres+i)
1426 C
1427 C Calculate SC interaction energy.
1428 C
1429         do iint=1,nint_gr(i)
1430           do j=istart(i,iint),iend(i,iint)
1431             itypj=itype(j)
1432             xj=c(1,nres+j)-xi
1433             yj=c(2,nres+j)-yi
1434             zj=c(3,nres+j)-zi
1435             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1436             fac_augm=rrij**expon
1437             e_augm=augm(itypi,itypj)*fac_augm
1438             r_inv_ij=dsqrt(rrij)
1439             rij=1.0D0/r_inv_ij
1440             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1441             fac=r_shift_inv**expon
1442             e1=fac*fac*aa(itypi,itypj)
1443             e2=fac*bb(itypi,itypj)
1444             evdwij=e_augm+e1+e2
1445 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1446 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1447 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1448 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1449 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1450 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1451 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1452 #ifdef TSCSC
1453             if (bb(itypi,itypj).gt.0) then
1454                evdw_p=evdw_p+evdwij
1455             else
1456                evdw_m=evdw_m+evdwij
1457             endif
1458 #else
1459             evdw=evdw+evdwij
1460 #endif
1461 C
1462 C Calculate the components of the gradient in DC and X
1463 C
1464             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1465             gg(1)=xj*fac
1466             gg(2)=yj*fac
1467             gg(3)=zj*fac
1468 #ifdef TSCSC
1469             if (bb(itypi,itypj).gt.0.0d0) then
1470               do k=1,3
1471                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1472                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1473                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1474                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1475               enddo
1476             else
1477               do k=1,3
1478                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1479                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1480                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1481                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1482               enddo
1483             endif
1484 #else
1485             do k=1,3
1486               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1487               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1488               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1489               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1490             enddo
1491 #endif
1492 cgrad            do k=i,j-1
1493 cgrad              do l=1,3
1494 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1495 cgrad              enddo
1496 cgrad            enddo
1497           enddo      ! j
1498         enddo        ! iint
1499       enddo          ! i
1500       do i=1,nct
1501         do j=1,3
1502           gvdwc(j,i)=expon*gvdwc(j,i)
1503           gvdwx(j,i)=expon*gvdwx(j,i)
1504         enddo
1505       enddo
1506       return
1507       end
1508 C-----------------------------------------------------------------------------
1509       subroutine ebp(evdw,evdw_p,evdw_m)
1510 C
1511 C This subroutine calculates the interaction energy of nonbonded side chains
1512 C assuming the Berne-Pechukas potential of interaction.
1513 C
1514       implicit real*8 (a-h,o-z)
1515       include 'DIMENSIONS'
1516       include 'COMMON.GEO'
1517       include 'COMMON.VAR'
1518       include 'COMMON.LOCAL'
1519       include 'COMMON.CHAIN'
1520       include 'COMMON.DERIV'
1521       include 'COMMON.NAMES'
1522       include 'COMMON.INTERACT'
1523       include 'COMMON.IOUNITS'
1524       include 'COMMON.CALC'
1525       common /srutu/ icall
1526 c     double precision rrsave(maxdim)
1527       logical lprn
1528       evdw=0.0D0
1529 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1530       evdw=0.0D0
1531 c     if (icall.eq.0) then
1532 c       lprn=.true.
1533 c     else
1534         lprn=.false.
1535 c     endif
1536       ind=0
1537       do i=iatsc_s,iatsc_e
1538         itypi=itype(i)
1539         itypi1=itype(i+1)
1540         xi=c(1,nres+i)
1541         yi=c(2,nres+i)
1542         zi=c(3,nres+i)
1543         dxi=dc_norm(1,nres+i)
1544         dyi=dc_norm(2,nres+i)
1545         dzi=dc_norm(3,nres+i)
1546 c        dsci_inv=dsc_inv(itypi)
1547         dsci_inv=vbld_inv(i+nres)
1548 C
1549 C Calculate SC interaction energy.
1550 C
1551         do iint=1,nint_gr(i)
1552           do j=istart(i,iint),iend(i,iint)
1553             ind=ind+1
1554             itypj=itype(j)
1555 c            dscj_inv=dsc_inv(itypj)
1556             dscj_inv=vbld_inv(j+nres)
1557             chi1=chi(itypi,itypj)
1558             chi2=chi(itypj,itypi)
1559             chi12=chi1*chi2
1560             chip1=chip(itypi)
1561             chip2=chip(itypj)
1562             chip12=chip1*chip2
1563             alf1=alp(itypi)
1564             alf2=alp(itypj)
1565             alf12=0.5D0*(alf1+alf2)
1566 C For diagnostics only!!!
1567 c           chi1=0.0D0
1568 c           chi2=0.0D0
1569 c           chi12=0.0D0
1570 c           chip1=0.0D0
1571 c           chip2=0.0D0
1572 c           chip12=0.0D0
1573 c           alf1=0.0D0
1574 c           alf2=0.0D0
1575 c           alf12=0.0D0
1576             xj=c(1,nres+j)-xi
1577             yj=c(2,nres+j)-yi
1578             zj=c(3,nres+j)-zi
1579             dxj=dc_norm(1,nres+j)
1580             dyj=dc_norm(2,nres+j)
1581             dzj=dc_norm(3,nres+j)
1582             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1583 cd          if (icall.eq.0) then
1584 cd            rrsave(ind)=rrij
1585 cd          else
1586 cd            rrij=rrsave(ind)
1587 cd          endif
1588             rij=dsqrt(rrij)
1589 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1590             call sc_angular
1591 C Calculate whole angle-dependent part of epsilon and contributions
1592 C to its derivatives
1593             fac=(rrij*sigsq)**expon2
1594             e1=fac*fac*aa(itypi,itypj)
1595             e2=fac*bb(itypi,itypj)
1596             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1597             eps2der=evdwij*eps3rt
1598             eps3der=evdwij*eps2rt
1599             evdwij=evdwij*eps2rt*eps3rt
1600 #ifdef TSCSC
1601             if (bb(itypi,itypj).gt.0) then
1602                evdw_p=evdw_p+evdwij
1603             else
1604                evdw_m=evdw_m+evdwij
1605             endif
1606 #else
1607             evdw=evdw+evdwij
1608 #endif
1609             if (lprn) then
1610             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1611             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1612 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1613 cd     &        restyp(itypi),i,restyp(itypj),j,
1614 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1615 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1616 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1617 cd     &        evdwij
1618             endif
1619 C Calculate gradient components.
1620             e1=e1*eps1*eps2rt**2*eps3rt**2
1621             fac=-expon*(e1+evdwij)
1622             sigder=fac/sigsq
1623             fac=rrij*fac
1624 C Calculate radial part of the gradient
1625             gg(1)=xj*fac
1626             gg(2)=yj*fac
1627             gg(3)=zj*fac
1628 C Calculate the angular part of the gradient and sum add the contributions
1629 C to the appropriate components of the Cartesian gradient.
1630 #ifdef TSCSC
1631             if (bb(itypi,itypj).gt.0) then
1632                call sc_grad
1633             else
1634                call sc_grad_T
1635             endif
1636 #else
1637             call sc_grad
1638 #endif
1639           enddo      ! j
1640         enddo        ! iint
1641       enddo          ! i
1642 c     stop
1643       return
1644       end
1645 C-----------------------------------------------------------------------------
1646       subroutine egb(evdw,evdw_p,evdw_m)
1647 C
1648 C This subroutine calculates the interaction energy of nonbonded side chains
1649 C assuming the Gay-Berne potential of interaction.
1650 C
1651       implicit real*8 (a-h,o-z)
1652       include 'DIMENSIONS'
1653       include 'COMMON.GEO'
1654       include 'COMMON.VAR'
1655       include 'COMMON.LOCAL'
1656       include 'COMMON.CHAIN'
1657       include 'COMMON.DERIV'
1658       include 'COMMON.NAMES'
1659       include 'COMMON.INTERACT'
1660       include 'COMMON.IOUNITS'
1661       include 'COMMON.CALC'
1662       include 'COMMON.CONTROL'
1663       include 'COMMON.SBRIDGE'
1664       logical lprn
1665       evdw=0.0D0
1666 ccccc      energy_dec=.false.
1667 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1668       evdw=0.0D0
1669       evdw_p=0.0D0
1670       evdw_m=0.0D0
1671       lprn=.false.
1672 c     if (icall.eq.0) lprn=.false.
1673       ind=0
1674       do i=iatsc_s,iatsc_e
1675         itypi=itype(i)
1676         itypi1=itype(i+1)
1677         xi=c(1,nres+i)
1678         yi=c(2,nres+i)
1679         zi=c(3,nres+i)
1680         dxi=dc_norm(1,nres+i)
1681         dyi=dc_norm(2,nres+i)
1682         dzi=dc_norm(3,nres+i)
1683 c        dsci_inv=dsc_inv(itypi)
1684         dsci_inv=vbld_inv(i+nres)
1685 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1686 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1687 C
1688 C Calculate SC interaction energy.
1689 C
1690         do iint=1,nint_gr(i)
1691           do j=istart(i,iint),iend(i,iint)
1692             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1693               call dyn_ssbond_ene(i,j,evdwij)
1694               evdw=evdw+evdwij
1695               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1696      &                        'evdw',i,j,evdwij,' ss'
1697             ELSE
1698             ind=ind+1
1699             itypj=itype(j)
1700 c            dscj_inv=dsc_inv(itypj)
1701             dscj_inv=vbld_inv(j+nres)
1702 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1703 c     &       1.0d0/vbld(j+nres)
1704 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1705             sig0ij=sigma(itypi,itypj)
1706             chi1=chi(itypi,itypj)
1707             chi2=chi(itypj,itypi)
1708             chi12=chi1*chi2
1709             chip1=chip(itypi)
1710             chip2=chip(itypj)
1711             chip12=chip1*chip2
1712             alf1=alp(itypi)
1713             alf2=alp(itypj)
1714             alf12=0.5D0*(alf1+alf2)
1715 C For diagnostics only!!!
1716 c           chi1=0.0D0
1717 c           chi2=0.0D0
1718 c           chi12=0.0D0
1719 c           chip1=0.0D0
1720 c           chip2=0.0D0
1721 c           chip12=0.0D0
1722 c           alf1=0.0D0
1723 c           alf2=0.0D0
1724 c           alf12=0.0D0
1725             xj=c(1,nres+j)-xi
1726             yj=c(2,nres+j)-yi
1727             zj=c(3,nres+j)-zi
1728             dxj=dc_norm(1,nres+j)
1729             dyj=dc_norm(2,nres+j)
1730             dzj=dc_norm(3,nres+j)
1731 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1732 c            write (iout,*) "j",j," dc_norm",
1733 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1734             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1735             rij=dsqrt(rrij)
1736 C Calculate angle-dependent terms of energy and contributions to their
1737 C derivatives.
1738             call sc_angular
1739             sigsq=1.0D0/sigsq
1740             sig=sig0ij*dsqrt(sigsq)
1741             rij_shift=1.0D0/rij-sig+sig0ij
1742 c for diagnostics; uncomment
1743 c            rij_shift=1.2*sig0ij
1744 C I hate to put IF's in the loops, but here don't have another choice!!!!
1745             if (rij_shift.le.0.0D0) then
1746               evdw=1.0D20
1747 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1748 cd     &        restyp(itypi),i,restyp(itypj),j,
1749 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1750               return
1751             endif
1752             sigder=-sig*sigsq
1753 c---------------------------------------------------------------
1754             rij_shift=1.0D0/rij_shift
1755             fac=rij_shift**expon
1756             e1=fac*fac*aa(itypi,itypj)
1757             e2=fac*bb(itypi,itypj)
1758             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1759             eps2der=evdwij*eps3rt
1760             eps3der=evdwij*eps2rt
1761 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1762 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1763             evdwij=evdwij*eps2rt*eps3rt
1764 #ifdef TSCSC
1765             if (bb(itypi,itypj).gt.0) then
1766                evdw_p=evdw_p+evdwij
1767             else
1768                evdw_m=evdw_m+evdwij
1769             endif
1770 #else
1771             evdw=evdw+evdwij
1772 #endif
1773             if (lprn) then
1774             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1775             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1776             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1777      &        restyp(itypi),i,restyp(itypj),j,
1778      &        epsi,sigm,chi1,chi2,chip1,chip2,
1779      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1780      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1781      &        evdwij
1782             endif
1783
1784             if (energy_dec) then
1785               write (iout,'(a6,2i5,0pf7.3)') 'evdw',i,j,evdwij
1786               call flush(iout)
1787             endif
1788 C Calculate gradient components.
1789             e1=e1*eps1*eps2rt**2*eps3rt**2
1790             fac=-expon*(e1+evdwij)*rij_shift
1791             sigder=fac*sigder
1792             fac=rij*fac
1793 c            fac=0.0d0
1794 C Calculate the radial part of the gradient
1795             gg(1)=xj*fac
1796             gg(2)=yj*fac
1797             gg(3)=zj*fac
1798 C Calculate angular part of the gradient.
1799 #ifdef TSCSC
1800             if (bb(itypi,itypj).gt.0) then
1801                call sc_grad
1802             else
1803                call sc_grad_T
1804             endif
1805 #else
1806             call sc_grad
1807 #endif
1808             ENDIF    ! dyn_ss
1809           enddo      ! j
1810         enddo        ! iint
1811       enddo          ! i
1812 c      write (iout,*) "Number of loop steps in EGB:",ind
1813 cccc      energy_dec=.false.
1814       return
1815       end
1816 C-----------------------------------------------------------------------------
1817       subroutine egbv(evdw,evdw_p,evdw_m)
1818 C
1819 C This subroutine calculates the interaction energy of nonbonded side chains
1820 C assuming the Gay-Berne-Vorobjev potential of interaction.
1821 C
1822       implicit real*8 (a-h,o-z)
1823       include 'DIMENSIONS'
1824       include 'COMMON.GEO'
1825       include 'COMMON.VAR'
1826       include 'COMMON.LOCAL'
1827       include 'COMMON.CHAIN'
1828       include 'COMMON.DERIV'
1829       include 'COMMON.NAMES'
1830       include 'COMMON.INTERACT'
1831       include 'COMMON.IOUNITS'
1832       include 'COMMON.CALC'
1833       common /srutu/ icall
1834       logical lprn
1835       evdw=0.0D0
1836 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1837       evdw=0.0D0
1838       lprn=.false.
1839 c     if (icall.eq.0) lprn=.true.
1840       ind=0
1841       do i=iatsc_s,iatsc_e
1842         itypi=itype(i)
1843         itypi1=itype(i+1)
1844         xi=c(1,nres+i)
1845         yi=c(2,nres+i)
1846         zi=c(3,nres+i)
1847         dxi=dc_norm(1,nres+i)
1848         dyi=dc_norm(2,nres+i)
1849         dzi=dc_norm(3,nres+i)
1850 c        dsci_inv=dsc_inv(itypi)
1851         dsci_inv=vbld_inv(i+nres)
1852 C
1853 C Calculate SC interaction energy.
1854 C
1855         do iint=1,nint_gr(i)
1856           do j=istart(i,iint),iend(i,iint)
1857             ind=ind+1
1858             itypj=itype(j)
1859 c            dscj_inv=dsc_inv(itypj)
1860             dscj_inv=vbld_inv(j+nres)
1861             sig0ij=sigma(itypi,itypj)
1862             r0ij=r0(itypi,itypj)
1863             chi1=chi(itypi,itypj)
1864             chi2=chi(itypj,itypi)
1865             chi12=chi1*chi2
1866             chip1=chip(itypi)
1867             chip2=chip(itypj)
1868             chip12=chip1*chip2
1869             alf1=alp(itypi)
1870             alf2=alp(itypj)
1871             alf12=0.5D0*(alf1+alf2)
1872 C For diagnostics only!!!
1873 c           chi1=0.0D0
1874 c           chi2=0.0D0
1875 c           chi12=0.0D0
1876 c           chip1=0.0D0
1877 c           chip2=0.0D0
1878 c           chip12=0.0D0
1879 c           alf1=0.0D0
1880 c           alf2=0.0D0
1881 c           alf12=0.0D0
1882             xj=c(1,nres+j)-xi
1883             yj=c(2,nres+j)-yi
1884             zj=c(3,nres+j)-zi
1885             dxj=dc_norm(1,nres+j)
1886             dyj=dc_norm(2,nres+j)
1887             dzj=dc_norm(3,nres+j)
1888             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1889             rij=dsqrt(rrij)
1890 C Calculate angle-dependent terms of energy and contributions to their
1891 C derivatives.
1892             call sc_angular
1893             sigsq=1.0D0/sigsq
1894             sig=sig0ij*dsqrt(sigsq)
1895             rij_shift=1.0D0/rij-sig+r0ij
1896 C I hate to put IF's in the loops, but here don't have another choice!!!!
1897             if (rij_shift.le.0.0D0) then
1898               evdw=1.0D20
1899               return
1900             endif
1901             sigder=-sig*sigsq
1902 c---------------------------------------------------------------
1903             rij_shift=1.0D0/rij_shift
1904             fac=rij_shift**expon
1905             e1=fac*fac*aa(itypi,itypj)
1906             e2=fac*bb(itypi,itypj)
1907             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1908             eps2der=evdwij*eps3rt
1909             eps3der=evdwij*eps2rt
1910             fac_augm=rrij**expon
1911             e_augm=augm(itypi,itypj)*fac_augm
1912             evdwij=evdwij*eps2rt*eps3rt
1913 #ifdef TSCSC
1914             if (bb(itypi,itypj).gt.0) then
1915                evdw_p=evdw_p+evdwij+e_augm
1916             else
1917                evdw_m=evdw_m+evdwij+e_augm
1918             endif
1919 #else
1920             evdw=evdw+evdwij+e_augm
1921 #endif
1922             if (lprn) then
1923             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1924             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1925             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1926      &        restyp(itypi),i,restyp(itypj),j,
1927      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1928      &        chi1,chi2,chip1,chip2,
1929      &        eps1,eps2rt**2,eps3rt**2,
1930      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1931      &        evdwij+e_augm
1932             endif
1933 C Calculate gradient components.
1934             e1=e1*eps1*eps2rt**2*eps3rt**2
1935             fac=-expon*(e1+evdwij)*rij_shift
1936             sigder=fac*sigder
1937             fac=rij*fac-2*expon*rrij*e_augm
1938 C Calculate the radial part of the gradient
1939             gg(1)=xj*fac
1940             gg(2)=yj*fac
1941             gg(3)=zj*fac
1942 C Calculate angular part of the gradient.
1943 #ifdef TSCSC
1944             if (bb(itypi,itypj).gt.0) then
1945                call sc_grad
1946             else
1947                call sc_grad_T
1948             endif
1949 #else
1950             call sc_grad
1951 #endif
1952           enddo      ! j
1953         enddo        ! iint
1954       enddo          ! i
1955       end
1956 C-----------------------------------------------------------------------------
1957       subroutine sc_angular
1958 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1959 C om12. Called by ebp, egb, and egbv.
1960       implicit none
1961       include 'COMMON.CALC'
1962       include 'COMMON.IOUNITS'
1963       erij(1)=xj*rij
1964       erij(2)=yj*rij
1965       erij(3)=zj*rij
1966       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1967       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1968       om12=dxi*dxj+dyi*dyj+dzi*dzj
1969       chiom12=chi12*om12
1970 C Calculate eps1(om12) and its derivative in om12
1971       faceps1=1.0D0-om12*chiom12
1972       faceps1_inv=1.0D0/faceps1
1973       eps1=dsqrt(faceps1_inv)
1974 C Following variable is eps1*deps1/dom12
1975       eps1_om12=faceps1_inv*chiom12
1976 c diagnostics only
1977 c      faceps1_inv=om12
1978 c      eps1=om12
1979 c      eps1_om12=1.0d0
1980 c      write (iout,*) "om12",om12," eps1",eps1
1981 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1982 C and om12.
1983       om1om2=om1*om2
1984       chiom1=chi1*om1
1985       chiom2=chi2*om2
1986       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1987       sigsq=1.0D0-facsig*faceps1_inv
1988       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1989       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1990       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1991 c diagnostics only
1992 c      sigsq=1.0d0
1993 c      sigsq_om1=0.0d0
1994 c      sigsq_om2=0.0d0
1995 c      sigsq_om12=0.0d0
1996 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1997 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1998 c     &    " eps1",eps1
1999 C Calculate eps2 and its derivatives in om1, om2, and om12.
2000       chipom1=chip1*om1
2001       chipom2=chip2*om2
2002       chipom12=chip12*om12
2003       facp=1.0D0-om12*chipom12
2004       facp_inv=1.0D0/facp
2005       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2006 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2007 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2008 C Following variable is the square root of eps2
2009       eps2rt=1.0D0-facp1*facp_inv
2010 C Following three variables are the derivatives of the square root of eps
2011 C in om1, om2, and om12.
2012       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2013       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2014       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2015 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2016       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2017 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2018 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2019 c     &  " eps2rt_om12",eps2rt_om12
2020 C Calculate whole angle-dependent part of epsilon and contributions
2021 C to its derivatives
2022       return
2023       end
2024
2025 C----------------------------------------------------------------------------
2026       subroutine sc_grad_T
2027       implicit real*8 (a-h,o-z)
2028       include 'DIMENSIONS'
2029       include 'COMMON.CHAIN'
2030       include 'COMMON.DERIV'
2031       include 'COMMON.CALC'
2032       include 'COMMON.IOUNITS'
2033       double precision dcosom1(3),dcosom2(3)
2034       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2035       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2036       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2037      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2038 c diagnostics only
2039 c      eom1=0.0d0
2040 c      eom2=0.0d0
2041 c      eom12=evdwij*eps1_om12
2042 c end diagnostics
2043 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2044 c     &  " sigder",sigder
2045 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2046 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2047       do k=1,3
2048         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2049         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2050       enddo
2051       do k=1,3
2052         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
2053       enddo
2054 c      write (iout,*) "gg",(gg(k),k=1,3)
2055       do k=1,3
2056         gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
2057      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2058      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2059         gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
2060      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2061      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2062 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2063 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2064 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2065 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2066       enddo
2067 C
2068 C Calculate the components of the gradient in DC and X
2069 C
2070 cgrad      do k=i,j-1
2071 cgrad        do l=1,3
2072 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2073 cgrad        enddo
2074 cgrad      enddo
2075       do l=1,3
2076         gvdwcT(l,i)=gvdwcT(l,i)-gg(l)
2077         gvdwcT(l,j)=gvdwcT(l,j)+gg(l)
2078       enddo
2079       return
2080       end
2081
2082 C----------------------------------------------------------------------------
2083       subroutine sc_grad
2084       implicit real*8 (a-h,o-z)
2085       include 'DIMENSIONS'
2086       include 'COMMON.CHAIN'
2087       include 'COMMON.DERIV'
2088       include 'COMMON.CALC'
2089       include 'COMMON.IOUNITS'
2090       double precision dcosom1(3),dcosom2(3)
2091       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2092       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2093       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2094      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2095 c diagnostics only
2096 c      eom1=0.0d0
2097 c      eom2=0.0d0
2098 c      eom12=evdwij*eps1_om12
2099 c end diagnostics
2100 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2101 c     &  " sigder",sigder
2102 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2103 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2104       do k=1,3
2105         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2106         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2107       enddo
2108       do k=1,3
2109         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
2110       enddo
2111 c      write (iout,*) "gg",(gg(k),k=1,3)
2112       do k=1,3
2113         gvdwx(k,i)=gvdwx(k,i)-gg(k)
2114      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2115      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2116         gvdwx(k,j)=gvdwx(k,j)+gg(k)
2117      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2118      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2119 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2120 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2121 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2122 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2123       enddo
2124 C
2125 C Calculate the components of the gradient in DC and X
2126 C
2127 cgrad      do k=i,j-1
2128 cgrad        do l=1,3
2129 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2130 cgrad        enddo
2131 cgrad      enddo
2132       do l=1,3
2133         gvdwc(l,i)=gvdwc(l,i)-gg(l)
2134         gvdwc(l,j)=gvdwc(l,j)+gg(l)
2135       enddo
2136       return
2137       end
2138 C-----------------------------------------------------------------------
2139       subroutine e_softsphere(evdw)
2140 C
2141 C This subroutine calculates the interaction energy of nonbonded side chains
2142 C assuming the LJ potential of interaction.
2143 C
2144       implicit real*8 (a-h,o-z)
2145       include 'DIMENSIONS'
2146       parameter (accur=1.0d-10)
2147       include 'COMMON.GEO'
2148       include 'COMMON.VAR'
2149       include 'COMMON.LOCAL'
2150       include 'COMMON.CHAIN'
2151       include 'COMMON.DERIV'
2152       include 'COMMON.INTERACT'
2153       include 'COMMON.TORSION'
2154       include 'COMMON.SBRIDGE'
2155       include 'COMMON.NAMES'
2156       include 'COMMON.IOUNITS'
2157       include 'COMMON.CONTACTS'
2158       dimension gg(3)
2159 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2160       evdw=0.0D0
2161       do i=iatsc_s,iatsc_e
2162         itypi=itype(i)
2163         itypi1=itype(i+1)
2164         xi=c(1,nres+i)
2165         yi=c(2,nres+i)
2166         zi=c(3,nres+i)
2167 C
2168 C Calculate SC interaction energy.
2169 C
2170         do iint=1,nint_gr(i)
2171 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2172 cd   &                  'iend=',iend(i,iint)
2173           do j=istart(i,iint),iend(i,iint)
2174             itypj=itype(j)
2175             xj=c(1,nres+j)-xi
2176             yj=c(2,nres+j)-yi
2177             zj=c(3,nres+j)-zi
2178             rij=xj*xj+yj*yj+zj*zj
2179 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2180             r0ij=r0(itypi,itypj)
2181             r0ijsq=r0ij*r0ij
2182 c            print *,i,j,r0ij,dsqrt(rij)
2183             if (rij.lt.r0ijsq) then
2184               evdwij=0.25d0*(rij-r0ijsq)**2
2185               fac=rij-r0ijsq
2186             else
2187               evdwij=0.0d0
2188               fac=0.0d0
2189             endif
2190             evdw=evdw+evdwij
2191 C
2192 C Calculate the components of the gradient in DC and X
2193 C
2194             gg(1)=xj*fac
2195             gg(2)=yj*fac
2196             gg(3)=zj*fac
2197             do k=1,3
2198               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2199               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2200               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2201               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2202             enddo
2203 cgrad            do k=i,j-1
2204 cgrad              do l=1,3
2205 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2206 cgrad              enddo
2207 cgrad            enddo
2208           enddo ! j
2209         enddo ! iint
2210       enddo ! i
2211       return
2212       end
2213 C--------------------------------------------------------------------------
2214       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2215      &              eello_turn4)
2216 C
2217 C Soft-sphere potential of p-p interaction
2218 C
2219       implicit real*8 (a-h,o-z)
2220       include 'DIMENSIONS'
2221       include 'COMMON.CONTROL'
2222       include 'COMMON.IOUNITS'
2223       include 'COMMON.GEO'
2224       include 'COMMON.VAR'
2225       include 'COMMON.LOCAL'
2226       include 'COMMON.CHAIN'
2227       include 'COMMON.DERIV'
2228       include 'COMMON.INTERACT'
2229       include 'COMMON.CONTACTS'
2230       include 'COMMON.TORSION'
2231       include 'COMMON.VECTORS'
2232       include 'COMMON.FFIELD'
2233       dimension ggg(3)
2234 cd      write(iout,*) 'In EELEC_soft_sphere'
2235       ees=0.0D0
2236       evdw1=0.0D0
2237       eel_loc=0.0d0
2238       eello_turn3=0.0d0
2239       eello_turn4=0.0d0
2240       ind=0
2241       do i=iatel_s,iatel_e
2242         dxi=dc(1,i)
2243         dyi=dc(2,i)
2244         dzi=dc(3,i)
2245         xmedi=c(1,i)+0.5d0*dxi
2246         ymedi=c(2,i)+0.5d0*dyi
2247         zmedi=c(3,i)+0.5d0*dzi
2248         num_conti=0
2249 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2250         do j=ielstart(i),ielend(i)
2251           ind=ind+1
2252           iteli=itel(i)
2253           itelj=itel(j)
2254           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2255           r0ij=rpp(iteli,itelj)
2256           r0ijsq=r0ij*r0ij
2257           dxj=dc(1,j)
2258           dyj=dc(2,j)
2259           dzj=dc(3,j)
2260           xj=c(1,j)+0.5D0*dxj-xmedi
2261           yj=c(2,j)+0.5D0*dyj-ymedi
2262           zj=c(3,j)+0.5D0*dzj-zmedi
2263           rij=xj*xj+yj*yj+zj*zj
2264           if (rij.lt.r0ijsq) then
2265             evdw1ij=0.25d0*(rij-r0ijsq)**2
2266             fac=rij-r0ijsq
2267           else
2268             evdw1ij=0.0d0
2269             fac=0.0d0
2270           endif
2271           evdw1=evdw1+evdw1ij
2272 C
2273 C Calculate contributions to the Cartesian gradient.
2274 C
2275           ggg(1)=fac*xj
2276           ggg(2)=fac*yj
2277           ggg(3)=fac*zj
2278           do k=1,3
2279             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2280             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2281           enddo
2282 *
2283 * Loop over residues i+1 thru j-1.
2284 *
2285 cgrad          do k=i+1,j-1
2286 cgrad            do l=1,3
2287 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2288 cgrad            enddo
2289 cgrad          enddo
2290         enddo ! j
2291       enddo   ! i
2292 cgrad      do i=nnt,nct-1
2293 cgrad        do k=1,3
2294 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2295 cgrad        enddo
2296 cgrad        do j=i+1,nct-1
2297 cgrad          do k=1,3
2298 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2299 cgrad          enddo
2300 cgrad        enddo
2301 cgrad      enddo
2302       return
2303       end
2304 c------------------------------------------------------------------------------
2305       subroutine vec_and_deriv
2306       implicit real*8 (a-h,o-z)
2307       include 'DIMENSIONS'
2308 #ifdef MPI
2309       include 'mpif.h'
2310 #endif
2311       include 'COMMON.IOUNITS'
2312       include 'COMMON.GEO'
2313       include 'COMMON.VAR'
2314       include 'COMMON.LOCAL'
2315       include 'COMMON.CHAIN'
2316       include 'COMMON.VECTORS'
2317       include 'COMMON.SETUP'
2318       include 'COMMON.TIME1'
2319       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2320 C Compute the local reference systems. For reference system (i), the
2321 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2322 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2323 #ifdef PARVEC
2324       do i=ivec_start,ivec_end
2325 #else
2326       do i=1,nres-1
2327 #endif
2328           if (i.eq.nres-1) then
2329 C Case of the last full residue
2330 C Compute the Z-axis
2331             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2332             costh=dcos(pi-theta(nres))
2333             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2334             do k=1,3
2335               uz(k,i)=fac*uz(k,i)
2336             enddo
2337 C Compute the derivatives of uz
2338             uzder(1,1,1)= 0.0d0
2339             uzder(2,1,1)=-dc_norm(3,i-1)
2340             uzder(3,1,1)= dc_norm(2,i-1)
2341             uzder(1,2,1)= dc_norm(3,i-1)
2342             uzder(2,2,1)= 0.0d0
2343             uzder(3,2,1)=-dc_norm(1,i-1)
2344             uzder(1,3,1)=-dc_norm(2,i-1)
2345             uzder(2,3,1)= dc_norm(1,i-1)
2346             uzder(3,3,1)= 0.0d0
2347             uzder(1,1,2)= 0.0d0
2348             uzder(2,1,2)= dc_norm(3,i)
2349             uzder(3,1,2)=-dc_norm(2,i)
2350             uzder(1,2,2)=-dc_norm(3,i)
2351             uzder(2,2,2)= 0.0d0
2352             uzder(3,2,2)= dc_norm(1,i)
2353             uzder(1,3,2)= dc_norm(2,i)
2354             uzder(2,3,2)=-dc_norm(1,i)
2355             uzder(3,3,2)= 0.0d0
2356 C Compute the Y-axis
2357             facy=fac
2358             do k=1,3
2359               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2360             enddo
2361 C Compute the derivatives of uy
2362             do j=1,3
2363               do k=1,3
2364                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2365      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2366                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2367               enddo
2368               uyder(j,j,1)=uyder(j,j,1)-costh
2369               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2370             enddo
2371             do j=1,2
2372               do k=1,3
2373                 do l=1,3
2374                   uygrad(l,k,j,i)=uyder(l,k,j)
2375                   uzgrad(l,k,j,i)=uzder(l,k,j)
2376                 enddo
2377               enddo
2378             enddo
2379             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2380             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2381             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2382             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2383           else
2384 C Other residues
2385 C Compute the Z-axis
2386             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2387             costh=dcos(pi-theta(i+2))
2388             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2389             do k=1,3
2390               uz(k,i)=fac*uz(k,i)
2391             enddo
2392 C Compute the derivatives of uz
2393             uzder(1,1,1)= 0.0d0
2394             uzder(2,1,1)=-dc_norm(3,i+1)
2395             uzder(3,1,1)= dc_norm(2,i+1)
2396             uzder(1,2,1)= dc_norm(3,i+1)
2397             uzder(2,2,1)= 0.0d0
2398             uzder(3,2,1)=-dc_norm(1,i+1)
2399             uzder(1,3,1)=-dc_norm(2,i+1)
2400             uzder(2,3,1)= dc_norm(1,i+1)
2401             uzder(3,3,1)= 0.0d0
2402             uzder(1,1,2)= 0.0d0
2403             uzder(2,1,2)= dc_norm(3,i)
2404             uzder(3,1,2)=-dc_norm(2,i)
2405             uzder(1,2,2)=-dc_norm(3,i)
2406             uzder(2,2,2)= 0.0d0
2407             uzder(3,2,2)= dc_norm(1,i)
2408             uzder(1,3,2)= dc_norm(2,i)
2409             uzder(2,3,2)=-dc_norm(1,i)
2410             uzder(3,3,2)= 0.0d0
2411 C Compute the Y-axis
2412             facy=fac
2413             do k=1,3
2414               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2415             enddo
2416 C Compute the derivatives of uy
2417             do j=1,3
2418               do k=1,3
2419                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2420      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2421                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2422               enddo
2423               uyder(j,j,1)=uyder(j,j,1)-costh
2424               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2425             enddo
2426             do j=1,2
2427               do k=1,3
2428                 do l=1,3
2429                   uygrad(l,k,j,i)=uyder(l,k,j)
2430                   uzgrad(l,k,j,i)=uzder(l,k,j)
2431                 enddo
2432               enddo
2433             enddo
2434             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2435             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2436             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2437             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2438           endif
2439       enddo
2440       do i=1,nres-1
2441         vbld_inv_temp(1)=vbld_inv(i+1)
2442         if (i.lt.nres-1) then
2443           vbld_inv_temp(2)=vbld_inv(i+2)
2444           else
2445           vbld_inv_temp(2)=vbld_inv(i)
2446           endif
2447         do j=1,2
2448           do k=1,3
2449             do l=1,3
2450               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2451               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2452             enddo
2453           enddo
2454         enddo
2455       enddo
2456 #if defined(PARVEC) && defined(MPI)
2457       if (nfgtasks1.gt.1) then
2458         time00=MPI_Wtime()
2459 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2460 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2461 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2462         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2463      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2464      &   FG_COMM1,IERR)
2465         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2466      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2467      &   FG_COMM1,IERR)
2468         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2469      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2470      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2471         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2472      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2473      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2474         time_gather=time_gather+MPI_Wtime()-time00
2475       endif
2476 c      if (fg_rank.eq.0) then
2477 c        write (iout,*) "Arrays UY and UZ"
2478 c        do i=1,nres-1
2479 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2480 c     &     (uz(k,i),k=1,3)
2481 c        enddo
2482 c      endif
2483 #endif
2484       return
2485       end
2486 C-----------------------------------------------------------------------------
2487       subroutine check_vecgrad
2488       implicit real*8 (a-h,o-z)
2489       include 'DIMENSIONS'
2490       include 'COMMON.IOUNITS'
2491       include 'COMMON.GEO'
2492       include 'COMMON.VAR'
2493       include 'COMMON.LOCAL'
2494       include 'COMMON.CHAIN'
2495       include 'COMMON.VECTORS'
2496       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2497       dimension uyt(3,maxres),uzt(3,maxres)
2498       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2499       double precision delta /1.0d-7/
2500       call vec_and_deriv
2501 cd      do i=1,nres
2502 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2503 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2504 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2505 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2506 cd     &     (dc_norm(if90,i),if90=1,3)
2507 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2508 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2509 cd          write(iout,'(a)')
2510 cd      enddo
2511       do i=1,nres
2512         do j=1,2
2513           do k=1,3
2514             do l=1,3
2515               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2516               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2517             enddo
2518           enddo
2519         enddo
2520       enddo
2521       call vec_and_deriv
2522       do i=1,nres
2523         do j=1,3
2524           uyt(j,i)=uy(j,i)
2525           uzt(j,i)=uz(j,i)
2526         enddo
2527       enddo
2528       do i=1,nres
2529 cd        write (iout,*) 'i=',i
2530         do k=1,3
2531           erij(k)=dc_norm(k,i)
2532         enddo
2533         do j=1,3
2534           do k=1,3
2535             dc_norm(k,i)=erij(k)
2536           enddo
2537           dc_norm(j,i)=dc_norm(j,i)+delta
2538 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2539 c          do k=1,3
2540 c            dc_norm(k,i)=dc_norm(k,i)/fac
2541 c          enddo
2542 c          write (iout,*) (dc_norm(k,i),k=1,3)
2543 c          write (iout,*) (erij(k),k=1,3)
2544           call vec_and_deriv
2545           do k=1,3
2546             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2547             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2548             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2549             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2550           enddo
2551 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2552 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2553 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2554         enddo
2555         do k=1,3
2556           dc_norm(k,i)=erij(k)
2557         enddo
2558 cd        do k=1,3
2559 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2560 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2561 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2562 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2563 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2564 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2565 cd          write (iout,'(a)')
2566 cd        enddo
2567       enddo
2568       return
2569       end
2570 C--------------------------------------------------------------------------
2571       subroutine set_matrices
2572       implicit real*8 (a-h,o-z)
2573       include 'DIMENSIONS'
2574 #ifdef MPI
2575       include "mpif.h"
2576       include "COMMON.SETUP"
2577       integer IERR
2578       integer status(MPI_STATUS_SIZE)
2579 #endif
2580       include 'COMMON.IOUNITS'
2581       include 'COMMON.GEO'
2582       include 'COMMON.VAR'
2583       include 'COMMON.LOCAL'
2584       include 'COMMON.CHAIN'
2585       include 'COMMON.DERIV'
2586       include 'COMMON.INTERACT'
2587       include 'COMMON.CONTACTS'
2588       include 'COMMON.TORSION'
2589       include 'COMMON.VECTORS'
2590       include 'COMMON.FFIELD'
2591       double precision auxvec(2),auxmat(2,2)
2592 C
2593 C Compute the virtual-bond-torsional-angle dependent quantities needed
2594 C to calculate the el-loc multibody terms of various order.
2595 C
2596 #ifdef PARMAT
2597       do i=ivec_start+2,ivec_end+2
2598 #else
2599       do i=3,nres+1
2600 #endif
2601         if (i .lt. nres+1) then
2602           sin1=dsin(phi(i))
2603           cos1=dcos(phi(i))
2604           sintab(i-2)=sin1
2605           costab(i-2)=cos1
2606           obrot(1,i-2)=cos1
2607           obrot(2,i-2)=sin1
2608           sin2=dsin(2*phi(i))
2609           cos2=dcos(2*phi(i))
2610           sintab2(i-2)=sin2
2611           costab2(i-2)=cos2
2612           obrot2(1,i-2)=cos2
2613           obrot2(2,i-2)=sin2
2614           Ug(1,1,i-2)=-cos1
2615           Ug(1,2,i-2)=-sin1
2616           Ug(2,1,i-2)=-sin1
2617           Ug(2,2,i-2)= cos1
2618           Ug2(1,1,i-2)=-cos2
2619           Ug2(1,2,i-2)=-sin2
2620           Ug2(2,1,i-2)=-sin2
2621           Ug2(2,2,i-2)= cos2
2622         else
2623           costab(i-2)=1.0d0
2624           sintab(i-2)=0.0d0
2625           obrot(1,i-2)=1.0d0
2626           obrot(2,i-2)=0.0d0
2627           obrot2(1,i-2)=0.0d0
2628           obrot2(2,i-2)=0.0d0
2629           Ug(1,1,i-2)=1.0d0
2630           Ug(1,2,i-2)=0.0d0
2631           Ug(2,1,i-2)=0.0d0
2632           Ug(2,2,i-2)=1.0d0
2633           Ug2(1,1,i-2)=0.0d0
2634           Ug2(1,2,i-2)=0.0d0
2635           Ug2(2,1,i-2)=0.0d0
2636           Ug2(2,2,i-2)=0.0d0
2637         endif
2638         if (i .gt. 3 .and. i .lt. nres+1) then
2639           obrot_der(1,i-2)=-sin1
2640           obrot_der(2,i-2)= cos1
2641           Ugder(1,1,i-2)= sin1
2642           Ugder(1,2,i-2)=-cos1
2643           Ugder(2,1,i-2)=-cos1
2644           Ugder(2,2,i-2)=-sin1
2645           dwacos2=cos2+cos2
2646           dwasin2=sin2+sin2
2647           obrot2_der(1,i-2)=-dwasin2
2648           obrot2_der(2,i-2)= dwacos2
2649           Ug2der(1,1,i-2)= dwasin2
2650           Ug2der(1,2,i-2)=-dwacos2
2651           Ug2der(2,1,i-2)=-dwacos2
2652           Ug2der(2,2,i-2)=-dwasin2
2653         else
2654           obrot_der(1,i-2)=0.0d0
2655           obrot_der(2,i-2)=0.0d0
2656           Ugder(1,1,i-2)=0.0d0
2657           Ugder(1,2,i-2)=0.0d0
2658           Ugder(2,1,i-2)=0.0d0
2659           Ugder(2,2,i-2)=0.0d0
2660           obrot2_der(1,i-2)=0.0d0
2661           obrot2_der(2,i-2)=0.0d0
2662           Ug2der(1,1,i-2)=0.0d0
2663           Ug2der(1,2,i-2)=0.0d0
2664           Ug2der(2,1,i-2)=0.0d0
2665           Ug2der(2,2,i-2)=0.0d0
2666         endif
2667 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2668         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2669           iti = itortyp(itype(i-2))
2670         else
2671           iti=ntortyp+1
2672         endif
2673 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2674         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2675           iti1 = itortyp(itype(i-1))
2676         else
2677           iti1=ntortyp+1
2678         endif
2679 cd        write (iout,*) '*******i',i,' iti1',iti
2680 cd        write (iout,*) 'b1',b1(:,iti)
2681 cd        write (iout,*) 'b2',b2(:,iti)
2682 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2683 c        if (i .gt. iatel_s+2) then
2684         if (i .gt. nnt+2) then
2685           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2686           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2687           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2688      &    then
2689           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2690           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2691           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2692           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2693           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2694           endif
2695         else
2696           do k=1,2
2697             Ub2(k,i-2)=0.0d0
2698             Ctobr(k,i-2)=0.0d0
2699             Dtobr2(k,i-2)=0.0d0
2700             do l=1,2
2701               EUg(l,k,i-2)=0.0d0
2702               CUg(l,k,i-2)=0.0d0
2703               DUg(l,k,i-2)=0.0d0
2704               DtUg2(l,k,i-2)=0.0d0
2705             enddo
2706           enddo
2707         endif
2708         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2709         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2710         do k=1,2
2711           muder(k,i-2)=Ub2der(k,i-2)
2712         enddo
2713 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2714         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2715           iti1 = itortyp(itype(i-1))
2716         else
2717           iti1=ntortyp+1
2718         endif
2719         do k=1,2
2720           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2721         enddo
2722 cd        write (iout,*) 'mu ',mu(:,i-2)
2723 cd        write (iout,*) 'mu1',mu1(:,i-2)
2724 cd        write (iout,*) 'mu2',mu2(:,i-2)
2725         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2726      &  then
2727         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2728         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2729         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2730         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2731         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2732 C Vectors and matrices dependent on a single virtual-bond dihedral.
2733         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2734         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2735         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2736         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2737         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2738         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2739         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2740         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2741         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2742         endif
2743       enddo
2744 C Matrices dependent on two consecutive virtual-bond dihedrals.
2745 C The order of matrices is from left to right.
2746       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2747      &then
2748 c      do i=max0(ivec_start,2),ivec_end
2749       do i=2,nres-1
2750         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2751         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2752         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2753         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2754         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2755         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2756         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2757         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2758       enddo
2759       endif
2760 #if defined(MPI) && defined(PARMAT)
2761 #ifdef DEBUG
2762 c      if (fg_rank.eq.0) then
2763         write (iout,*) "Arrays UG and UGDER before GATHER"
2764         do i=1,nres-1
2765           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2766      &     ((ug(l,k,i),l=1,2),k=1,2),
2767      &     ((ugder(l,k,i),l=1,2),k=1,2)
2768         enddo
2769         write (iout,*) "Arrays UG2 and UG2DER"
2770         do i=1,nres-1
2771           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2772      &     ((ug2(l,k,i),l=1,2),k=1,2),
2773      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2774         enddo
2775         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2776         do i=1,nres-1
2777           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2778      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2779      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2780         enddo
2781         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2782         do i=1,nres-1
2783           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2784      &     costab(i),sintab(i),costab2(i),sintab2(i)
2785         enddo
2786         write (iout,*) "Array MUDER"
2787         do i=1,nres-1
2788           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2789         enddo
2790 c      endif
2791 #endif
2792       if (nfgtasks.gt.1) then
2793         time00=MPI_Wtime()
2794 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2795 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2796 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2797 #ifdef MATGATHER
2798         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2799      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2800      &   FG_COMM1,IERR)
2801         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2802      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2803      &   FG_COMM1,IERR)
2804         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2805      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2806      &   FG_COMM1,IERR)
2807         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2808      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2809      &   FG_COMM1,IERR)
2810         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2811      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2812      &   FG_COMM1,IERR)
2813         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2814      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2815      &   FG_COMM1,IERR)
2816         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2817      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2818      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2819         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2820      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2821      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2822         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2823      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2824      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2825         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2826      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2827      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2828         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2829      &  then
2830         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2831      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2832      &   FG_COMM1,IERR)
2833         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2834      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2835      &   FG_COMM1,IERR)
2836         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2837      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2838      &   FG_COMM1,IERR)
2839        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2840      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2841      &   FG_COMM1,IERR)
2842         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2843      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2844      &   FG_COMM1,IERR)
2845         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2846      &   ivec_count(fg_rank1),
2847      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2848      &   FG_COMM1,IERR)
2849         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2850      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2851      &   FG_COMM1,IERR)
2852         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2853      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2854      &   FG_COMM1,IERR)
2855         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2856      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2857      &   FG_COMM1,IERR)
2858         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2859      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2860      &   FG_COMM1,IERR)
2861         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2862      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2863      &   FG_COMM1,IERR)
2864         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2865      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2866      &   FG_COMM1,IERR)
2867         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2868      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2869      &   FG_COMM1,IERR)
2870         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2871      &   ivec_count(fg_rank1),
2872      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2873      &   FG_COMM1,IERR)
2874         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2875      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2876      &   FG_COMM1,IERR)
2877        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2878      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2879      &   FG_COMM1,IERR)
2880         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2881      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2882      &   FG_COMM1,IERR)
2883        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2884      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2885      &   FG_COMM1,IERR)
2886         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2887      &   ivec_count(fg_rank1),
2888      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2889      &   FG_COMM1,IERR)
2890         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2891      &   ivec_count(fg_rank1),
2892      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2893      &   FG_COMM1,IERR)
2894         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2895      &   ivec_count(fg_rank1),
2896      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2897      &   MPI_MAT2,FG_COMM1,IERR)
2898         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2899      &   ivec_count(fg_rank1),
2900      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2901      &   MPI_MAT2,FG_COMM1,IERR)
2902         endif
2903 #else
2904 c Passes matrix info through the ring
2905       isend=fg_rank1
2906       irecv=fg_rank1-1
2907       if (irecv.lt.0) irecv=nfgtasks1-1
2908       iprev=irecv
2909       inext=fg_rank1+1
2910       if (inext.ge.nfgtasks1) inext=0
2911       do i=1,nfgtasks1-1
2912 c        write (iout,*) "isend",isend," irecv",irecv
2913 c        call flush(iout)
2914         lensend=lentyp(isend)
2915         lenrecv=lentyp(irecv)
2916 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2917 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2918 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2919 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2920 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2921 c        write (iout,*) "Gather ROTAT1"
2922 c        call flush(iout)
2923 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2924 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2925 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2926 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2927 c        write (iout,*) "Gather ROTAT2"
2928 c        call flush(iout)
2929         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2930      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2931      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2932      &   iprev,4400+irecv,FG_COMM,status,IERR)
2933 c        write (iout,*) "Gather ROTAT_OLD"
2934 c        call flush(iout)
2935         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2936      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2937      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2938      &   iprev,5500+irecv,FG_COMM,status,IERR)
2939 c        write (iout,*) "Gather PRECOMP11"
2940 c        call flush(iout)
2941         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2942      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2943      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2944      &   iprev,6600+irecv,FG_COMM,status,IERR)
2945 c        write (iout,*) "Gather PRECOMP12"
2946 c        call flush(iout)
2947         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2948      &  then
2949         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2950      &   MPI_ROTAT2(lensend),inext,7700+isend,
2951      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2952      &   iprev,7700+irecv,FG_COMM,status,IERR)
2953 c        write (iout,*) "Gather PRECOMP21"
2954 c        call flush(iout)
2955         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2956      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2957      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2958      &   iprev,8800+irecv,FG_COMM,status,IERR)
2959 c        write (iout,*) "Gather PRECOMP22"
2960 c        call flush(iout)
2961         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2962      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2963      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2964      &   MPI_PRECOMP23(lenrecv),
2965      &   iprev,9900+irecv,FG_COMM,status,IERR)
2966 c        write (iout,*) "Gather PRECOMP23"
2967 c        call flush(iout)
2968         endif
2969         isend=irecv
2970         irecv=irecv-1
2971         if (irecv.lt.0) irecv=nfgtasks1-1
2972       enddo
2973 #endif
2974         time_gather=time_gather+MPI_Wtime()-time00
2975       endif
2976 #ifdef DEBUG
2977 c      if (fg_rank.eq.0) then
2978         write (iout,*) "Arrays UG and UGDER"
2979         do i=1,nres-1
2980           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2981      &     ((ug(l,k,i),l=1,2),k=1,2),
2982      &     ((ugder(l,k,i),l=1,2),k=1,2)
2983         enddo
2984         write (iout,*) "Arrays UG2 and UG2DER"
2985         do i=1,nres-1
2986           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2987      &     ((ug2(l,k,i),l=1,2),k=1,2),
2988      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2989         enddo
2990         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2991         do i=1,nres-1
2992           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2993      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2994      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2995         enddo
2996         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2997         do i=1,nres-1
2998           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2999      &     costab(i),sintab(i),costab2(i),sintab2(i)
3000         enddo
3001         write (iout,*) "Array MUDER"
3002         do i=1,nres-1
3003           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3004         enddo
3005 c      endif
3006 #endif
3007 #endif
3008 cd      do i=1,nres
3009 cd        iti = itortyp(itype(i))
3010 cd        write (iout,*) i
3011 cd        do j=1,2
3012 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3013 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3014 cd        enddo
3015 cd      enddo
3016       return
3017       end
3018 C--------------------------------------------------------------------------
3019       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3020 C
3021 C This subroutine calculates the average interaction energy and its gradient
3022 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3023 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3024 C The potential depends both on the distance of peptide-group centers and on
3025 C the orientation of the CA-CA virtual bonds.
3026 C
3027       implicit real*8 (a-h,o-z)
3028 #ifdef MPI
3029       include 'mpif.h'
3030 #endif
3031       include 'DIMENSIONS'
3032       include 'COMMON.CONTROL'
3033       include 'COMMON.SETUP'
3034       include 'COMMON.IOUNITS'
3035       include 'COMMON.GEO'
3036       include 'COMMON.VAR'
3037       include 'COMMON.LOCAL'
3038       include 'COMMON.CHAIN'
3039       include 'COMMON.DERIV'
3040       include 'COMMON.INTERACT'
3041       include 'COMMON.CONTACTS'
3042       include 'COMMON.TORSION'
3043       include 'COMMON.VECTORS'
3044       include 'COMMON.FFIELD'
3045       include 'COMMON.TIME1'
3046       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3047      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3048       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3049      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3050       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3051      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3052      &    num_conti,j1,j2
3053 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3054 #ifdef MOMENT
3055       double precision scal_el /1.0d0/
3056 #else
3057       double precision scal_el /0.5d0/
3058 #endif
3059 C 12/13/98
3060 C 13-go grudnia roku pamietnego...
3061       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3062      &                   0.0d0,1.0d0,0.0d0,
3063      &                   0.0d0,0.0d0,1.0d0/
3064 cd      write(iout,*) 'In EELEC'
3065 cd      do i=1,nloctyp
3066 cd        write(iout,*) 'Type',i
3067 cd        write(iout,*) 'B1',B1(:,i)
3068 cd        write(iout,*) 'B2',B2(:,i)
3069 cd        write(iout,*) 'CC',CC(:,:,i)
3070 cd        write(iout,*) 'DD',DD(:,:,i)
3071 cd        write(iout,*) 'EE',EE(:,:,i)
3072 cd      enddo
3073 cd      call check_vecgrad
3074 cd      stop
3075       if (icheckgrad.eq.1) then
3076         do i=1,nres-1
3077           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3078           do k=1,3
3079             dc_norm(k,i)=dc(k,i)*fac
3080           enddo
3081 c          write (iout,*) 'i',i,' fac',fac
3082         enddo
3083       endif
3084       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3085      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3086      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3087 c        call vec_and_deriv
3088 #ifdef TIMING
3089         time01=MPI_Wtime()
3090 #endif
3091         call set_matrices
3092 #ifdef TIMING
3093         time_mat=time_mat+MPI_Wtime()-time01
3094 #endif
3095       endif
3096 cd      do i=1,nres-1
3097 cd        write (iout,*) 'i=',i
3098 cd        do k=1,3
3099 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3100 cd        enddo
3101 cd        do k=1,3
3102 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3103 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3104 cd        enddo
3105 cd      enddo
3106       t_eelecij=0.0d0
3107       ees=0.0D0
3108       evdw1=0.0D0
3109       eel_loc=0.0d0
3110       eello_turn3=0.0d0
3111       eello_turn4=0.0d0
3112       ind=0
3113       do i=1,nres
3114         num_cont_hb(i)=0
3115       enddo
3116 cd      print '(a)','Enter EELEC'
3117 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3118       do i=1,nres
3119         gel_loc_loc(i)=0.0d0
3120         gcorr_loc(i)=0.0d0
3121       enddo
3122 c
3123 c
3124 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3125 C
3126 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3127 C
3128       do i=iturn3_start,iturn3_end
3129         dxi=dc(1,i)
3130         dyi=dc(2,i)
3131         dzi=dc(3,i)
3132         dx_normi=dc_norm(1,i)
3133         dy_normi=dc_norm(2,i)
3134         dz_normi=dc_norm(3,i)
3135         xmedi=c(1,i)+0.5d0*dxi
3136         ymedi=c(2,i)+0.5d0*dyi
3137         zmedi=c(3,i)+0.5d0*dzi
3138         num_conti=0
3139         call eelecij(i,i+2,ees,evdw1,eel_loc)
3140         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3141         num_cont_hb(i)=num_conti
3142       enddo
3143       do i=iturn4_start,iturn4_end
3144         dxi=dc(1,i)
3145         dyi=dc(2,i)
3146         dzi=dc(3,i)
3147         dx_normi=dc_norm(1,i)
3148         dy_normi=dc_norm(2,i)
3149         dz_normi=dc_norm(3,i)
3150         xmedi=c(1,i)+0.5d0*dxi
3151         ymedi=c(2,i)+0.5d0*dyi
3152         zmedi=c(3,i)+0.5d0*dzi
3153         num_conti=num_cont_hb(i)
3154         call eelecij(i,i+3,ees,evdw1,eel_loc)
3155         if (wturn4.gt.0.0d0) call eturn4(i,eello_turn4)
3156         num_cont_hb(i)=num_conti
3157       enddo   ! i
3158 c
3159 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3160 c
3161       do i=iatel_s,iatel_e
3162         dxi=dc(1,i)
3163         dyi=dc(2,i)
3164         dzi=dc(3,i)
3165         dx_normi=dc_norm(1,i)
3166         dy_normi=dc_norm(2,i)
3167         dz_normi=dc_norm(3,i)
3168         xmedi=c(1,i)+0.5d0*dxi
3169         ymedi=c(2,i)+0.5d0*dyi
3170         zmedi=c(3,i)+0.5d0*dzi
3171 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3172         num_conti=num_cont_hb(i)
3173         do j=ielstart(i),ielend(i)
3174           call eelecij(i,j,ees,evdw1,eel_loc)
3175         enddo ! j
3176         num_cont_hb(i)=num_conti
3177       enddo   ! i
3178 c      write (iout,*) "Number of loop steps in EELEC:",ind
3179 cd      do i=1,nres
3180 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3181 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3182 cd      enddo
3183 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3184 ccc      eel_loc=eel_loc+eello_turn3
3185 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3186       return
3187       end
3188 C-------------------------------------------------------------------------------
3189       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3190       implicit real*8 (a-h,o-z)
3191       include 'DIMENSIONS'
3192 #ifdef MPI
3193       include "mpif.h"
3194 #endif
3195       include 'COMMON.CONTROL'
3196       include 'COMMON.IOUNITS'
3197       include 'COMMON.GEO'
3198       include 'COMMON.VAR'
3199       include 'COMMON.LOCAL'
3200       include 'COMMON.CHAIN'
3201       include 'COMMON.DERIV'
3202       include 'COMMON.INTERACT'
3203       include 'COMMON.CONTACTS'
3204       include 'COMMON.TORSION'
3205       include 'COMMON.VECTORS'
3206       include 'COMMON.FFIELD'
3207       include 'COMMON.TIME1'
3208       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3209      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3210       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3211      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3212       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3213      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3214      &    num_conti,j1,j2
3215 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3216 #ifdef MOMENT
3217       double precision scal_el /1.0d0/
3218 #else
3219       double precision scal_el /0.5d0/
3220 #endif
3221 C 12/13/98
3222 C 13-go grudnia roku pamietnego...
3223       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3224      &                   0.0d0,1.0d0,0.0d0,
3225      &                   0.0d0,0.0d0,1.0d0/
3226 c          time00=MPI_Wtime()
3227 cd      write (iout,*) "eelecij",i,j
3228 c          ind=ind+1
3229           iteli=itel(i)
3230           itelj=itel(j)
3231           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3232           aaa=app(iteli,itelj)
3233           bbb=bpp(iteli,itelj)
3234           ael6i=ael6(iteli,itelj)
3235           ael3i=ael3(iteli,itelj)
3236           dxj=dc(1,j)
3237           dyj=dc(2,j)
3238           dzj=dc(3,j)
3239           dx_normj=dc_norm(1,j)
3240           dy_normj=dc_norm(2,j)
3241           dz_normj=dc_norm(3,j)
3242           xj=c(1,j)+0.5D0*dxj-xmedi
3243           yj=c(2,j)+0.5D0*dyj-ymedi
3244           zj=c(3,j)+0.5D0*dzj-zmedi
3245           rij=xj*xj+yj*yj+zj*zj
3246           rrmij=1.0D0/rij
3247           rij=dsqrt(rij)
3248           rmij=1.0D0/rij
3249           r3ij=rrmij*rmij
3250           r6ij=r3ij*r3ij
3251           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3252           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3253           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3254           fac=cosa-3.0D0*cosb*cosg
3255           ev1=aaa*r6ij*r6ij
3256 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3257           if (j.eq.i+2) ev1=scal_el*ev1
3258           ev2=bbb*r6ij
3259           fac3=ael6i*r6ij
3260           fac4=ael3i*r3ij
3261           evdwij=ev1+ev2
3262           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3263           el2=fac4*fac
3264           eesij=el1+el2
3265 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3266           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3267           ees=ees+eesij
3268           evdw1=evdw1+evdwij
3269 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3270 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3271 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3272 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3273
3274           if (energy_dec) then
3275               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3276               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3277           endif
3278
3279 C
3280 C Calculate contributions to the Cartesian gradient.
3281 C
3282 #ifdef SPLITELE
3283           facvdw=-6*rrmij*(ev1+evdwij)
3284           facel=-3*rrmij*(el1+eesij)
3285           fac1=fac
3286           erij(1)=xj*rmij
3287           erij(2)=yj*rmij
3288           erij(3)=zj*rmij
3289 *
3290 * Radial derivatives. First process both termini of the fragment (i,j)
3291 *
3292           ggg(1)=facel*xj
3293           ggg(2)=facel*yj
3294           ggg(3)=facel*zj
3295 c          do k=1,3
3296 c            ghalf=0.5D0*ggg(k)
3297 c            gelc(k,i)=gelc(k,i)+ghalf
3298 c            gelc(k,j)=gelc(k,j)+ghalf
3299 c          enddo
3300 c 9/28/08 AL Gradient compotents will be summed only at the end
3301           do k=1,3
3302             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3303             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3304           enddo
3305 *
3306 * Loop over residues i+1 thru j-1.
3307 *
3308 cgrad          do k=i+1,j-1
3309 cgrad            do l=1,3
3310 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3311 cgrad            enddo
3312 cgrad          enddo
3313           ggg(1)=facvdw*xj
3314           ggg(2)=facvdw*yj
3315           ggg(3)=facvdw*zj
3316 c          do k=1,3
3317 c            ghalf=0.5D0*ggg(k)
3318 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3319 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3320 c          enddo
3321 c 9/28/08 AL Gradient compotents will be summed only at the end
3322           do k=1,3
3323             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3324             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3325           enddo
3326 *
3327 * Loop over residues i+1 thru j-1.
3328 *
3329 cgrad          do k=i+1,j-1
3330 cgrad            do l=1,3
3331 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3332 cgrad            enddo
3333 cgrad          enddo
3334 #else
3335           facvdw=ev1+evdwij
3336           facel=el1+eesij
3337           fac1=fac
3338           fac=-3*rrmij*(facvdw+facvdw+facel)
3339           erij(1)=xj*rmij
3340           erij(2)=yj*rmij
3341           erij(3)=zj*rmij
3342 *
3343 * Radial derivatives. First process both termini of the fragment (i,j)
3344 *
3345           ggg(1)=fac*xj
3346           ggg(2)=fac*yj
3347           ggg(3)=fac*zj
3348 c          do k=1,3
3349 c            ghalf=0.5D0*ggg(k)
3350 c            gelc(k,i)=gelc(k,i)+ghalf
3351 c            gelc(k,j)=gelc(k,j)+ghalf
3352 c          enddo
3353 c 9/28/08 AL Gradient compotents will be summed only at the end
3354           do k=1,3
3355             gelc_long(k,j)=gelc(k,j)+ggg(k)
3356             gelc_long(k,i)=gelc(k,i)-ggg(k)
3357           enddo
3358 *
3359 * Loop over residues i+1 thru j-1.
3360 *
3361 cgrad          do k=i+1,j-1
3362 cgrad            do l=1,3
3363 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3364 cgrad            enddo
3365 cgrad          enddo
3366 c 9/28/08 AL Gradient compotents will be summed only at the end
3367           ggg(1)=facvdw*xj
3368           ggg(2)=facvdw*yj
3369           ggg(3)=facvdw*zj
3370           do k=1,3
3371             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3372             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3373           enddo
3374 #endif
3375 *
3376 * Angular part
3377 *
3378           ecosa=2.0D0*fac3*fac1+fac4
3379           fac4=-3.0D0*fac4
3380           fac3=-6.0D0*fac3
3381           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3382           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3383           do k=1,3
3384             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3385             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3386           enddo
3387 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3388 cd   &          (dcosg(k),k=1,3)
3389           do k=1,3
3390             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3391           enddo
3392 c          do k=1,3
3393 c            ghalf=0.5D0*ggg(k)
3394 c            gelc(k,i)=gelc(k,i)+ghalf
3395 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3396 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3397 c            gelc(k,j)=gelc(k,j)+ghalf
3398 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3399 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3400 c          enddo
3401 cgrad          do k=i+1,j-1
3402 cgrad            do l=1,3
3403 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3404 cgrad            enddo
3405 cgrad          enddo
3406           do k=1,3
3407             gelc(k,i)=gelc(k,i)
3408      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3409      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3410             gelc(k,j)=gelc(k,j)
3411      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3412      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3413             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3414             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3415           enddo
3416           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3417      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3418      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3419 C
3420 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3421 C   energy of a peptide unit is assumed in the form of a second-order
3422 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3423 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3424 C   are computed for EVERY pair of non-contiguous peptide groups.
3425 C
3426           if (j.lt.nres-1) then
3427             j1=j+1
3428             j2=j-1
3429           else
3430             j1=j-1
3431             j2=j-2
3432           endif
3433           kkk=0
3434           do k=1,2
3435             do l=1,2
3436               kkk=kkk+1
3437               muij(kkk)=mu(k,i)*mu(l,j)
3438             enddo
3439           enddo
3440 cd         write (iout,*) 'EELEC: i',i,' j',j
3441 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3442 cd          write(iout,*) 'muij',muij
3443           ury=scalar(uy(1,i),erij)
3444           urz=scalar(uz(1,i),erij)
3445           vry=scalar(uy(1,j),erij)
3446           vrz=scalar(uz(1,j),erij)
3447           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3448           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3449           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3450           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3451           fac=dsqrt(-ael6i)*r3ij
3452           a22=a22*fac
3453           a23=a23*fac
3454           a32=a32*fac
3455           a33=a33*fac
3456 cd          write (iout,'(4i5,4f10.5)')
3457 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3458 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3459 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3460 cd     &      uy(:,j),uz(:,j)
3461 cd          write (iout,'(4f10.5)')
3462 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3463 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3464 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3465 cd           write (iout,'(9f10.5/)')
3466 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3467 C Derivatives of the elements of A in virtual-bond vectors
3468           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3469           do k=1,3
3470             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3471             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3472             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3473             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3474             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3475             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3476             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3477             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3478             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3479             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3480             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3481             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3482           enddo
3483 C Compute radial contributions to the gradient
3484           facr=-3.0d0*rrmij
3485           a22der=a22*facr
3486           a23der=a23*facr
3487           a32der=a32*facr
3488           a33der=a33*facr
3489           agg(1,1)=a22der*xj
3490           agg(2,1)=a22der*yj
3491           agg(3,1)=a22der*zj
3492           agg(1,2)=a23der*xj
3493           agg(2,2)=a23der*yj
3494           agg(3,2)=a23der*zj
3495           agg(1,3)=a32der*xj
3496           agg(2,3)=a32der*yj
3497           agg(3,3)=a32der*zj
3498           agg(1,4)=a33der*xj
3499           agg(2,4)=a33der*yj
3500           agg(3,4)=a33der*zj
3501 C Add the contributions coming from er
3502           fac3=-3.0d0*fac
3503           do k=1,3
3504             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3505             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3506             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3507             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3508           enddo
3509           do k=1,3
3510 C Derivatives in DC(i)
3511 cgrad            ghalf1=0.5d0*agg(k,1)
3512 cgrad            ghalf2=0.5d0*agg(k,2)
3513 cgrad            ghalf3=0.5d0*agg(k,3)
3514 cgrad            ghalf4=0.5d0*agg(k,4)
3515             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3516      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3517             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3518      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3519             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3520      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3521             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3522      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3523 C Derivatives in DC(i+1)
3524             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3525      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3526             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3527      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3528             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3529      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3530             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3531      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3532 C Derivatives in DC(j)
3533             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3534      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3535             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3536      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3537             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3538      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3539             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3540      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3541 C Derivatives in DC(j+1) or DC(nres-1)
3542             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3543      &      -3.0d0*vryg(k,3)*ury)
3544             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3545      &      -3.0d0*vrzg(k,3)*ury)
3546             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3547      &      -3.0d0*vryg(k,3)*urz)
3548             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3549      &      -3.0d0*vrzg(k,3)*urz)
3550 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3551 cgrad              do l=1,4
3552 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3553 cgrad              enddo
3554 cgrad            endif
3555           enddo
3556           acipa(1,1)=a22
3557           acipa(1,2)=a23
3558           acipa(2,1)=a32
3559           acipa(2,2)=a33
3560           a22=-a22
3561           a23=-a23
3562           do l=1,2
3563             do k=1,3
3564               agg(k,l)=-agg(k,l)
3565               aggi(k,l)=-aggi(k,l)
3566               aggi1(k,l)=-aggi1(k,l)
3567               aggj(k,l)=-aggj(k,l)
3568               aggj1(k,l)=-aggj1(k,l)
3569             enddo
3570           enddo
3571           if (j.lt.nres-1) then
3572             a22=-a22
3573             a32=-a32
3574             do l=1,3,2
3575               do k=1,3
3576                 agg(k,l)=-agg(k,l)
3577                 aggi(k,l)=-aggi(k,l)
3578                 aggi1(k,l)=-aggi1(k,l)
3579                 aggj(k,l)=-aggj(k,l)
3580                 aggj1(k,l)=-aggj1(k,l)
3581               enddo
3582             enddo
3583           else
3584             a22=-a22
3585             a23=-a23
3586             a32=-a32
3587             a33=-a33
3588             do l=1,4
3589               do k=1,3
3590                 agg(k,l)=-agg(k,l)
3591                 aggi(k,l)=-aggi(k,l)
3592                 aggi1(k,l)=-aggi1(k,l)
3593                 aggj(k,l)=-aggj(k,l)
3594                 aggj1(k,l)=-aggj1(k,l)
3595               enddo
3596             enddo
3597           endif
3598           ENDIF ! WCORR
3599           IF (wel_loc.gt.0.0d0) THEN
3600 C Contribution to the local-electrostatic energy coming from the i-j pair
3601           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3602      &     +a33*muij(4)
3603 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3604
3605           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3606      &            'eelloc',i,j,eel_loc_ij
3607
3608           eel_loc=eel_loc+eel_loc_ij
3609 C Partial derivatives in virtual-bond dihedral angles gamma
3610           if (i.gt.1)
3611      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3612      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3613      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3614           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3615      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3616      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3617 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3618           do l=1,3
3619             ggg(l)=agg(l,1)*muij(1)+
3620      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3621             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3622             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3623 cgrad            ghalf=0.5d0*ggg(l)
3624 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3625 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3626           enddo
3627 cgrad          do k=i+1,j2
3628 cgrad            do l=1,3
3629 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3630 cgrad            enddo
3631 cgrad          enddo
3632 C Remaining derivatives of eello
3633           do l=1,3
3634             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3635      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3636             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3637      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3638             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3639      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3640             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3641      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3642           enddo
3643           ENDIF
3644 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3645 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3646           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3647      &       .and. num_conti.le.maxconts) then
3648 c            write (iout,*) i,j," entered corr"
3649 C
3650 C Calculate the contact function. The ith column of the array JCONT will
3651 C contain the numbers of atoms that make contacts with the atom I (of numbers
3652 C greater than I). The arrays FACONT and GACONT will contain the values of
3653 C the contact function and its derivative.
3654 c           r0ij=1.02D0*rpp(iteli,itelj)
3655 c           r0ij=1.11D0*rpp(iteli,itelj)
3656             r0ij=2.20D0*rpp(iteli,itelj)
3657 c           r0ij=1.55D0*rpp(iteli,itelj)
3658             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3659             if (fcont.gt.0.0D0) then
3660               num_conti=num_conti+1
3661               if (num_conti.gt.maxconts) then
3662                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3663      &                         ' will skip next contacts for this conf.'
3664               else
3665                 jcont_hb(num_conti,i)=j
3666 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3667 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3668                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3669      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3670 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3671 C  terms.
3672                 d_cont(num_conti,i)=rij
3673 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3674 C     --- Electrostatic-interaction matrix ---
3675                 a_chuj(1,1,num_conti,i)=a22
3676                 a_chuj(1,2,num_conti,i)=a23
3677                 a_chuj(2,1,num_conti,i)=a32
3678                 a_chuj(2,2,num_conti,i)=a33
3679 C     --- Gradient of rij
3680                 do kkk=1,3
3681                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3682                 enddo
3683                 kkll=0
3684                 do k=1,2
3685                   do l=1,2
3686                     kkll=kkll+1
3687                     do m=1,3
3688                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3689                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3690                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3691                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3692                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3693                     enddo
3694                   enddo
3695                 enddo
3696                 ENDIF
3697                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3698 C Calculate contact energies
3699                 cosa4=4.0D0*cosa
3700                 wij=cosa-3.0D0*cosb*cosg
3701                 cosbg1=cosb+cosg
3702                 cosbg2=cosb-cosg
3703 c               fac3=dsqrt(-ael6i)/r0ij**3
3704                 fac3=dsqrt(-ael6i)*r3ij
3705 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3706                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3707                 if (ees0tmp.gt.0) then
3708                   ees0pij=dsqrt(ees0tmp)
3709                 else
3710                   ees0pij=0
3711                 endif
3712 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3713                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3714                 if (ees0tmp.gt.0) then
3715                   ees0mij=dsqrt(ees0tmp)
3716                 else
3717                   ees0mij=0
3718                 endif
3719 c               ees0mij=0.0D0
3720                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3721                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3722 C Diagnostics. Comment out or remove after debugging!
3723 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3724 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3725 c               ees0m(num_conti,i)=0.0D0
3726 C End diagnostics.
3727 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3728 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3729 C Angular derivatives of the contact function
3730                 ees0pij1=fac3/ees0pij
3731                 ees0mij1=fac3/ees0mij
3732                 fac3p=-3.0D0*fac3*rrmij
3733                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3734                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3735 c               ees0mij1=0.0D0
3736                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3737                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3738                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3739                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3740                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3741                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3742                 ecosap=ecosa1+ecosa2
3743                 ecosbp=ecosb1+ecosb2
3744                 ecosgp=ecosg1+ecosg2
3745                 ecosam=ecosa1-ecosa2
3746                 ecosbm=ecosb1-ecosb2
3747                 ecosgm=ecosg1-ecosg2
3748 C Diagnostics
3749 c               ecosap=ecosa1
3750 c               ecosbp=ecosb1
3751 c               ecosgp=ecosg1
3752 c               ecosam=0.0D0
3753 c               ecosbm=0.0D0
3754 c               ecosgm=0.0D0
3755 C End diagnostics
3756                 facont_hb(num_conti,i)=fcont
3757                 fprimcont=fprimcont/rij
3758 cd              facont_hb(num_conti,i)=1.0D0
3759 C Following line is for diagnostics.
3760 cd              fprimcont=0.0D0
3761                 do k=1,3
3762                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3763                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3764                 enddo
3765                 do k=1,3
3766                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3767                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3768                 enddo
3769                 gggp(1)=gggp(1)+ees0pijp*xj
3770                 gggp(2)=gggp(2)+ees0pijp*yj
3771                 gggp(3)=gggp(3)+ees0pijp*zj
3772                 gggm(1)=gggm(1)+ees0mijp*xj
3773                 gggm(2)=gggm(2)+ees0mijp*yj
3774                 gggm(3)=gggm(3)+ees0mijp*zj
3775 C Derivatives due to the contact function
3776                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3777                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3778                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3779                 do k=1,3
3780 c
3781 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3782 c          following the change of gradient-summation algorithm.
3783 c
3784 cgrad                  ghalfp=0.5D0*gggp(k)
3785 cgrad                  ghalfm=0.5D0*gggm(k)
3786                   gacontp_hb1(k,num_conti,i)=!ghalfp
3787      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3788      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3789                   gacontp_hb2(k,num_conti,i)=!ghalfp
3790      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3791      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3792                   gacontp_hb3(k,num_conti,i)=gggp(k)
3793                   gacontm_hb1(k,num_conti,i)=!ghalfm
3794      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3795      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3796                   gacontm_hb2(k,num_conti,i)=!ghalfm
3797      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3798      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3799                   gacontm_hb3(k,num_conti,i)=gggm(k)
3800                 enddo
3801 C Diagnostics. Comment out or remove after debugging!
3802 cdiag           do k=1,3
3803 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3804 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3805 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3806 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3807 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3808 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3809 cdiag           enddo
3810               ENDIF ! wcorr
3811               endif  ! num_conti.le.maxconts
3812             endif  ! fcont.gt.0
3813           endif    ! j.gt.i+1
3814           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3815             do k=1,4
3816               do l=1,3
3817                 ghalf=0.5d0*agg(l,k)
3818                 aggi(l,k)=aggi(l,k)+ghalf
3819                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3820                 aggj(l,k)=aggj(l,k)+ghalf
3821               enddo
3822             enddo
3823             if (j.eq.nres-1 .and. i.lt.j-2) then
3824               do k=1,4
3825                 do l=1,3
3826                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3827                 enddo
3828               enddo
3829             endif
3830           endif
3831 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3832       return
3833       end
3834 C-----------------------------------------------------------------------------
3835       subroutine eturn3(i,eello_turn3)
3836 C Third- and fourth-order contributions from turns
3837       implicit real*8 (a-h,o-z)
3838       include 'DIMENSIONS'
3839       include 'COMMON.IOUNITS'
3840       include 'COMMON.GEO'
3841       include 'COMMON.VAR'
3842       include 'COMMON.LOCAL'
3843       include 'COMMON.CHAIN'
3844       include 'COMMON.DERIV'
3845       include 'COMMON.INTERACT'
3846       include 'COMMON.CONTACTS'
3847       include 'COMMON.TORSION'
3848       include 'COMMON.VECTORS'
3849       include 'COMMON.FFIELD'
3850       include 'COMMON.CONTROL'
3851       dimension ggg(3)
3852       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3853      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3854      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3855       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3856      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3857       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3858      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3859      &    num_conti,j1,j2
3860       j=i+2
3861 c      write (iout,*) "eturn3",i,j,j1,j2
3862       a_temp(1,1)=a22
3863       a_temp(1,2)=a23
3864       a_temp(2,1)=a32
3865       a_temp(2,2)=a33
3866 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3867 C
3868 C               Third-order contributions
3869 C
3870 C                 (i+2)o----(i+3)
3871 C                      | |
3872 C                      | |
3873 C                 (i+1)o----i
3874 C
3875 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3876 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3877         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3878         call transpose2(auxmat(1,1),auxmat1(1,1))
3879         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3880         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3881         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3882      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3883 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3884 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3885 cd     &    ' eello_turn3_num',4*eello_turn3_num
3886 C Derivatives in gamma(i)
3887         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3888         call transpose2(auxmat2(1,1),auxmat3(1,1))
3889         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3890         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3891 C Derivatives in gamma(i+1)
3892         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3893         call transpose2(auxmat2(1,1),auxmat3(1,1))
3894         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3895         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3896      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3897 C Cartesian derivatives
3898         do l=1,3
3899 c            ghalf1=0.5d0*agg(l,1)
3900 c            ghalf2=0.5d0*agg(l,2)
3901 c            ghalf3=0.5d0*agg(l,3)
3902 c            ghalf4=0.5d0*agg(l,4)
3903           a_temp(1,1)=aggi(l,1)!+ghalf1
3904           a_temp(1,2)=aggi(l,2)!+ghalf2
3905           a_temp(2,1)=aggi(l,3)!+ghalf3
3906           a_temp(2,2)=aggi(l,4)!+ghalf4
3907           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3908           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3909      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3910           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3911           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3912           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3913           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3914           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3915           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3916      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3917           a_temp(1,1)=aggj(l,1)!+ghalf1
3918           a_temp(1,2)=aggj(l,2)!+ghalf2
3919           a_temp(2,1)=aggj(l,3)!+ghalf3
3920           a_temp(2,2)=aggj(l,4)!+ghalf4
3921           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3922           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3923      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3924           a_temp(1,1)=aggj1(l,1)
3925           a_temp(1,2)=aggj1(l,2)
3926           a_temp(2,1)=aggj1(l,3)
3927           a_temp(2,2)=aggj1(l,4)
3928           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3929           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3930      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3931         enddo
3932       return
3933       end
3934 C-------------------------------------------------------------------------------
3935       subroutine eturn4(i,eello_turn4)
3936 C Third- and fourth-order contributions from turns
3937       implicit real*8 (a-h,o-z)
3938       include 'DIMENSIONS'
3939       include 'COMMON.IOUNITS'
3940       include 'COMMON.GEO'
3941       include 'COMMON.VAR'
3942       include 'COMMON.LOCAL'
3943       include 'COMMON.CHAIN'
3944       include 'COMMON.DERIV'
3945       include 'COMMON.INTERACT'
3946       include 'COMMON.CONTACTS'
3947       include 'COMMON.TORSION'
3948       include 'COMMON.VECTORS'
3949       include 'COMMON.FFIELD'
3950       include 'COMMON.CONTROL'
3951       dimension ggg(3)
3952       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3953      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3954      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3955       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3956      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3957       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3958      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3959      &    num_conti,j1,j2
3960       j=i+3
3961 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3962 C
3963 C               Fourth-order contributions
3964 C
3965 C                 (i+3)o----(i+4)
3966 C                     /  |
3967 C               (i+2)o   |
3968 C                     \  |
3969 C                 (i+1)o----i
3970 C
3971 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3972 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3973 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3974         a_temp(1,1)=a22
3975         a_temp(1,2)=a23
3976         a_temp(2,1)=a32
3977         a_temp(2,2)=a33
3978         iti1=itortyp(itype(i+1))
3979         iti2=itortyp(itype(i+2))
3980         iti3=itortyp(itype(i+3))
3981 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3982         call transpose2(EUg(1,1,i+1),e1t(1,1))
3983         call transpose2(Eug(1,1,i+2),e2t(1,1))
3984         call transpose2(Eug(1,1,i+3),e3t(1,1))
3985         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3986         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3987         s1=scalar2(b1(1,iti2),auxvec(1))
3988         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3989         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3990         s2=scalar2(b1(1,iti1),auxvec(1))
3991         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3992         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3993         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3994         eello_turn4=eello_turn4-(s1+s2+s3)
3995         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3996      &      'eturn4',i,j,-(s1+s2+s3)
3997 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3998 cd     &    ' eello_turn4_num',8*eello_turn4_num
3999 C Derivatives in gamma(i)
4000         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4001         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4002         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4003         s1=scalar2(b1(1,iti2),auxvec(1))
4004         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4005         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4006         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
4007 C Derivatives in gamma(i+1)
4008         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4009         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4010         s2=scalar2(b1(1,iti1),auxvec(1))
4011         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4012         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4013         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4014         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
4015 C Derivatives in gamma(i+2)
4016         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4017         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4018         s1=scalar2(b1(1,iti2),auxvec(1))
4019         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4020         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4021         s2=scalar2(b1(1,iti1),auxvec(1))
4022         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
4023         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
4024         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4025         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
4026 C Cartesian derivatives
4027 C Derivatives of this turn contributions in DC(i+2)
4028         if (j.lt.nres-1) then
4029           do l=1,3
4030             a_temp(1,1)=agg(l,1)
4031             a_temp(1,2)=agg(l,2)
4032             a_temp(2,1)=agg(l,3)
4033             a_temp(2,2)=agg(l,4)
4034             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4035             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4036             s1=scalar2(b1(1,iti2),auxvec(1))
4037             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4038             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4039             s2=scalar2(b1(1,iti1),auxvec(1))
4040             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4041             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4042             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4043             ggg(l)=-(s1+s2+s3)
4044             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
4045           enddo
4046         endif
4047 C Remaining derivatives of this turn contribution
4048         do l=1,3
4049           a_temp(1,1)=aggi(l,1)
4050           a_temp(1,2)=aggi(l,2)
4051           a_temp(2,1)=aggi(l,3)
4052           a_temp(2,2)=aggi(l,4)
4053           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4054           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4055           s1=scalar2(b1(1,iti2),auxvec(1))
4056           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4057           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4058           s2=scalar2(b1(1,iti1),auxvec(1))
4059           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4060           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4061           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4062           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
4063           a_temp(1,1)=aggi1(l,1)
4064           a_temp(1,2)=aggi1(l,2)
4065           a_temp(2,1)=aggi1(l,3)
4066           a_temp(2,2)=aggi1(l,4)
4067           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4068           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4069           s1=scalar2(b1(1,iti2),auxvec(1))
4070           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4071           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4072           s2=scalar2(b1(1,iti1),auxvec(1))
4073           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4074           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4075           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4076           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
4077           a_temp(1,1)=aggj(l,1)
4078           a_temp(1,2)=aggj(l,2)
4079           a_temp(2,1)=aggj(l,3)
4080           a_temp(2,2)=aggj(l,4)
4081           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4082           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4083           s1=scalar2(b1(1,iti2),auxvec(1))
4084           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4085           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4086           s2=scalar2(b1(1,iti1),auxvec(1))
4087           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4088           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4089           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4090           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
4091           a_temp(1,1)=aggj1(l,1)
4092           a_temp(1,2)=aggj1(l,2)
4093           a_temp(2,1)=aggj1(l,3)
4094           a_temp(2,2)=aggj1(l,4)
4095           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4096           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4097           s1=scalar2(b1(1,iti2),auxvec(1))
4098           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4099           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4100           s2=scalar2(b1(1,iti1),auxvec(1))
4101           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4102           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4103           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4104 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4105           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4106         enddo
4107       return
4108       end
4109 C-----------------------------------------------------------------------------
4110       subroutine vecpr(u,v,w)
4111       implicit real*8(a-h,o-z)
4112       dimension u(3),v(3),w(3)
4113       w(1)=u(2)*v(3)-u(3)*v(2)
4114       w(2)=-u(1)*v(3)+u(3)*v(1)
4115       w(3)=u(1)*v(2)-u(2)*v(1)
4116       return
4117       end
4118 C-----------------------------------------------------------------------------
4119       subroutine unormderiv(u,ugrad,unorm,ungrad)
4120 C This subroutine computes the derivatives of a normalized vector u, given
4121 C the derivatives computed without normalization conditions, ugrad. Returns
4122 C ungrad.
4123       implicit none
4124       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4125       double precision vec(3)
4126       double precision scalar
4127       integer i,j
4128 c      write (2,*) 'ugrad',ugrad
4129 c      write (2,*) 'u',u
4130       do i=1,3
4131         vec(i)=scalar(ugrad(1,i),u(1))
4132       enddo
4133 c      write (2,*) 'vec',vec
4134       do i=1,3
4135         do j=1,3
4136           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4137         enddo
4138       enddo
4139 c      write (2,*) 'ungrad',ungrad
4140       return
4141       end
4142 C-----------------------------------------------------------------------------
4143       subroutine escp_soft_sphere(evdw2,evdw2_14)
4144 C
4145 C This subroutine calculates the excluded-volume interaction energy between
4146 C peptide-group centers and side chains and its gradient in virtual-bond and
4147 C side-chain vectors.
4148 C
4149       implicit real*8 (a-h,o-z)
4150       include 'DIMENSIONS'
4151       include 'COMMON.GEO'
4152       include 'COMMON.VAR'
4153       include 'COMMON.LOCAL'
4154       include 'COMMON.CHAIN'
4155       include 'COMMON.DERIV'
4156       include 'COMMON.INTERACT'
4157       include 'COMMON.FFIELD'
4158       include 'COMMON.IOUNITS'
4159       include 'COMMON.CONTROL'
4160       dimension ggg(3)
4161       evdw2=0.0D0
4162       evdw2_14=0.0d0
4163       r0_scp=4.5d0
4164 cd    print '(a)','Enter ESCP'
4165 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4166       do i=iatscp_s,iatscp_e
4167         iteli=itel(i)
4168         xi=0.5D0*(c(1,i)+c(1,i+1))
4169         yi=0.5D0*(c(2,i)+c(2,i+1))
4170         zi=0.5D0*(c(3,i)+c(3,i+1))
4171
4172         do iint=1,nscp_gr(i)
4173
4174         do j=iscpstart(i,iint),iscpend(i,iint)
4175           itypj=itype(j)
4176 C Uncomment following three lines for SC-p interactions
4177 c         xj=c(1,nres+j)-xi
4178 c         yj=c(2,nres+j)-yi
4179 c         zj=c(3,nres+j)-zi
4180 C Uncomment following three lines for Ca-p interactions
4181           xj=c(1,j)-xi
4182           yj=c(2,j)-yi
4183           zj=c(3,j)-zi
4184           rij=xj*xj+yj*yj+zj*zj
4185           r0ij=r0_scp
4186           r0ijsq=r0ij*r0ij
4187           if (rij.lt.r0ijsq) then
4188             evdwij=0.25d0*(rij-r0ijsq)**2
4189             fac=rij-r0ijsq
4190           else
4191             evdwij=0.0d0
4192             fac=0.0d0
4193           endif
4194           evdw2=evdw2+evdwij
4195 C
4196 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4197 C
4198           ggg(1)=xj*fac
4199           ggg(2)=yj*fac
4200           ggg(3)=zj*fac
4201 cgrad          if (j.lt.i) then
4202 cd          write (iout,*) 'j<i'
4203 C Uncomment following three lines for SC-p interactions
4204 c           do k=1,3
4205 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4206 c           enddo
4207 cgrad          else
4208 cd          write (iout,*) 'j>i'
4209 cgrad            do k=1,3
4210 cgrad              ggg(k)=-ggg(k)
4211 C Uncomment following line for SC-p interactions
4212 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4213 cgrad            enddo
4214 cgrad          endif
4215 cgrad          do k=1,3
4216 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4217 cgrad          enddo
4218 cgrad          kstart=min0(i+1,j)
4219 cgrad          kend=max0(i-1,j-1)
4220 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4221 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4222 cgrad          do k=kstart,kend
4223 cgrad            do l=1,3
4224 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4225 cgrad            enddo
4226 cgrad          enddo
4227           do k=1,3
4228             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4229             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4230           enddo
4231         enddo
4232
4233         enddo ! iint
4234       enddo ! i
4235       return
4236       end
4237 C-----------------------------------------------------------------------------
4238       subroutine escp(evdw2,evdw2_14)
4239 C
4240 C This subroutine calculates the excluded-volume interaction energy between
4241 C peptide-group centers and side chains and its gradient in virtual-bond and
4242 C side-chain vectors.
4243 C
4244       implicit real*8 (a-h,o-z)
4245       include 'DIMENSIONS'
4246       include 'COMMON.GEO'
4247       include 'COMMON.VAR'
4248       include 'COMMON.LOCAL'
4249       include 'COMMON.CHAIN'
4250       include 'COMMON.DERIV'
4251       include 'COMMON.INTERACT'
4252       include 'COMMON.FFIELD'
4253       include 'COMMON.IOUNITS'
4254       include 'COMMON.CONTROL'
4255       dimension ggg(3)
4256       evdw2=0.0D0
4257       evdw2_14=0.0d0
4258 cd    print '(a)','Enter ESCP'
4259 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4260       do i=iatscp_s,iatscp_e
4261         iteli=itel(i)
4262         xi=0.5D0*(c(1,i)+c(1,i+1))
4263         yi=0.5D0*(c(2,i)+c(2,i+1))
4264         zi=0.5D0*(c(3,i)+c(3,i+1))
4265
4266         do iint=1,nscp_gr(i)
4267
4268         do j=iscpstart(i,iint),iscpend(i,iint)
4269           itypj=itype(j)
4270 C Uncomment following three lines for SC-p interactions
4271 c         xj=c(1,nres+j)-xi
4272 c         yj=c(2,nres+j)-yi
4273 c         zj=c(3,nres+j)-zi
4274 C Uncomment following three lines for Ca-p interactions
4275           xj=c(1,j)-xi
4276           yj=c(2,j)-yi
4277           zj=c(3,j)-zi
4278           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4279           fac=rrij**expon2
4280           e1=fac*fac*aad(itypj,iteli)
4281           e2=fac*bad(itypj,iteli)
4282           if (iabs(j-i) .le. 2) then
4283             e1=scal14*e1
4284             e2=scal14*e2
4285             evdw2_14=evdw2_14+e1+e2
4286           endif
4287           evdwij=e1+e2
4288           evdw2=evdw2+evdwij
4289           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4290      &        'evdw2',i,j,evdwij
4291 C
4292 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4293 C
4294           fac=-(evdwij+e1)*rrij
4295           ggg(1)=xj*fac
4296           ggg(2)=yj*fac
4297           ggg(3)=zj*fac
4298 cgrad          if (j.lt.i) then
4299 cd          write (iout,*) 'j<i'
4300 C Uncomment following three lines for SC-p interactions
4301 c           do k=1,3
4302 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4303 c           enddo
4304 cgrad          else
4305 cd          write (iout,*) 'j>i'
4306 cgrad            do k=1,3
4307 cgrad              ggg(k)=-ggg(k)
4308 C Uncomment following line for SC-p interactions
4309 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4310 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4311 cgrad            enddo
4312 cgrad          endif
4313 cgrad          do k=1,3
4314 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4315 cgrad          enddo
4316 cgrad          kstart=min0(i+1,j)
4317 cgrad          kend=max0(i-1,j-1)
4318 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4319 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4320 cgrad          do k=kstart,kend
4321 cgrad            do l=1,3
4322 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4323 cgrad            enddo
4324 cgrad          enddo
4325           do k=1,3
4326             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4327             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4328           enddo
4329         enddo
4330
4331         enddo ! iint
4332       enddo ! i
4333       do i=1,nct
4334         do j=1,3
4335           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4336           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4337           gradx_scp(j,i)=expon*gradx_scp(j,i)
4338         enddo
4339       enddo
4340 C******************************************************************************
4341 C
4342 C                              N O T E !!!
4343 C
4344 C To save time the factor EXPON has been extracted from ALL components
4345 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4346 C use!
4347 C
4348 C******************************************************************************
4349       return
4350       end
4351 C--------------------------------------------------------------------------
4352       subroutine edis(ehpb)
4353 C
4354 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4355 C
4356       implicit real*8 (a-h,o-z)
4357       include 'DIMENSIONS'
4358       include 'COMMON.SBRIDGE'
4359       include 'COMMON.CHAIN'
4360       include 'COMMON.DERIV'
4361       include 'COMMON.VAR'
4362       include 'COMMON.INTERACT'
4363       include 'COMMON.IOUNITS'
4364       include 'COMMON.CONTROL'
4365       dimension ggg(3)
4366       ehpb=0.0D0
4367 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4368 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4369       if (link_end.eq.0) return
4370       do i=link_start,link_end
4371 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4372 C CA-CA distance used in regularization of structure.
4373         ii=ihpb(i)
4374         jj=jhpb(i)
4375 C iii and jjj point to the residues for which the distance is assigned.
4376         if (ii.gt.nres) then
4377           iii=ii-nres
4378           jjj=jj-nres
4379         else
4380           iii=ii
4381           jjj=jj
4382         endif
4383 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4384 c     &    dhpb(i),dhpb1(i),forcon(i)
4385 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4386 C    distance and angle dependent SS bond potential.
4387 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4388 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4389         if (.not.dyn_ss .and. i.le.nss) then
4390 C 15/02/13 CC dynamic SSbond - additional check
4391          if (ii.gt.nres
4392      &       .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4393           call ssbond_ene(iii,jjj,eij)
4394           ehpb=ehpb+2*eij
4395          endif
4396 cd          write (iout,*) "eij",eij
4397         else if (ii.gt.nres .and. jj.gt.nres) then
4398 c Restraints from contact prediction
4399           dd=dist(ii,jj)
4400           if (constr_dist.eq.11) then
4401             ehpb=ehpb+fordepth(i)**4.0d0
4402      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
4403             fac=fordepth(i)**4.0d0
4404      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
4405           if (energy_dec) write (iout,'(a6,2i5,f15.6,2f8.3)')
4406      &     "edisl",ii,jj,
4407      &     fordepth(i)**4.0d0*rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i)),
4408      &     fordepth(i),dd
4409            else
4410           if (dhpb1(i).gt.0.0d0) then
4411             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4412             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4413 c            write (iout,*) "beta nmr",
4414 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4415           else
4416             dd=dist(ii,jj)
4417             rdis=dd-dhpb(i)
4418 C Get the force constant corresponding to this distance.
4419             waga=forcon(i)
4420 C Calculate the contribution to energy.
4421             ehpb=ehpb+waga*rdis*rdis
4422 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
4423 C
4424 C Evaluate gradient.
4425 C
4426             fac=waga*rdis/dd
4427           endif
4428           endif
4429           do j=1,3
4430             ggg(j)=fac*(c(j,jj)-c(j,ii))
4431           enddo
4432           do j=1,3
4433             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4434             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4435           enddo
4436           do k=1,3
4437             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4438             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4439           enddo
4440         else
4441 C Calculate the distance between the two points and its difference from the
4442 C target distance.
4443           dd=dist(ii,jj)
4444          if (constr_dist.eq.11) then
4445             ehpb=ehpb+fordepth(i)**4.0d0
4446      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
4447             fac=fordepth(i)**4.0d0
4448      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
4449           if (energy_dec) write (iout,'(a6,2i5,f15.6,2f8.3)')
4450      7     "edisl",ii,jj,
4451      &     fordepth(i)**4.0d0*rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i)),
4452      &     fordepth(i),dd
4453 c          if (energy_dec)
4454 c     &      write (iout,*) fac
4455          else
4456           if (dhpb1(i).gt.0.0d0) then
4457             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4458             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4459 c            write (iout,*) "alph nmr",
4460 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4461           else
4462             rdis=dd-dhpb(i)
4463 C Get the force constant corresponding to this distance.
4464             waga=forcon(i)
4465 C Calculate the contribution to energy.
4466             ehpb=ehpb+waga*rdis*rdis
4467 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
4468 C
4469 C Evaluate gradient.
4470 C
4471             fac=waga*rdis/dd
4472           endif
4473          endif
4474 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4475 cd   &   ' waga=',waga,' fac=',fac
4476             do j=1,3
4477               ggg(j)=fac*(c(j,jj)-c(j,ii))
4478             enddo
4479 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4480 C If this is a SC-SC distance, we need to calculate the contributions to the
4481 C Cartesian gradient in the SC vectors (ghpbx).
4482           if (iii.lt.ii) then
4483           do j=1,3
4484             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4485             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4486           enddo
4487           endif
4488 cgrad        do j=iii,jjj-1
4489 cgrad          do k=1,3
4490 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4491 cgrad          enddo
4492 cgrad        enddo
4493           do k=1,3
4494             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4495             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4496           enddo
4497         endif
4498       enddo
4499       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
4500 c      do i=1,nres
4501 c        write (iout,*) "ghpbc",i,(ghpbc(j,i),j=1,3)
4502 c      enddo
4503       return
4504       end
4505 C--------------------------------------------------------------------------
4506       subroutine ssbond_ene(i,j,eij)
4507 C
4508 C Calculate the distance and angle dependent SS-bond potential energy
4509 C using a free-energy function derived based on RHF/6-31G** ab initio
4510 C calculations of diethyl disulfide.
4511 C
4512 C A. Liwo and U. Kozlowska, 11/24/03
4513 C
4514       implicit real*8 (a-h,o-z)
4515       include 'DIMENSIONS'
4516       include 'COMMON.SBRIDGE'
4517       include 'COMMON.CHAIN'
4518       include 'COMMON.DERIV'
4519       include 'COMMON.LOCAL'
4520       include 'COMMON.INTERACT'
4521       include 'COMMON.VAR'
4522       include 'COMMON.IOUNITS'
4523       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4524       itypi=itype(i)
4525       xi=c(1,nres+i)
4526       yi=c(2,nres+i)
4527       zi=c(3,nres+i)
4528       dxi=dc_norm(1,nres+i)
4529       dyi=dc_norm(2,nres+i)
4530       dzi=dc_norm(3,nres+i)
4531 c      dsci_inv=dsc_inv(itypi)
4532       dsci_inv=vbld_inv(nres+i)
4533       itypj=itype(j)
4534 c      dscj_inv=dsc_inv(itypj)
4535       dscj_inv=vbld_inv(nres+j)
4536       xj=c(1,nres+j)-xi
4537       yj=c(2,nres+j)-yi
4538       zj=c(3,nres+j)-zi
4539       dxj=dc_norm(1,nres+j)
4540       dyj=dc_norm(2,nres+j)
4541       dzj=dc_norm(3,nres+j)
4542       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4543       rij=dsqrt(rrij)
4544       erij(1)=xj*rij
4545       erij(2)=yj*rij
4546       erij(3)=zj*rij
4547       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4548       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4549       om12=dxi*dxj+dyi*dyj+dzi*dzj
4550       do k=1,3
4551         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4552         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4553       enddo
4554       rij=1.0d0/rij
4555       deltad=rij-d0cm
4556       deltat1=1.0d0-om1
4557       deltat2=1.0d0+om2
4558       deltat12=om2-om1+2.0d0
4559       cosphi=om12-om1*om2
4560       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4561      &  +akct*deltad*deltat12+ebr
4562      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4563 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4564 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4565 c     &  " deltat12",deltat12," eij",eij
4566       ed=2*akcm*deltad+akct*deltat12
4567       pom1=akct*deltad
4568       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4569       eom1=-2*akth*deltat1-pom1-om2*pom2
4570       eom2= 2*akth*deltat2+pom1-om1*pom2
4571       eom12=pom2
4572       do k=1,3
4573         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4574         ghpbx(k,i)=ghpbx(k,i)-ggk
4575      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4576      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4577         ghpbx(k,j)=ghpbx(k,j)+ggk
4578      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4579      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4580         ghpbc(k,i)=ghpbc(k,i)-ggk
4581         ghpbc(k,j)=ghpbc(k,j)+ggk
4582       enddo
4583 C
4584 C Calculate the components of the gradient in DC and X
4585 C
4586 cgrad      do k=i,j-1
4587 cgrad        do l=1,3
4588 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4589 cgrad        enddo
4590 cgrad      enddo
4591       return
4592       end
4593 C--------------------------------------------------------------------------
4594       subroutine ebond(estr)
4595 c
4596 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4597 c
4598       implicit real*8 (a-h,o-z)
4599       include 'DIMENSIONS'
4600       include 'COMMON.LOCAL'
4601       include 'COMMON.GEO'
4602       include 'COMMON.INTERACT'
4603       include 'COMMON.DERIV'
4604       include 'COMMON.VAR'
4605       include 'COMMON.CHAIN'
4606       include 'COMMON.IOUNITS'
4607       include 'COMMON.NAMES'
4608       include 'COMMON.FFIELD'
4609       include 'COMMON.CONTROL'
4610       include 'COMMON.SETUP'
4611       double precision u(3),ud(3)
4612       estr=0.0d0
4613       do i=ibondp_start,ibondp_end
4614         diff = vbld(i)-vbldp0
4615 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4616         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
4617      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4618         estr=estr+diff*diff
4619         do j=1,3
4620           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4621         enddo
4622 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4623       enddo
4624       estr=0.5d0*AKP*estr
4625 c
4626 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4627 c
4628       do i=ibond_start,ibond_end
4629         iti=itype(i)
4630         if (iti.ne.10) then
4631           nbi=nbondterm(iti)
4632           if (nbi.eq.1) then
4633             diff=vbld(i+nres)-vbldsc0(1,iti)
4634 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4635 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4636             if (energy_dec)  then
4637               write (iout,*)
4638      &         "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4639      &         AKSC(1,iti),AKSC(1,iti)*diff*diff
4640               call flush(iout)
4641             endif
4642             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4643             do j=1,3
4644               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4645             enddo
4646           else
4647             do j=1,nbi
4648               diff=vbld(i+nres)-vbldsc0(j,iti)
4649               ud(j)=aksc(j,iti)*diff
4650               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4651             enddo
4652             uprod=u(1)
4653             do j=2,nbi
4654               uprod=uprod*u(j)
4655             enddo
4656             usum=0.0d0
4657             usumsqder=0.0d0
4658             do j=1,nbi
4659               uprod1=1.0d0
4660               uprod2=1.0d0
4661               do k=1,nbi
4662                 if (k.ne.j) then
4663                   uprod1=uprod1*u(k)
4664                   uprod2=uprod2*u(k)*u(k)
4665                 endif
4666               enddo
4667               usum=usum+uprod1
4668               usumsqder=usumsqder+ud(j)*uprod2
4669             enddo
4670             estr=estr+uprod/usum
4671             do j=1,3
4672              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4673             enddo
4674           endif
4675         endif
4676       enddo
4677       return
4678       end
4679 #ifdef CRYST_THETA
4680 C--------------------------------------------------------------------------
4681       subroutine ebend(etheta)
4682 C
4683 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4684 C angles gamma and its derivatives in consecutive thetas and gammas.
4685 C
4686       implicit real*8 (a-h,o-z)
4687       include 'DIMENSIONS'
4688       include 'COMMON.LOCAL'
4689       include 'COMMON.GEO'
4690       include 'COMMON.INTERACT'
4691       include 'COMMON.DERIV'
4692       include 'COMMON.VAR'
4693       include 'COMMON.CHAIN'
4694       include 'COMMON.IOUNITS'
4695       include 'COMMON.NAMES'
4696       include 'COMMON.FFIELD'
4697       include 'COMMON.CONTROL'
4698       common /calcthet/ term1,term2,termm,diffak,ratak,
4699      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4700      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4701       double precision y(2),z(2)
4702       delta=0.02d0*pi
4703 c      time11=dexp(-2*time)
4704 c      time12=1.0d0
4705       etheta=0.0D0
4706 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4707       do i=ithet_start,ithet_end
4708 C Zero the energy function and its derivative at 0 or pi.
4709         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4710         it=itype(i-1)
4711         if (i.gt.3) then
4712 #ifdef OSF
4713           phii=phi(i)
4714           if (phii.ne.phii) phii=150.0
4715 #else
4716           phii=phi(i)
4717 #endif
4718           y(1)=dcos(phii)
4719           y(2)=dsin(phii)
4720         else
4721           y(1)=0.0D0
4722           y(2)=0.0D0
4723         endif
4724         if (i.lt.nres) then
4725 #ifdef OSF
4726           phii1=phi(i+1)
4727           if (phii1.ne.phii1) phii1=150.0
4728           phii1=pinorm(phii1)
4729           z(1)=cos(phii1)
4730 #else
4731           phii1=phi(i+1)
4732           z(1)=dcos(phii1)
4733 #endif
4734           z(2)=dsin(phii1)
4735         else
4736           z(1)=0.0D0
4737           z(2)=0.0D0
4738         endif
4739 C Calculate the "mean" value of theta from the part of the distribution
4740 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4741 C In following comments this theta will be referred to as t_c.
4742         thet_pred_mean=0.0d0
4743         do k=1,2
4744           athetk=athet(k,it)
4745           bthetk=bthet(k,it)
4746           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4747         enddo
4748         dthett=thet_pred_mean*ssd
4749         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4750 C Derivatives of the "mean" values in gamma1 and gamma2.
4751         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
4752         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
4753         if (theta(i).gt.pi-delta) then
4754           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4755      &         E_tc0)
4756           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4757           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4758           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4759      &        E_theta)
4760           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4761      &        E_tc)
4762         else if (theta(i).lt.delta) then
4763           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4764           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4765           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4766      &        E_theta)
4767           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4768           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4769      &        E_tc)
4770         else
4771           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4772      &        E_theta,E_tc)
4773         endif
4774         etheta=etheta+ethetai
4775         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4776      &      'ebend',i,ethetai
4777         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4778         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4779         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
4780       enddo
4781 C Ufff.... We've done all this!!!
4782       return
4783       end
4784 C---------------------------------------------------------------------------
4785       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4786      &     E_tc)
4787       implicit real*8 (a-h,o-z)
4788       include 'DIMENSIONS'
4789       include 'COMMON.LOCAL'
4790       include 'COMMON.IOUNITS'
4791       common /calcthet/ term1,term2,termm,diffak,ratak,
4792      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4793      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4794 C Calculate the contributions to both Gaussian lobes.
4795 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4796 C The "polynomial part" of the "standard deviation" of this part of
4797 C the distribution.
4798         sig=polthet(3,it)
4799         do j=2,0,-1
4800           sig=sig*thet_pred_mean+polthet(j,it)
4801         enddo
4802 C Derivative of the "interior part" of the "standard deviation of the"
4803 C gamma-dependent Gaussian lobe in t_c.
4804         sigtc=3*polthet(3,it)
4805         do j=2,1,-1
4806           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4807         enddo
4808         sigtc=sig*sigtc
4809 C Set the parameters of both Gaussian lobes of the distribution.
4810 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4811         fac=sig*sig+sigc0(it)
4812         sigcsq=fac+fac
4813         sigc=1.0D0/sigcsq
4814 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4815         sigsqtc=-4.0D0*sigcsq*sigtc
4816 c       print *,i,sig,sigtc,sigsqtc
4817 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4818         sigtc=-sigtc/(fac*fac)
4819 C Following variable is sigma(t_c)**(-2)
4820         sigcsq=sigcsq*sigcsq
4821         sig0i=sig0(it)
4822         sig0inv=1.0D0/sig0i**2
4823         delthec=thetai-thet_pred_mean
4824         delthe0=thetai-theta0i
4825         term1=-0.5D0*sigcsq*delthec*delthec
4826         term2=-0.5D0*sig0inv*delthe0*delthe0
4827 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4828 C NaNs in taking the logarithm. We extract the largest exponent which is added
4829 C to the energy (this being the log of the distribution) at the end of energy
4830 C term evaluation for this virtual-bond angle.
4831         if (term1.gt.term2) then
4832           termm=term1
4833           term2=dexp(term2-termm)
4834           term1=1.0d0
4835         else
4836           termm=term2
4837           term1=dexp(term1-termm)
4838           term2=1.0d0
4839         endif
4840 C The ratio between the gamma-independent and gamma-dependent lobes of
4841 C the distribution is a Gaussian function of thet_pred_mean too.
4842         diffak=gthet(2,it)-thet_pred_mean
4843         ratak=diffak/gthet(3,it)**2
4844         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4845 C Let's differentiate it in thet_pred_mean NOW.
4846         aktc=ak*ratak
4847 C Now put together the distribution terms to make complete distribution.
4848         termexp=term1+ak*term2
4849         termpre=sigc+ak*sig0i
4850 C Contribution of the bending energy from this theta is just the -log of
4851 C the sum of the contributions from the two lobes and the pre-exponential
4852 C factor. Simple enough, isn't it?
4853         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4854 C NOW the derivatives!!!
4855 C 6/6/97 Take into account the deformation.
4856         E_theta=(delthec*sigcsq*term1
4857      &       +ak*delthe0*sig0inv*term2)/termexp
4858         E_tc=((sigtc+aktc*sig0i)/termpre
4859      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4860      &       aktc*term2)/termexp)
4861       return
4862       end
4863 c-----------------------------------------------------------------------------
4864       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4865       implicit real*8 (a-h,o-z)
4866       include 'DIMENSIONS'
4867       include 'COMMON.LOCAL'
4868       include 'COMMON.IOUNITS'
4869       common /calcthet/ term1,term2,termm,diffak,ratak,
4870      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4871      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4872       delthec=thetai-thet_pred_mean
4873       delthe0=thetai-theta0i
4874 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4875       t3 = thetai-thet_pred_mean
4876       t6 = t3**2
4877       t9 = term1
4878       t12 = t3*sigcsq
4879       t14 = t12+t6*sigsqtc
4880       t16 = 1.0d0
4881       t21 = thetai-theta0i
4882       t23 = t21**2
4883       t26 = term2
4884       t27 = t21*t26
4885       t32 = termexp
4886       t40 = t32**2
4887       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4888      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4889      & *(-t12*t9-ak*sig0inv*t27)
4890       return
4891       end
4892 #else
4893 C--------------------------------------------------------------------------
4894       subroutine ebend(etheta)
4895 C
4896 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4897 C angles gamma and its derivatives in consecutive thetas and gammas.
4898 C ab initio-derived potentials from
4899 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4900 C
4901       implicit real*8 (a-h,o-z)
4902       include 'DIMENSIONS'
4903       include 'COMMON.LOCAL'
4904       include 'COMMON.GEO'
4905       include 'COMMON.INTERACT'
4906       include 'COMMON.DERIV'
4907       include 'COMMON.VAR'
4908       include 'COMMON.CHAIN'
4909       include 'COMMON.IOUNITS'
4910       include 'COMMON.NAMES'
4911       include 'COMMON.FFIELD'
4912       include 'COMMON.CONTROL'
4913       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4914      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4915      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4916      & sinph1ph2(maxdouble,maxdouble)
4917       logical lprn /.false./, lprn1 /.false./
4918       etheta=0.0D0
4919 c      write (iout,*) "EBEND ithet_start",ithet_start,
4920 c     &     " ithet_end",ithet_end
4921       do i=ithet_start,ithet_end
4922         if ((itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
4923      &(itype(i).eq.ntyp1)) cycle
4924         dethetai=0.0d0
4925         dephii=0.0d0
4926         dephii1=0.0d0
4927         theti2=0.5d0*theta(i)
4928         ityp2=ithetyp(itype(i-1))
4929         do k=1,nntheterm
4930           coskt(k)=dcos(k*theti2)
4931           sinkt(k)=dsin(k*theti2)
4932         enddo
4933 C        if (i.gt.3) then
4934         if (i.gt.3 .and. itype(imax0(i-3,1)).ne.ntyp1) then
4935 #ifdef OSF
4936           phii=phi(i)
4937           if (phii.ne.phii) phii=150.0
4938 #else
4939           phii=phi(i)
4940 #endif
4941           ityp1=ithetyp(itype(i-2))
4942           do k=1,nsingle
4943             cosph1(k)=dcos(k*phii)
4944             sinph1(k)=dsin(k*phii)
4945           enddo
4946         else
4947           phii=0.0d0
4948           ityp1=ithetyp(itype(i-2))
4949           do k=1,nsingle
4950             cosph1(k)=0.0d0
4951             sinph1(k)=0.0d0
4952           enddo
4953         endif
4954         if ((i.lt.nres).and. itype(i+1).ne.ntyp1) then
4955 #ifdef OSF
4956           phii1=phi(i+1)
4957           if (phii1.ne.phii1) phii1=150.0
4958           phii1=pinorm(phii1)
4959 #else
4960           phii1=phi(i+1)
4961 #endif
4962           ityp3=ithetyp(itype(i))
4963           do k=1,nsingle
4964             cosph2(k)=dcos(k*phii1)
4965             sinph2(k)=dsin(k*phii1)
4966           enddo
4967         else
4968           phii1=0.0d0
4969           ityp3=ithetyp(itype(i))
4970           do k=1,nsingle
4971             cosph2(k)=0.0d0
4972             sinph2(k)=0.0d0
4973           enddo
4974         endif
4975         ethetai=aa0thet(ityp1,ityp2,ityp3)
4976         do k=1,ndouble
4977           do l=1,k-1
4978             ccl=cosph1(l)*cosph2(k-l)
4979             ssl=sinph1(l)*sinph2(k-l)
4980             scl=sinph1(l)*cosph2(k-l)
4981             csl=cosph1(l)*sinph2(k-l)
4982             cosph1ph2(l,k)=ccl-ssl
4983             cosph1ph2(k,l)=ccl+ssl
4984             sinph1ph2(l,k)=scl+csl
4985             sinph1ph2(k,l)=scl-csl
4986           enddo
4987         enddo
4988         if (lprn) then
4989         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4990      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4991         write (iout,*) "coskt and sinkt"
4992         do k=1,nntheterm
4993           write (iout,*) k,coskt(k),sinkt(k)
4994         enddo
4995         endif
4996         do k=1,ntheterm
4997           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4998           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4999      &      *coskt(k)
5000           if (lprn)
5001      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
5002      &     " ethetai",ethetai
5003         enddo
5004         if (lprn) then
5005         write (iout,*) "cosph and sinph"
5006         do k=1,nsingle
5007           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5008         enddo
5009         write (iout,*) "cosph1ph2 and sinph2ph2"
5010         do k=2,ndouble
5011           do l=1,k-1
5012             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
5013      &         sinph1ph2(l,k),sinph1ph2(k,l)
5014           enddo
5015         enddo
5016         write(iout,*) "ethetai",ethetai
5017         endif
5018         do m=1,ntheterm2
5019           do k=1,nsingle
5020             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
5021      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
5022      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
5023      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
5024             ethetai=ethetai+sinkt(m)*aux
5025             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5026             dephii=dephii+k*sinkt(m)*(
5027      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
5028      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
5029             dephii1=dephii1+k*sinkt(m)*(
5030      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
5031      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
5032             if (lprn)
5033      &      write (iout,*) "m",m," k",k," bbthet",
5034      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
5035      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
5036      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
5037      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
5038           enddo
5039         enddo
5040         if (lprn)
5041      &  write(iout,*) "ethetai",ethetai
5042         do m=1,ntheterm3
5043           do k=2,ndouble
5044             do l=1,k-1
5045               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
5046      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
5047      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
5048      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
5049               ethetai=ethetai+sinkt(m)*aux
5050               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5051               dephii=dephii+l*sinkt(m)*(
5052      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
5053      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
5054      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
5055      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
5056               dephii1=dephii1+(k-l)*sinkt(m)*(
5057      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
5058      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
5059      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
5060      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
5061               if (lprn) then
5062               write (iout,*) "m",m," k",k," l",l," ffthet",
5063      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
5064      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
5065      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
5066      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
5067               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5068      &            cosph1ph2(k,l)*sinkt(m),
5069      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5070               endif
5071             enddo
5072           enddo
5073         enddo
5074 10      continue
5075 c        lprn1=.true.
5076         if (lprn1) write (iout,'(a4,i2,3f8.1,9h ethetai ,f10.5)')
5077      &  'ebe', i,theta(i)*rad2deg,phii*rad2deg,
5078      &   phii1*rad2deg,ethetai
5079 c        lprn1=.false.
5080         etheta=etheta+ethetai
5081         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5082      &      'ebend',i,ethetai
5083         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5084         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5085         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
5086       enddo
5087       return
5088       end
5089 #endif
5090 #ifdef CRYST_SC
5091 c-----------------------------------------------------------------------------
5092       subroutine esc(escloc)
5093 C Calculate the local energy of a side chain and its derivatives in the
5094 C corresponding virtual-bond valence angles THETA and the spherical angles
5095 C ALPHA and OMEGA.
5096       implicit real*8 (a-h,o-z)
5097       include 'DIMENSIONS'
5098       include 'COMMON.GEO'
5099       include 'COMMON.LOCAL'
5100       include 'COMMON.VAR'
5101       include 'COMMON.INTERACT'
5102       include 'COMMON.DERIV'
5103       include 'COMMON.CHAIN'
5104       include 'COMMON.IOUNITS'
5105       include 'COMMON.NAMES'
5106       include 'COMMON.FFIELD'
5107       include 'COMMON.CONTROL'
5108       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5109      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5110       common /sccalc/ time11,time12,time112,theti,it,nlobit
5111       delta=0.02d0*pi
5112       escloc=0.0D0
5113 c     write (iout,'(a)') 'ESC'
5114       do i=loc_start,loc_end
5115         it=itype(i)
5116         if (it.eq.10) goto 1
5117         nlobit=nlob(it)
5118 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5119 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5120         theti=theta(i+1)-pipol
5121         x(1)=dtan(theti)
5122         x(2)=alph(i)
5123         x(3)=omeg(i)
5124
5125         if (x(2).gt.pi-delta) then
5126           xtemp(1)=x(1)
5127           xtemp(2)=pi-delta
5128           xtemp(3)=x(3)
5129           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5130           xtemp(2)=pi
5131           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5132           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5133      &        escloci,dersc(2))
5134           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5135      &        ddersc0(1),dersc(1))
5136           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5137      &        ddersc0(3),dersc(3))
5138           xtemp(2)=pi-delta
5139           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5140           xtemp(2)=pi
5141           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5142           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5143      &            dersc0(2),esclocbi,dersc02)
5144           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5145      &            dersc12,dersc01)
5146           call splinthet(x(2),0.5d0*delta,ss,ssd)
5147           dersc0(1)=dersc01
5148           dersc0(2)=dersc02
5149           dersc0(3)=0.0d0
5150           do k=1,3
5151             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5152           enddo
5153           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5154 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5155 c    &             esclocbi,ss,ssd
5156           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5157 c         escloci=esclocbi
5158 c         write (iout,*) escloci
5159         else if (x(2).lt.delta) then
5160           xtemp(1)=x(1)
5161           xtemp(2)=delta
5162           xtemp(3)=x(3)
5163           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5164           xtemp(2)=0.0d0
5165           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5166           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5167      &        escloci,dersc(2))
5168           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5169      &        ddersc0(1),dersc(1))
5170           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5171      &        ddersc0(3),dersc(3))
5172           xtemp(2)=delta
5173           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5174           xtemp(2)=0.0d0
5175           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5176           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5177      &            dersc0(2),esclocbi,dersc02)
5178           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5179      &            dersc12,dersc01)
5180           dersc0(1)=dersc01
5181           dersc0(2)=dersc02
5182           dersc0(3)=0.0d0
5183           call splinthet(x(2),0.5d0*delta,ss,ssd)
5184           do k=1,3
5185             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5186           enddo
5187           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5188 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5189 c    &             esclocbi,ss,ssd
5190           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5191 c         write (iout,*) escloci
5192         else
5193           call enesc(x,escloci,dersc,ddummy,.false.)
5194         endif
5195
5196         escloc=escloc+escloci
5197         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5198      &     'escloc',i,escloci
5199 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5200
5201         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5202      &   wscloc*dersc(1)
5203         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5204         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5205     1   continue
5206       enddo
5207       return
5208       end
5209 C---------------------------------------------------------------------------
5210       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5211       implicit real*8 (a-h,o-z)
5212       include 'DIMENSIONS'
5213       include 'COMMON.GEO'
5214       include 'COMMON.LOCAL'
5215       include 'COMMON.IOUNITS'
5216       common /sccalc/ time11,time12,time112,theti,it,nlobit
5217       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5218       double precision contr(maxlob,-1:1)
5219       logical mixed
5220 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5221         escloc_i=0.0D0
5222         do j=1,3
5223           dersc(j)=0.0D0
5224           if (mixed) ddersc(j)=0.0d0
5225         enddo
5226         x3=x(3)
5227
5228 C Because of periodicity of the dependence of the SC energy in omega we have
5229 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5230 C To avoid underflows, first compute & store the exponents.
5231
5232         do iii=-1,1
5233
5234           x(3)=x3+iii*dwapi
5235
5236           do j=1,nlobit
5237             do k=1,3
5238               z(k)=x(k)-censc(k,j,it)
5239             enddo
5240             do k=1,3
5241               Axk=0.0D0
5242               do l=1,3
5243                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5244               enddo
5245               Ax(k,j,iii)=Axk
5246             enddo
5247             expfac=0.0D0
5248             do k=1,3
5249               expfac=expfac+Ax(k,j,iii)*z(k)
5250             enddo
5251             contr(j,iii)=expfac
5252           enddo ! j
5253
5254         enddo ! iii
5255
5256         x(3)=x3
5257 C As in the case of ebend, we want to avoid underflows in exponentiation and
5258 C subsequent NaNs and INFs in energy calculation.
5259 C Find the largest exponent
5260         emin=contr(1,-1)
5261         do iii=-1,1
5262           do j=1,nlobit
5263             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5264           enddo
5265         enddo
5266         emin=0.5D0*emin
5267 cd      print *,'it=',it,' emin=',emin
5268
5269 C Compute the contribution to SC energy and derivatives
5270         do iii=-1,1
5271
5272           do j=1,nlobit
5273 #ifdef OSF
5274             adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin
5275             if(adexp.ne.adexp) adexp=1.0
5276             expfac=dexp(adexp)
5277 #else
5278             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
5279 #endif
5280 cd          print *,'j=',j,' expfac=',expfac
5281             escloc_i=escloc_i+expfac
5282             do k=1,3
5283               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5284             enddo
5285             if (mixed) then
5286               do k=1,3,2
5287                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5288      &            +gaussc(k,2,j,it))*expfac
5289               enddo
5290             endif
5291           enddo
5292
5293         enddo ! iii
5294
5295         dersc(1)=dersc(1)/cos(theti)**2
5296         ddersc(1)=ddersc(1)/cos(theti)**2
5297         ddersc(3)=ddersc(3)
5298
5299         escloci=-(dlog(escloc_i)-emin)
5300         do j=1,3
5301           dersc(j)=dersc(j)/escloc_i
5302         enddo
5303         if (mixed) then
5304           do j=1,3,2
5305             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5306           enddo
5307         endif
5308       return
5309       end
5310 C------------------------------------------------------------------------------
5311       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5312       implicit real*8 (a-h,o-z)
5313       include 'DIMENSIONS'
5314       include 'COMMON.GEO'
5315       include 'COMMON.LOCAL'
5316       include 'COMMON.IOUNITS'
5317       common /sccalc/ time11,time12,time112,theti,it,nlobit
5318       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5319       double precision contr(maxlob)
5320       logical mixed
5321
5322       escloc_i=0.0D0
5323
5324       do j=1,3
5325         dersc(j)=0.0D0
5326       enddo
5327
5328       do j=1,nlobit
5329         do k=1,2
5330           z(k)=x(k)-censc(k,j,it)
5331         enddo
5332         z(3)=dwapi
5333         do k=1,3
5334           Axk=0.0D0
5335           do l=1,3
5336             Axk=Axk+gaussc(l,k,j,it)*z(l)
5337           enddo
5338           Ax(k,j)=Axk
5339         enddo
5340         expfac=0.0D0
5341         do k=1,3
5342           expfac=expfac+Ax(k,j)*z(k)
5343         enddo
5344         contr(j)=expfac
5345       enddo ! j
5346
5347 C As in the case of ebend, we want to avoid underflows in exponentiation and
5348 C subsequent NaNs and INFs in energy calculation.
5349 C Find the largest exponent
5350       emin=contr(1)
5351       do j=1,nlobit
5352         if (emin.gt.contr(j)) emin=contr(j)
5353       enddo
5354       emin=0.5D0*emin
5355
5356 C Compute the contribution to SC energy and derivatives
5357
5358       dersc12=0.0d0
5359       do j=1,nlobit
5360         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
5361         escloc_i=escloc_i+expfac
5362         do k=1,2
5363           dersc(k)=dersc(k)+Ax(k,j)*expfac
5364         enddo
5365         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5366      &            +gaussc(1,2,j,it))*expfac
5367         dersc(3)=0.0d0
5368       enddo
5369
5370       dersc(1)=dersc(1)/cos(theti)**2
5371       dersc12=dersc12/cos(theti)**2
5372       escloci=-(dlog(escloc_i)-emin)
5373       do j=1,2
5374         dersc(j)=dersc(j)/escloc_i
5375       enddo
5376       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5377       return
5378       end
5379 #else
5380 c----------------------------------------------------------------------------------
5381       subroutine esc(escloc)
5382 C Calculate the local energy of a side chain and its derivatives in the
5383 C corresponding virtual-bond valence angles THETA and the spherical angles
5384 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5385 C added by Urszula Kozlowska. 07/11/2007
5386 C
5387       implicit real*8 (a-h,o-z)
5388       include 'DIMENSIONS'
5389       include 'COMMON.GEO'
5390       include 'COMMON.LOCAL'
5391       include 'COMMON.VAR'
5392       include 'COMMON.SCROT'
5393       include 'COMMON.INTERACT'
5394       include 'COMMON.DERIV'
5395       include 'COMMON.CHAIN'
5396       include 'COMMON.IOUNITS'
5397       include 'COMMON.NAMES'
5398       include 'COMMON.FFIELD'
5399       include 'COMMON.CONTROL'
5400       include 'COMMON.VECTORS'
5401       double precision x_prime(3),y_prime(3),z_prime(3)
5402      &    , sumene,dsc_i,dp2_i,x(65),
5403      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5404      &    de_dxx,de_dyy,de_dzz,de_dt
5405       double precision s1_t,s1_6_t,s2_t,s2_6_t
5406       double precision
5407      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5408      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5409      & dt_dCi(3),dt_dCi1(3)
5410       common /sccalc/ time11,time12,time112,theti,it,nlobit
5411       delta=0.02d0*pi
5412       escloc=0.0D0
5413 c      write(iout,*) "ESC: loc_start",loc_start," loc_end",loc_end
5414       do i=loc_start,loc_end
5415         costtab(i+1) =dcos(theta(i+1))
5416         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5417         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5418         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5419         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5420         cosfac=dsqrt(cosfac2)
5421         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5422         sinfac=dsqrt(sinfac2)
5423         it=itype(i)
5424         if (it.eq.10) goto 1
5425 c
5426 C  Compute the axes of tghe local cartesian coordinates system; store in
5427 c   x_prime, y_prime and z_prime
5428 c
5429         do j=1,3
5430           x_prime(j) = 0.00
5431           y_prime(j) = 0.00
5432           z_prime(j) = 0.00
5433         enddo
5434 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5435 C     &   dc_norm(3,i+nres)
5436         do j = 1,3
5437           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5438           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5439         enddo
5440         do j = 1,3
5441           z_prime(j) = -uz(j,i-1)
5442         enddo
5443 c       write (2,*) "i",i
5444 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5445 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5446 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5447 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5448 c      & " xy",scalar(x_prime(1),y_prime(1)),
5449 c      & " xz",scalar(x_prime(1),z_prime(1)),
5450 c      & " yy",scalar(y_prime(1),y_prime(1)),
5451 c      & " yz",scalar(y_prime(1),z_prime(1)),
5452 c      & " zz",scalar(z_prime(1),z_prime(1))
5453 c
5454 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5455 C to local coordinate system. Store in xx, yy, zz.
5456 c
5457         xx=0.0d0
5458         yy=0.0d0
5459         zz=0.0d0
5460         do j = 1,3
5461           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5462           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5463           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5464         enddo
5465
5466         xxtab(i)=xx
5467         yytab(i)=yy
5468         zztab(i)=zz
5469 C
5470 C Compute the energy of the ith side cbain
5471 C
5472 c        write (2,*) "xx",xx," yy",yy," zz",zz
5473         it=itype(i)
5474         do j = 1,65
5475           x(j) = sc_parmin(j,it)
5476         enddo
5477 #ifdef CHECK_COORD
5478 Cc diagnostics - remove later
5479         xx1 = dcos(alph(2))
5480         yy1 = dsin(alph(2))*dcos(omeg(2))
5481         zz1 = -dsin(alph(2))*dsin(omeg(2))
5482         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5483      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5484      &    xx1,yy1,zz1
5485 C,"  --- ", xx_w,yy_w,zz_w
5486 c end diagnostics
5487 #endif
5488         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5489      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5490      &   + x(10)*yy*zz
5491         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5492      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5493      & + x(20)*yy*zz
5494         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5495      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5496      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5497      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5498      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5499      &  +x(40)*xx*yy*zz
5500         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5501      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5502      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5503      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5504      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5505      &  +x(60)*xx*yy*zz
5506         dsc_i   = 0.743d0+x(61)
5507         dp2_i   = 1.9d0+x(62)
5508         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5509      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5510         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5511      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5512         s1=(1+x(63))/(0.1d0 + dscp1)
5513         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5514         s2=(1+x(65))/(0.1d0 + dscp2)
5515         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5516         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5517      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5518 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5519 c     &   sumene4,
5520 c     &   dscp1,dscp2,sumene
5521 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5522         escloc = escloc + sumene
5523 c        write (2,*) "i",i," escloc",sumene,escloc
5524 #ifdef DEBUG
5525 C
5526 C This section to check the numerical derivatives of the energy of ith side
5527 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5528 C #define DEBUG in the code to turn it on.
5529 C
5530         write (2,*) "sumene               =",sumene
5531         aincr=1.0d-7
5532         xxsave=xx
5533         xx=xx+aincr
5534         write (2,*) xx,yy,zz
5535         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5536         de_dxx_num=(sumenep-sumene)/aincr
5537         xx=xxsave
5538         write (2,*) "xx+ sumene from enesc=",sumenep
5539         yysave=yy
5540         yy=yy+aincr
5541         write (2,*) xx,yy,zz
5542         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5543         de_dyy_num=(sumenep-sumene)/aincr
5544         yy=yysave
5545         write (2,*) "yy+ sumene from enesc=",sumenep
5546         zzsave=zz
5547         zz=zz+aincr
5548         write (2,*) xx,yy,zz
5549         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5550         de_dzz_num=(sumenep-sumene)/aincr
5551         zz=zzsave
5552         write (2,*) "zz+ sumene from enesc=",sumenep
5553         costsave=cost2tab(i+1)
5554         sintsave=sint2tab(i+1)
5555         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5556         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5557         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5558         de_dt_num=(sumenep-sumene)/aincr
5559         write (2,*) " t+ sumene from enesc=",sumenep
5560         cost2tab(i+1)=costsave
5561         sint2tab(i+1)=sintsave
5562 C End of diagnostics section.
5563 #endif
5564 C
5565 C Compute the gradient of esc
5566 C
5567         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5568         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5569         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5570         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5571         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5572         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5573         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5574         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5575         pom1=(sumene3*sint2tab(i+1)+sumene1)
5576      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5577         pom2=(sumene4*cost2tab(i+1)+sumene2)
5578      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5579         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5580         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5581      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5582      &  +x(40)*yy*zz
5583         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5584         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5585      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5586      &  +x(60)*yy*zz
5587         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5588      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5589      &        +(pom1+pom2)*pom_dx
5590 #ifdef DEBUG
5591         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5592 #endif
5593 C
5594         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5595         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5596      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5597      &  +x(40)*xx*zz
5598         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5599         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5600      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5601      &  +x(59)*zz**2 +x(60)*xx*zz
5602         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5603      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5604      &        +(pom1-pom2)*pom_dy
5605 #ifdef DEBUG
5606         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5607 #endif
5608 C
5609         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5610      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5611      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5612      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5613      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5614      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5615      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5616      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5617 #ifdef DEBUG
5618         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5619 #endif
5620 C
5621         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5622      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5623      &  +pom1*pom_dt1+pom2*pom_dt2
5624 #ifdef DEBUG
5625         write(2,*), "de_dt = ", de_dt,de_dt_num
5626 #endif
5627 c
5628 C
5629        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5630        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5631        cosfac2xx=cosfac2*xx
5632        sinfac2yy=sinfac2*yy
5633        do k = 1,3
5634          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5635      &      vbld_inv(i+1)
5636          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5637      &      vbld_inv(i)
5638          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5639          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5640 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5641 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5642 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5643 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5644          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5645          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5646          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5647          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5648          dZZ_Ci1(k)=0.0d0
5649          dZZ_Ci(k)=0.0d0
5650          do j=1,3
5651            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5652            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5653          enddo
5654
5655          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5656          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5657          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5658 c
5659          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5660          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5661        enddo
5662
5663        do k=1,3
5664          dXX_Ctab(k,i)=dXX_Ci(k)
5665          dXX_C1tab(k,i)=dXX_Ci1(k)
5666          dYY_Ctab(k,i)=dYY_Ci(k)
5667          dYY_C1tab(k,i)=dYY_Ci1(k)
5668          dZZ_Ctab(k,i)=dZZ_Ci(k)
5669          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5670          dXX_XYZtab(k,i)=dXX_XYZ(k)
5671          dYY_XYZtab(k,i)=dYY_XYZ(k)
5672          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5673        enddo
5674
5675        do k = 1,3
5676 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5677 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5678 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5679 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5680 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5681 c     &    dt_dci(k)
5682 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5683 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5684          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5685      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5686          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5687      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5688          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5689      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5690        enddo
5691 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5692 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5693
5694 C to check gradient call subroutine check_grad
5695
5696     1 continue
5697       enddo
5698       return
5699       end
5700 c------------------------------------------------------------------------------
5701       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5702       implicit none
5703       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5704      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5705       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5706      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5707      &   + x(10)*yy*zz
5708       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5709      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5710      & + x(20)*yy*zz
5711       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5712      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5713      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5714      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5715      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5716      &  +x(40)*xx*yy*zz
5717       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5718      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5719      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5720      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5721      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5722      &  +x(60)*xx*yy*zz
5723       dsc_i   = 0.743d0+x(61)
5724       dp2_i   = 1.9d0+x(62)
5725       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5726      &          *(xx*cost2+yy*sint2))
5727       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5728      &          *(xx*cost2-yy*sint2))
5729       s1=(1+x(63))/(0.1d0 + dscp1)
5730       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5731       s2=(1+x(65))/(0.1d0 + dscp2)
5732       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5733       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5734      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5735       enesc=sumene
5736       return
5737       end
5738 #endif
5739 c------------------------------------------------------------------------------
5740       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5741 C
5742 C This procedure calculates two-body contact function g(rij) and its derivative:
5743 C
5744 C           eps0ij                                     !       x < -1
5745 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5746 C            0                                         !       x > 1
5747 C
5748 C where x=(rij-r0ij)/delta
5749 C
5750 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5751 C
5752       implicit none
5753       double precision rij,r0ij,eps0ij,fcont,fprimcont
5754       double precision x,x2,x4,delta
5755 c     delta=0.02D0*r0ij
5756 c      delta=0.2D0*r0ij
5757       x=(rij-r0ij)/delta
5758       if (x.lt.-1.0D0) then
5759         fcont=eps0ij
5760         fprimcont=0.0D0
5761       else if (x.le.1.0D0) then
5762         x2=x*x
5763         x4=x2*x2
5764         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5765         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5766       else
5767         fcont=0.0D0
5768         fprimcont=0.0D0
5769       endif
5770       return
5771       end
5772 c------------------------------------------------------------------------------
5773       subroutine splinthet(theti,delta,ss,ssder)
5774       implicit real*8 (a-h,o-z)
5775       include 'DIMENSIONS'
5776       include 'COMMON.VAR'
5777       include 'COMMON.GEO'
5778       thetup=pi-delta
5779       thetlow=delta
5780       if (theti.gt.pipol) then
5781         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5782       else
5783         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5784         ssder=-ssder
5785       endif
5786       return
5787       end
5788 c------------------------------------------------------------------------------
5789       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5790       implicit none
5791       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5792       double precision ksi,ksi2,ksi3,a1,a2,a3
5793       a1=fprim0*delta/(f1-f0)
5794       a2=3.0d0-2.0d0*a1
5795       a3=a1-2.0d0
5796       ksi=(x-x0)/delta
5797       ksi2=ksi*ksi
5798       ksi3=ksi2*ksi
5799       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5800       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5801       return
5802       end
5803 c------------------------------------------------------------------------------
5804       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5805       implicit none
5806       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5807       double precision ksi,ksi2,ksi3,a1,a2,a3
5808       ksi=(x-x0)/delta
5809       ksi2=ksi*ksi
5810       ksi3=ksi2*ksi
5811       a1=fprim0x*delta
5812       a2=3*(f1x-f0x)-2*fprim0x*delta
5813       a3=fprim0x*delta-2*(f1x-f0x)
5814       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5815       return
5816       end
5817 C-----------------------------------------------------------------------------
5818 #ifdef CRYST_TOR
5819 C-----------------------------------------------------------------------------
5820       subroutine etor(etors,edihcnstr)
5821       implicit real*8 (a-h,o-z)
5822       include 'DIMENSIONS'
5823       include 'COMMON.VAR'
5824       include 'COMMON.GEO'
5825       include 'COMMON.LOCAL'
5826       include 'COMMON.TORSION'
5827       include 'COMMON.INTERACT'
5828       include 'COMMON.DERIV'
5829       include 'COMMON.CHAIN'
5830       include 'COMMON.NAMES'
5831       include 'COMMON.IOUNITS'
5832       include 'COMMON.FFIELD'
5833       include 'COMMON.TORCNSTR'
5834       include 'COMMON.CONTROL'
5835       logical lprn
5836 C Set lprn=.true. for debugging
5837       lprn=.false.
5838 c      lprn=.true.
5839       etors=0.0D0
5840       do i=iphi_start,iphi_end
5841       etors_ii=0.0D0
5842         itori=itortyp(itype(i-2))
5843         itori1=itortyp(itype(i-1))
5844         phii=phi(i)
5845         gloci=0.0D0
5846 C Proline-Proline pair is a special case...
5847         if (itori.eq.3 .and. itori1.eq.3) then
5848           if (phii.gt.-dwapi3) then
5849             cosphi=dcos(3*phii)
5850             fac=1.0D0/(1.0D0-cosphi)
5851             etorsi=v1(1,3,3)*fac
5852             etorsi=etorsi+etorsi
5853             etors=etors+etorsi-v1(1,3,3)
5854             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5855             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5856           endif
5857           do j=1,3
5858             v1ij=v1(j+1,itori,itori1)
5859             v2ij=v2(j+1,itori,itori1)
5860             cosphi=dcos(j*phii)
5861             sinphi=dsin(j*phii)
5862             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5863             if (energy_dec) etors_ii=etors_ii+
5864      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5865             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5866           enddo
5867         else
5868           do j=1,nterm_old
5869             v1ij=v1(j,itori,itori1)
5870             v2ij=v2(j,itori,itori1)
5871             cosphi=dcos(j*phii)
5872             sinphi=dsin(j*phii)
5873             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5874             if (energy_dec) etors_ii=etors_ii+
5875      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5876             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5877           enddo
5878         endif
5879         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5880      &        'etor',i,etors_ii
5881         if (lprn)
5882      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5883      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5884      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5885         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5886         write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5887       enddo
5888 ! 6/20/98 - dihedral angle constraints
5889       edihcnstr=0.0d0
5890       do i=1,ndih_constr
5891         itori=idih_constr(i)
5892         phii=phi(itori)
5893         difi=phii-phi0(i)
5894         if (difi.gt.drange(i)) then
5895           difi=difi-drange(i)
5896           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5897           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5898         else if (difi.lt.-drange(i)) then
5899           difi=difi+drange(i)
5900           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5901           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5902         endif
5903 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5904 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5905       enddo
5906 !      write (iout,*) 'edihcnstr',edihcnstr
5907       return
5908       end
5909 c------------------------------------------------------------------------------
5910 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
5911       subroutine e_modeller(ehomology_constr)
5912       ehomology_constr=0.0d0
5913       write (iout,*) "!!!!!UWAGA, JESTEM W DZIWNEJ PETLI, TEST!!!!!"
5914       return
5915       end
5916 C !!!!!!!! NIE CZYTANE !!!!!!!!!!!
5917
5918 c------------------------------------------------------------------------------
5919       subroutine etor_d(etors_d)
5920       etors_d=0.0d0
5921       return
5922       end
5923 c----------------------------------------------------------------------------
5924 #else
5925       subroutine etor(etors,edihcnstr)
5926       implicit real*8 (a-h,o-z)
5927       include 'DIMENSIONS'
5928       include 'COMMON.VAR'
5929       include 'COMMON.GEO'
5930       include 'COMMON.LOCAL'
5931       include 'COMMON.TORSION'
5932       include 'COMMON.INTERACT'
5933       include 'COMMON.DERIV'
5934       include 'COMMON.CHAIN'
5935       include 'COMMON.NAMES'
5936       include 'COMMON.IOUNITS'
5937       include 'COMMON.FFIELD'
5938       include 'COMMON.TORCNSTR'
5939       include 'COMMON.CONTROL'
5940       logical lprn
5941 C Set lprn=.true. for debugging
5942       lprn=.false.
5943 c     lprn=.true.
5944       etors=0.0D0
5945       do i=iphi_start,iphi_end
5946       etors_ii=0.0D0
5947         itori=itortyp(itype(i-2))
5948         itori1=itortyp(itype(i-1))
5949         phii=phi(i)
5950         gloci=0.0D0
5951 C Regular cosine and sine terms
5952         do j=1,nterm(itori,itori1)
5953           v1ij=v1(j,itori,itori1)
5954           v2ij=v2(j,itori,itori1)
5955           cosphi=dcos(j*phii)
5956           sinphi=dsin(j*phii)
5957           etors=etors+v1ij*cosphi+v2ij*sinphi
5958           if (energy_dec) etors_ii=etors_ii+
5959      &                v1ij*cosphi+v2ij*sinphi
5960           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5961         enddo
5962 C Lorentz terms
5963 C                         v1
5964 C  E = SUM ----------------------------------- - v1
5965 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5966 C
5967         cosphi=dcos(0.5d0*phii)
5968         sinphi=dsin(0.5d0*phii)
5969         do j=1,nlor(itori,itori1)
5970           vl1ij=vlor1(j,itori,itori1)
5971           vl2ij=vlor2(j,itori,itori1)
5972           vl3ij=vlor3(j,itori,itori1)
5973           pom=vl2ij*cosphi+vl3ij*sinphi
5974           pom1=1.0d0/(pom*pom+1.0d0)
5975           etors=etors+vl1ij*pom1
5976           if (energy_dec) etors_ii=etors_ii+
5977      &                vl1ij*pom1
5978           pom=-pom*pom1*pom1
5979           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5980         enddo
5981 C Subtract the constant term
5982         etors=etors-v0(itori,itori1)
5983           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5984      &         'etor',i,etors_ii-v0(itori,itori1)
5985         if (lprn)
5986      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5987      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5988      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5989         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5990 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5991       enddo
5992 ! 6/20/98 - dihedral angle constraints
5993       edihcnstr=0.0d0
5994 c      do i=1,ndih_constr
5995       do i=idihconstr_start,idihconstr_end
5996         itori=idih_constr(i)
5997         phii=phi(itori)
5998         difi=pinorm(phii-phi0(i))
5999         if (difi.gt.drange(i)) then
6000           difi=difi-drange(i)
6001           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6002           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6003         else if (difi.lt.-drange(i)) then
6004           difi=difi+drange(i)
6005           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6006           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6007         else
6008           difi=0.0
6009         endif
6010 c        write (iout,*) "gloci", gloc(i-3,icg)
6011 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
6012 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
6013 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6014       enddo
6015 cd       write (iout,*) 'edihcnstr',edihcnstr
6016       return
6017       end
6018 c----------------------------------------------------------------------------
6019 c MODELLER restraint function
6020       subroutine e_modeller(ehomology_constr)
6021       implicit real*8 (a-h,o-z)
6022       include 'DIMENSIONS'
6023
6024       integer nnn, i, j, k, ki, irec, l
6025       integer katy, odleglosci, test7
6026       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
6027       real*8 Eval,Erot
6028       real*8 distance(max_template),distancek(max_template),
6029      &    min_odl,godl(max_template),dih_diff(max_template)
6030
6031 c
6032 c     FP - 30/10/2014 Temporary specifications for homology restraints
6033 c
6034       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
6035      &                 sgtheta
6036       double precision, dimension (maxres) :: guscdiff,usc_diff
6037       double precision, dimension (max_template) ::
6038      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
6039      &           theta_diff
6040 c
6041
6042       include 'COMMON.SBRIDGE'
6043       include 'COMMON.CHAIN'
6044       include 'COMMON.GEO'
6045       include 'COMMON.DERIV'
6046       include 'COMMON.LOCAL'
6047       include 'COMMON.INTERACT'
6048       include 'COMMON.VAR'
6049       include 'COMMON.IOUNITS'
6050       include 'COMMON.MD'
6051       include 'COMMON.CONTROL'
6052 c
6053 c     From subroutine Econstr_back
6054 c
6055       include 'COMMON.NAMES'
6056       include 'COMMON.TIME1'
6057 c
6058
6059
6060       do i=1,max_template
6061         distancek(i)=9999999.9
6062       enddo
6063
6064
6065       odleg=0.0d0
6066
6067 c Pseudo-energy and gradient from homology restraints (MODELLER-like
6068 c function)
6069 C AL 5/2/14 - Introduce list of restraints
6070 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
6071 #ifdef DEBUG
6072       write(iout,*) "------- dist restrs start -------"
6073 #endif
6074       do ii = link_start_homo,link_end_homo
6075          i = ires_homo(ii)
6076          j = jres_homo(ii)
6077          dij=dist(i,j)
6078 c        write (iout,*) "dij(",i,j,") =",dij
6079          do k=1,constr_homology
6080 c           write(iout,*) ii,k,i,j,l_homo(k,ii),dij,odl(k,ii)
6081            if(.not.l_homo(k,ii)) cycle
6082            distance(k)=odl(k,ii)-dij
6083 c          write (iout,*) "distance(",k,") =",distance(k)
6084 c
6085 c          For Gaussian-type Urestr
6086 c
6087            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
6088 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
6089 c          write (iout,*) "distancek(",k,") =",distancek(k)
6090 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
6091 c
6092 c          For Lorentzian-type Urestr
6093 c
6094            if (waga_dist.lt.0.0d0) then
6095               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
6096               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
6097      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
6098            endif
6099          enddo
6100
6101
6102 c         min_odl=minval(distancek)
6103          do kk=1,constr_homology
6104           if(l_homo(kk,ii)) then
6105             min_odl=distancek(kk)
6106             exit
6107           endif
6108          enddo
6109          do kk=1,constr_homology
6110           if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
6111      &              min_odl=distancek(kk)
6112          enddo
6113 c        write (iout,* )"min_odl",min_odl
6114 #ifdef DEBUG
6115          write (iout,*) "ij dij",i,j,dij
6116          write (iout,*) "distance",(distance(k),k=1,constr_homology)
6117          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
6118          write (iout,* )"min_odl",min_odl
6119 #endif
6120          odleg2=0.0d0
6121          do k=1,constr_homology
6122 c Nie wiem po co to liczycie jeszcze raz!
6123 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
6124 c     &              (2*(sigma_odl(i,j,k))**2))
6125            if(.not.l_homo(k,ii)) cycle
6126            if (waga_dist.ge.0.0d0) then
6127 c
6128 c          For Gaussian-type Urestr
6129 c
6130             godl(k)=dexp(-distancek(k)+min_odl)
6131             odleg2=odleg2+godl(k)
6132 c
6133 c          For Lorentzian-type Urestr
6134 c
6135            else
6136             odleg2=odleg2+distancek(k)
6137            endif
6138
6139 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
6140 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
6141 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
6142 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
6143
6144          enddo
6145 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
6146 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
6147 #ifdef DEBUG
6148          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
6149          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
6150 #endif
6151            if (waga_dist.ge.0.0d0) then
6152 c
6153 c          For Gaussian-type Urestr
6154 c
6155               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
6156 c
6157 c          For Lorentzian-type Urestr
6158 c
6159            else
6160               odleg=odleg+odleg2/constr_homology
6161            endif
6162 c
6163 c        write (iout,*) "odleg",odleg ! sum of -ln-s
6164 c Gradient
6165 c
6166 c          For Gaussian-type Urestr
6167 c
6168          if (waga_dist.ge.0.0d0) sum_godl=odleg2
6169          sum_sgodl=0.0d0
6170          do k=1,constr_homology
6171 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
6172 c     &           *waga_dist)+min_odl
6173 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
6174 c
6175          if(.not.l_homo(k,ii)) cycle
6176          if (waga_dist.ge.0.0d0) then
6177 c          For Gaussian-type Urestr
6178 c
6179            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
6180 c
6181 c          For Lorentzian-type Urestr
6182 c
6183          else
6184            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
6185      &           sigma_odlir(k,ii)**2)**2)
6186          endif
6187            sum_sgodl=sum_sgodl+sgodl
6188
6189 c            sgodl2=sgodl2+sgodl
6190 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
6191 c      write(iout,*) "constr_homology=",constr_homology
6192 c      write(iout,*) i, j, k, "TEST K"
6193          enddo
6194          if (waga_dist.ge.0.0d0) then
6195 c
6196 c          For Gaussian-type Urestr
6197 c
6198             grad_odl3=waga_homology(iset)*waga_dist
6199      &                *sum_sgodl/(sum_godl*dij)
6200 c
6201 c          For Lorentzian-type Urestr
6202 c
6203          else
6204 c Original grad expr modified by analogy w Gaussian-type Urestr grad
6205 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
6206             grad_odl3=-waga_homology(iset)*waga_dist*
6207      &                sum_sgodl/(constr_homology*dij)
6208          endif
6209 c
6210 c        grad_odl3=sum_sgodl/(sum_godl*dij)
6211
6212
6213 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
6214 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
6215 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
6216
6217 ccc      write(iout,*) godl, sgodl, grad_odl3
6218
6219 c          grad_odl=grad_odl+grad_odl3
6220
6221          do jik=1,3
6222             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
6223 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
6224 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
6225 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
6226             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
6227             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
6228 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
6229 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
6230 c         if (i.eq.25.and.j.eq.27) then
6231 c         write(iout,*) "jik",jik,"i",i,"j",j
6232 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
6233 c         write(iout,*) "grad_odl3",grad_odl3
6234 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
6235 c         write(iout,*) "ggodl",ggodl
6236 c         write(iout,*) "ghpbc(",jik,i,")",
6237 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
6238 c     &                 ghpbc(jik,j)
6239 c         endif
6240          enddo
6241 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
6242 ccc     & dLOG(odleg2),"-odleg=", -odleg
6243
6244       enddo ! ii-loop for dist
6245 #ifdef DEBUG
6246       write(iout,*) "------- dist restrs end -------"
6247 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
6248 c    &     waga_d.eq.1.0d0) call sum_gradient
6249 #endif
6250 c Pseudo-energy and gradient from dihedral-angle restraints from
6251 c homology templates
6252 c      write (iout,*) "End of distance loop"
6253 c      call flush(iout)
6254       kat=0.0d0
6255 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
6256 #ifdef DEBUG
6257       write(iout,*) "------- dih restrs start -------"
6258       do i=idihconstr_start_homo,idihconstr_end_homo
6259         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
6260       enddo
6261 #endif
6262       do i=idihconstr_start_homo,idihconstr_end_homo
6263         kat2=0.0d0
6264 c        betai=beta(i,i+1,i+2,i+3)
6265         betai = phi(i)
6266 c       write (iout,*) "betai =",betai
6267         do k=1,constr_homology
6268           dih_diff(k)=pinorm(dih(k,i)-betai)
6269 c         write (iout,*) "dih_diff(",k,") =",dih_diff(k)
6270 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
6271 c     &                                   -(6.28318-dih_diff(i,k))
6272 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
6273 c     &                                   6.28318+dih_diff(i,k)
6274
6275           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
6276 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
6277           gdih(k)=dexp(kat3)
6278           kat2=kat2+gdih(k)
6279 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
6280 c          write(*,*)""
6281         enddo
6282 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
6283 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
6284 #ifdef DEBUG
6285         write (iout,*) "i",i," betai",betai," kat2",kat2
6286         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
6287 #endif
6288         if (kat2.le.1.0d-14) cycle
6289         kat=kat-dLOG(kat2/constr_homology)
6290 c       write (iout,*) "kat",kat ! sum of -ln-s
6291
6292 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
6293 ccc     & dLOG(kat2), "-kat=", -kat
6294
6295 c ----------------------------------------------------------------------
6296 c Gradient
6297 c ----------------------------------------------------------------------
6298
6299         sum_gdih=kat2
6300         sum_sgdih=0.0d0
6301         do k=1,constr_homology
6302           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
6303 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
6304           sum_sgdih=sum_sgdih+sgdih
6305         enddo
6306 c       grad_dih3=sum_sgdih/sum_gdih
6307         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
6308
6309 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
6310 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
6311 ccc     & gloc(nphi+i-3,icg)
6312         gloc(i-3,icg)=gloc(i-3,icg)+grad_dih3
6313 c        if (i.eq.25) then
6314 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
6315 c        endif
6316 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
6317 ccc     & gloc(nphi+i-3,icg)
6318
6319       enddo ! i-loop for dih
6320 #ifdef DEBUG
6321       write(iout,*) "------- dih restrs end -------"
6322 #endif
6323
6324 c Pseudo-energy and gradient for theta angle restraints from
6325 c homology templates
6326 c FP 01/15 - inserted from econstr_local_test.F, loop structure
6327 c adapted
6328
6329 c
6330 c     For constr_homology reference structures (FP)
6331 c
6332 c     Uconst_back_tot=0.0d0
6333       Eval=0.0d0
6334       Erot=0.0d0
6335 c     Econstr_back legacy
6336       do i=1,nres
6337 c     do i=ithet_start,ithet_end
6338        dutheta(i)=0.0d0
6339 c     enddo
6340 c     do i=loc_start,loc_end
6341         do j=1,3
6342           duscdiff(j,i)=0.0d0
6343           duscdiffx(j,i)=0.0d0
6344         enddo
6345       enddo
6346 c
6347 c     do iref=1,nref
6348 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
6349 c     write (iout,*) "waga_theta",waga_theta
6350       if (waga_theta.gt.0.0d0) then
6351 #ifdef DEBUG
6352       write (iout,*) "usampl",usampl
6353       write(iout,*) "------- theta restrs start -------"
6354 c     do i=ithet_start,ithet_end
6355 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
6356 c     enddo
6357 #endif
6358 c     write (iout,*) "maxres",maxres,"nres",nres
6359
6360       do i=ithet_start,ithet_end
6361 c
6362 c     do i=1,nfrag_back
6363 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
6364 c
6365 c Deviation of theta angles wrt constr_homology ref structures
6366 c
6367         utheta_i=0.0d0 ! argument of Gaussian for single k
6368         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
6369 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
6370 c       over residues in a fragment
6371 c       write (iout,*) "theta(",i,")=",theta(i)
6372         do k=1,constr_homology
6373 c
6374 c         dtheta_i=theta(j)-thetaref(j,iref)
6375 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
6376           theta_diff(k)=thetatpl(k,i)-theta(i)
6377 c
6378           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
6379 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
6380           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
6381           gutheta_i=gutheta_i+dexp(utheta_i)   ! Sum of Gaussians (pk)
6382 c         Gradient for single Gaussian restraint in subr Econstr_back
6383 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
6384 c
6385         enddo
6386 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
6387 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
6388
6389 c
6390 c         Gradient for multiple Gaussian restraint
6391         sum_gtheta=gutheta_i
6392         sum_sgtheta=0.0d0
6393         do k=1,constr_homology
6394 c        New generalized expr for multiple Gaussian from Econstr_back
6395          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
6396 c
6397 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
6398           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
6399         enddo
6400 c       Final value of gradient using same var as in Econstr_back
6401         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)
6402      &      +sum_sgtheta/sum_gtheta*waga_theta
6403      &               *waga_homology(iset)
6404 c        dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
6405 c     &               *waga_homology(iset)
6406 c       dutheta(i)=sum_sgtheta/sum_gtheta
6407 c
6408 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
6409         Eval=Eval-dLOG(gutheta_i/constr_homology)
6410 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
6411 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
6412 c       Uconst_back=Uconst_back+utheta(i)
6413       enddo ! (i-loop for theta)
6414 #ifdef DEBUG
6415       write(iout,*) "------- theta restrs end -------"
6416 #endif
6417       endif
6418 c
6419 c Deviation of local SC geometry
6420 c
6421 c Separation of two i-loops (instructed by AL - 11/3/2014)
6422 c
6423 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
6424 c     write (iout,*) "waga_d",waga_d
6425
6426 #ifdef DEBUG
6427       write(iout,*) "------- SC restrs start -------"
6428       write (iout,*) "Initial duscdiff,duscdiffx"
6429       do i=loc_start,loc_end
6430         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
6431      &                 (duscdiffx(jik,i),jik=1,3)
6432       enddo
6433 #endif
6434       do i=loc_start,loc_end
6435         usc_diff_i=0.0d0 ! argument of Gaussian for single k
6436         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
6437 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
6438 c       write(iout,*) "xxtab, yytab, zztab"
6439 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
6440         do k=1,constr_homology
6441 c
6442           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
6443 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
6444           dyy=-yytpl(k,i)+yytab(i) ! ibid y
6445           dzz=-zztpl(k,i)+zztab(i) ! ibid z
6446 c         write(iout,*) "dxx, dyy, dzz"
6447 c         write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
6448 c
6449           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
6450 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
6451 c         uscdiffk(k)=usc_diff(i)
6452           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
6453           guscdiff(i)=guscdiff(i)+dexp(usc_diff_i)   !Sum of Gaussians (pk)
6454 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
6455 c     &      xxref(j),yyref(j),zzref(j)
6456         enddo
6457 c
6458 c       Gradient
6459 c
6460 c       Generalized expression for multiple Gaussian acc to that for a single
6461 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
6462 c
6463 c       Original implementation
6464 c       sum_guscdiff=guscdiff(i)
6465 c
6466 c       sum_sguscdiff=0.0d0
6467 c       do k=1,constr_homology
6468 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
6469 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
6470 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
6471 c       enddo
6472 c
6473 c       Implementation of new expressions for gradient (Jan. 2015)
6474 c
6475 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
6476         do k=1,constr_homology
6477 c
6478 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
6479 c       before. Now the drivatives should be correct
6480 c
6481           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
6482 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
6483           dyy=-yytpl(k,i)+yytab(i) ! ibid y
6484           dzz=-zztpl(k,i)+zztab(i) ! ibid z
6485 c
6486 c         New implementation
6487 c
6488           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
6489      &                 sigma_d(k,i) ! for the grad wrt r'
6490 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
6491 c
6492 c
6493 c        New implementation
6494          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
6495          do jik=1,3
6496             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
6497      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
6498      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
6499             duscdiff(jik,i)=duscdiff(jik,i)+
6500      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
6501      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
6502             duscdiffx(jik,i)=duscdiffx(jik,i)+
6503      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
6504      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
6505 c
6506 #ifdef DEBUG
6507              write(iout,*) "jik",jik,"i",i
6508              write(iout,*) "dxx, dyy, dzz"
6509              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
6510              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
6511 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
6512 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
6513 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
6514 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
6515 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
6516 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
6517 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
6518 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
6519 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
6520 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
6521 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
6522 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
6523 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
6524 c            endif
6525 #endif
6526          enddo
6527         enddo
6528 c
6529 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
6530 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
6531 c
6532 c        write (iout,*) i," uscdiff",uscdiff(i)
6533 c
6534 c Put together deviations from local geometry
6535
6536 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
6537 c      &            wfrag_back(3,i,iset)*uscdiff(i)
6538         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
6539 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
6540 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
6541 c       Uconst_back=Uconst_back+usc_diff(i)
6542 c
6543 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
6544 c
6545 c     New implment: multiplied by sum_sguscdiff
6546 c
6547
6548       enddo ! (i-loop for dscdiff)
6549
6550 c      endif
6551
6552 #ifdef DEBUG
6553       write(iout,*) "------- SC restrs end -------"
6554         write (iout,*) "------ After SC loop in e_modeller ------"
6555         do i=loc_start,loc_end
6556          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
6557          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
6558         enddo
6559       if (waga_theta.eq.1.0d0) then
6560       write (iout,*) "in e_modeller after SC restr end: dutheta"
6561       do i=ithet_start,ithet_end
6562         write (iout,*) i,dutheta(i)
6563       enddo
6564       endif
6565       if (waga_d.eq.1.0d0) then
6566       write (iout,*) "e_modeller after SC loop: duscdiff/x"
6567       do i=1,nres
6568         write (iout,*) i,(duscdiff(j,i),j=1,3)
6569         write (iout,*) i,(duscdiffx(j,i),j=1,3)
6570       enddo
6571       endif
6572 #endif
6573
6574 c Total energy from homology restraints
6575 #ifdef DEBUG
6576       write (iout,*) "odleg",odleg," kat",kat
6577 #endif
6578 c
6579 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
6580 c
6581 c     ehomology_constr=odleg+kat
6582 c
6583 c     For Lorentzian-type Urestr
6584 c
6585
6586       if (waga_dist.ge.0.0d0) then
6587 c
6588 c          For Gaussian-type Urestr
6589 c
6590         ehomology_constr=(waga_dist*odleg+waga_angle*kat+
6591      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
6592 c     write (iout,*) "ehomology_constr=",ehomology_constr
6593       else
6594 c
6595 c          For Lorentzian-type Urestr
6596 c
6597         ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
6598      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
6599 c     write (iout,*) "ehomology_constr=",ehomology_constr
6600       endif
6601 #ifdef DEBUG
6602       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
6603      & "Eval",waga_theta,eval,
6604      &   "Erot",waga_d,Erot
6605       write (iout,*) "ehomology_constr",ehomology_constr
6606 #endif
6607       return
6608 c
6609 c FP 01/15 end
6610 c
6611   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
6612   747 format(a12,i4,i4,i4,f8.3,f8.3)
6613   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
6614   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
6615   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
6616      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
6617       end
6618
6619 c------------------------------------------------------------------------------
6620       subroutine etor_d(etors_d)
6621 C 6/23/01 Compute double torsional energy
6622       implicit real*8 (a-h,o-z)
6623       include 'DIMENSIONS'
6624       include 'COMMON.VAR'
6625       include 'COMMON.GEO'
6626       include 'COMMON.LOCAL'
6627       include 'COMMON.TORSION'
6628       include 'COMMON.INTERACT'
6629       include 'COMMON.DERIV'
6630       include 'COMMON.CHAIN'
6631       include 'COMMON.NAMES'
6632       include 'COMMON.IOUNITS'
6633       include 'COMMON.FFIELD'
6634       include 'COMMON.TORCNSTR'
6635       include 'COMMON.CONTROL'
6636       logical lprn
6637 C Set lprn=.true. for debugging
6638       lprn=.false.
6639 c     lprn=.true.
6640       etors_d=0.0D0
6641       do i=iphid_start,iphid_end
6642         etors_d_ii=0.0D0
6643         itori=itortyp(itype(i-2))
6644         itori1=itortyp(itype(i-1))
6645         itori2=itortyp(itype(i))
6646         phii=phi(i)
6647         phii1=phi(i+1)
6648         gloci1=0.0D0
6649         gloci2=0.0D0
6650         do j=1,ntermd_1(itori,itori1,itori2)
6651           v1cij=v1c(1,j,itori,itori1,itori2)
6652           v1sij=v1s(1,j,itori,itori1,itori2)
6653           v2cij=v1c(2,j,itori,itori1,itori2)
6654           v2sij=v1s(2,j,itori,itori1,itori2)
6655           cosphi1=dcos(j*phii)
6656           sinphi1=dsin(j*phii)
6657           cosphi2=dcos(j*phii1)
6658           sinphi2=dsin(j*phii1)
6659           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
6660      &     v2cij*cosphi2+v2sij*sinphi2
6661           if (energy_dec) etors_d_ii=etors_d_ii+
6662      &     v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
6663           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6664           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6665         enddo
6666         do k=2,ntermd_2(itori,itori1,itori2)
6667           do l=1,k-1
6668             v1cdij = v2c(k,l,itori,itori1,itori2)
6669             v2cdij = v2c(l,k,itori,itori1,itori2)
6670             v1sdij = v2s(k,l,itori,itori1,itori2)
6671             v2sdij = v2s(l,k,itori,itori1,itori2)
6672             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6673             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6674             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6675             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6676             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6677      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6678             if (energy_dec) etors_d_ii=etors_d_ii+
6679      &        v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6680      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6681             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
6682      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6683             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
6684      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6685           enddo
6686         enddo
6687         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6688      &        'etor_d',i,etors_d_ii
6689         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
6690         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
6691 c        write (iout,*) "gloci", gloc(i-3,icg)
6692       enddo
6693       return
6694       end
6695 #endif
6696 c------------------------------------------------------------------------------
6697       subroutine eback_sc_corr(esccor)
6698 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6699 c        conformational states; temporarily implemented as differences
6700 c        between UNRES torsional potentials (dependent on three types of
6701 c        residues) and the torsional potentials dependent on all 20 types
6702 c        of residues computed from AM1  energy surfaces of terminally-blocked
6703 c        amino-acid residues.
6704       implicit real*8 (a-h,o-z)
6705       include 'DIMENSIONS'
6706       include 'COMMON.VAR'
6707       include 'COMMON.GEO'
6708       include 'COMMON.LOCAL'
6709       include 'COMMON.TORSION'
6710       include 'COMMON.SCCOR'
6711       include 'COMMON.INTERACT'
6712       include 'COMMON.DERIV'
6713       include 'COMMON.CHAIN'
6714       include 'COMMON.NAMES'
6715       include 'COMMON.IOUNITS'
6716       include 'COMMON.FFIELD'
6717       include 'COMMON.CONTROL'
6718       logical lprn
6719 C Set lprn=.true. for debugging
6720       lprn=.false.
6721 c      lprn=.true.
6722 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
6723       esccor=0.0D0
6724       do i=itau_start,itau_end
6725         esccor_ii=0.0D0
6726         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6727         isccori=isccortyp(itype(i-2))
6728         isccori1=isccortyp(itype(i-1))
6729         phii=phi(i)
6730 cccc  Added 9 May 2012
6731 cc Tauangle is torsional engle depending on the value of first digit
6732 c(see comment below)
6733 cc Omicron is flat angle depending on the value of first digit
6734 c(see comment below)
6735
6736
6737         do intertyp=1,3 !intertyp
6738 cc Added 09 May 2012 (Adasko)
6739 cc  Intertyp means interaction type of backbone mainchain correlation:
6740 c   1 = SC...Ca...Ca...Ca
6741 c   2 = Ca...Ca...Ca...SC
6742 c   3 = SC...Ca...Ca...SCi
6743         gloci=0.0D0
6744         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6745      &      (itype(i-1).eq.10).or.(itype(i-2).eq.21).or.
6746      &      (itype(i-1).eq.21)))
6747      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6748      &     .or.(itype(i-2).eq.21)))
6749      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6750      &      (itype(i-1).eq.21)))) cycle
6751         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle
6752         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21))
6753      & cycle
6754         do j=1,nterm_sccor(isccori,isccori1)
6755           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6756           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6757           cosphi=dcos(j*tauangle(intertyp,i))
6758           sinphi=dsin(j*tauangle(intertyp,i))
6759           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6760           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6761         enddo
6762         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6763 c        write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
6764 c     &gloc_sc(intertyp,i-3,icg)
6765         if (lprn)
6766      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6767      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6768      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
6769      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
6770         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6771        enddo !intertyp
6772       enddo
6773 c        do i=1,nres
6774 c        write (iout,*) "W@T@F",  gloc_sc(1,i,icg),gloc(i,icg)
6775 c        enddo
6776       return
6777       end
6778 c----------------------------------------------------------------------------
6779       subroutine multibody(ecorr)
6780 C This subroutine calculates multi-body contributions to energy following
6781 C the idea of Skolnick et al. If side chains I and J make a contact and
6782 C at the same time side chains I+1 and J+1 make a contact, an extra
6783 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6784       implicit real*8 (a-h,o-z)
6785       include 'DIMENSIONS'
6786       include 'COMMON.IOUNITS'
6787       include 'COMMON.DERIV'
6788       include 'COMMON.INTERACT'
6789       include 'COMMON.CONTACTS'
6790       double precision gx(3),gx1(3)
6791       logical lprn
6792
6793 C Set lprn=.true. for debugging
6794       lprn=.false.
6795
6796       if (lprn) then
6797         write (iout,'(a)') 'Contact function values:'
6798         do i=nnt,nct-2
6799           write (iout,'(i2,20(1x,i2,f10.5))')
6800      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6801         enddo
6802       endif
6803       ecorr=0.0D0
6804       do i=nnt,nct
6805         do j=1,3
6806           gradcorr(j,i)=0.0D0
6807           gradxorr(j,i)=0.0D0
6808         enddo
6809       enddo
6810       do i=nnt,nct-2
6811
6812         DO ISHIFT = 3,4
6813
6814         i1=i+ishift
6815         num_conti=num_cont(i)
6816         num_conti1=num_cont(i1)
6817         do jj=1,num_conti
6818           j=jcont(jj,i)
6819           do kk=1,num_conti1
6820             j1=jcont(kk,i1)
6821             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6822 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6823 cd   &                   ' ishift=',ishift
6824 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6825 C The system gains extra energy.
6826               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6827             endif   ! j1==j+-ishift
6828           enddo     ! kk
6829         enddo       ! jj
6830
6831         ENDDO ! ISHIFT
6832
6833       enddo         ! i
6834       return
6835       end
6836 c------------------------------------------------------------------------------
6837       double precision function esccorr(i,j,k,l,jj,kk)
6838       implicit real*8 (a-h,o-z)
6839       include 'DIMENSIONS'
6840       include 'COMMON.IOUNITS'
6841       include 'COMMON.DERIV'
6842       include 'COMMON.INTERACT'
6843       include 'COMMON.CONTACTS'
6844       double precision gx(3),gx1(3)
6845       logical lprn
6846       lprn=.false.
6847       eij=facont(jj,i)
6848       ekl=facont(kk,k)
6849 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6850 C Calculate the multi-body contribution to energy.
6851 C Calculate multi-body contributions to the gradient.
6852 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6853 cd   & k,l,(gacont(m,kk,k),m=1,3)
6854       do m=1,3
6855         gx(m) =ekl*gacont(m,jj,i)
6856         gx1(m)=eij*gacont(m,kk,k)
6857         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6858         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6859         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6860         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6861       enddo
6862       do m=i,j-1
6863         do ll=1,3
6864           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6865         enddo
6866       enddo
6867       do m=k,l-1
6868         do ll=1,3
6869           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6870         enddo
6871       enddo
6872       esccorr=-eij*ekl
6873       return
6874       end
6875 c------------------------------------------------------------------------------
6876       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6877 C This subroutine calculates multi-body contributions to hydrogen-bonding
6878       implicit real*8 (a-h,o-z)
6879       include 'DIMENSIONS'
6880       include 'COMMON.IOUNITS'
6881 #ifdef MPI
6882       include "mpif.h"
6883       parameter (max_cont=maxconts)
6884       parameter (max_dim=26)
6885       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6886       double precision zapas(max_dim,maxconts,max_fg_procs),
6887      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6888       common /przechowalnia/ zapas
6889       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6890      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6891 #endif
6892       include 'COMMON.SETUP'
6893       include 'COMMON.FFIELD'
6894       include 'COMMON.DERIV'
6895       include 'COMMON.INTERACT'
6896       include 'COMMON.CONTACTS'
6897       include 'COMMON.CONTROL'
6898       include 'COMMON.LOCAL'
6899       double precision gx(3),gx1(3),time00
6900       logical lprn,ldone
6901
6902 C Set lprn=.true. for debugging
6903       lprn=.false.
6904 #ifdef MPI
6905       n_corr=0
6906       n_corr1=0
6907       if (nfgtasks.le.1) goto 30
6908       if (lprn) then
6909         write (iout,'(a)') 'Contact function values before RECEIVE:'
6910         do i=nnt,nct-2
6911           write (iout,'(2i3,50(1x,i2,f5.2))')
6912      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6913      &    j=1,num_cont_hb(i))
6914         enddo
6915       endif
6916       call flush(iout)
6917       do i=1,ntask_cont_from
6918         ncont_recv(i)=0
6919       enddo
6920       do i=1,ntask_cont_to
6921         ncont_sent(i)=0
6922       enddo
6923 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6924 c     & ntask_cont_to
6925 C Make the list of contacts to send to send to other procesors
6926 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6927 c      call flush(iout)
6928       do i=iturn3_start,iturn3_end
6929 c        write (iout,*) "make contact list turn3",i," num_cont",
6930 c     &    num_cont_hb(i)
6931         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6932       enddo
6933       do i=iturn4_start,iturn4_end
6934 c        write (iout,*) "make contact list turn4",i," num_cont",
6935 c     &   num_cont_hb(i)
6936         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6937       enddo
6938       do ii=1,nat_sent
6939         i=iat_sent(ii)
6940 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6941 c     &    num_cont_hb(i)
6942         do j=1,num_cont_hb(i)
6943         do k=1,4
6944           jjc=jcont_hb(j,i)
6945           iproc=iint_sent_local(k,jjc,ii)
6946 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6947           if (iproc.gt.0) then
6948             ncont_sent(iproc)=ncont_sent(iproc)+1
6949             nn=ncont_sent(iproc)
6950             zapas(1,nn,iproc)=i
6951             zapas(2,nn,iproc)=jjc
6952             zapas(3,nn,iproc)=facont_hb(j,i)
6953             zapas(4,nn,iproc)=ees0p(j,i)
6954             zapas(5,nn,iproc)=ees0m(j,i)
6955             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6956             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6957             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6958             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6959             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6960             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6961             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6962             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6963             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6964             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6965             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6966             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6967             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6968             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6969             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6970             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6971             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6972             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6973             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6974             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6975             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6976           endif
6977         enddo
6978         enddo
6979       enddo
6980       if (lprn) then
6981       write (iout,*)
6982      &  "Numbers of contacts to be sent to other processors",
6983      &  (ncont_sent(i),i=1,ntask_cont_to)
6984       write (iout,*) "Contacts sent"
6985       do ii=1,ntask_cont_to
6986         nn=ncont_sent(ii)
6987         iproc=itask_cont_to(ii)
6988         write (iout,*) nn," contacts to processor",iproc,
6989      &   " of CONT_TO_COMM group"
6990         do i=1,nn
6991           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6992         enddo
6993       enddo
6994       call flush(iout)
6995       endif
6996       CorrelType=477
6997       CorrelID=fg_rank+1
6998       CorrelType1=478
6999       CorrelID1=nfgtasks+fg_rank+1
7000       ireq=0
7001 C Receive the numbers of needed contacts from other processors
7002       do ii=1,ntask_cont_from
7003         iproc=itask_cont_from(ii)
7004         ireq=ireq+1
7005         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7006      &    FG_COMM,req(ireq),IERR)
7007       enddo
7008 c      write (iout,*) "IRECV ended"
7009 c      call flush(iout)
7010 C Send the number of contacts needed by other processors
7011       do ii=1,ntask_cont_to
7012         iproc=itask_cont_to(ii)
7013         ireq=ireq+1
7014         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7015      &    FG_COMM,req(ireq),IERR)
7016       enddo
7017 c      write (iout,*) "ISEND ended"
7018 c      write (iout,*) "number of requests (nn)",ireq
7019       call flush(iout)
7020       if (ireq.gt.0)
7021      &  call MPI_Waitall(ireq,req,status_array,ierr)
7022 c      write (iout,*)
7023 c     &  "Numbers of contacts to be received from other processors",
7024 c     &  (ncont_recv(i),i=1,ntask_cont_from)
7025 c      call flush(iout)
7026 C Receive contacts
7027       ireq=0
7028       do ii=1,ntask_cont_from
7029         iproc=itask_cont_from(ii)
7030         nn=ncont_recv(ii)
7031 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7032 c     &   " of CONT_TO_COMM group"
7033         call flush(iout)
7034         if (nn.gt.0) then
7035           ireq=ireq+1
7036           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
7037      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7038 c          write (iout,*) "ireq,req",ireq,req(ireq)
7039         endif
7040       enddo
7041 C Send the contacts to processors that need them
7042       do ii=1,ntask_cont_to
7043         iproc=itask_cont_to(ii)
7044         nn=ncont_sent(ii)
7045 c        write (iout,*) nn," contacts to processor",iproc,
7046 c     &   " of CONT_TO_COMM group"
7047         if (nn.gt.0) then
7048           ireq=ireq+1
7049           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
7050      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7051 c          write (iout,*) "ireq,req",ireq,req(ireq)
7052 c          do i=1,nn
7053 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7054 c          enddo
7055         endif
7056       enddo
7057 c      write (iout,*) "number of requests (contacts)",ireq
7058 c      write (iout,*) "req",(req(i),i=1,4)
7059 c      call flush(iout)
7060       if (ireq.gt.0)
7061      & call MPI_Waitall(ireq,req,status_array,ierr)
7062       do iii=1,ntask_cont_from
7063         iproc=itask_cont_from(iii)
7064         nn=ncont_recv(iii)
7065         if (lprn) then
7066         write (iout,*) "Received",nn," contacts from processor",iproc,
7067      &   " of CONT_FROM_COMM group"
7068         call flush(iout)
7069         do i=1,nn
7070           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
7071         enddo
7072         call flush(iout)
7073         endif
7074         do i=1,nn
7075           ii=zapas_recv(1,i,iii)
7076 c Flag the received contacts to prevent double-counting
7077           jj=-zapas_recv(2,i,iii)
7078 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7079 c          call flush(iout)
7080           nnn=num_cont_hb(ii)+1
7081           num_cont_hb(ii)=nnn
7082           jcont_hb(nnn,ii)=jj
7083           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
7084           ees0p(nnn,ii)=zapas_recv(4,i,iii)
7085           ees0m(nnn,ii)=zapas_recv(5,i,iii)
7086           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
7087           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
7088           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
7089           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
7090           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
7091           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
7092           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
7093           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
7094           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
7095           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
7096           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
7097           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
7098           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
7099           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
7100           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
7101           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
7102           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
7103           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
7104           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
7105           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
7106           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
7107         enddo
7108       enddo
7109       call flush(iout)
7110       if (lprn) then
7111         write (iout,'(a)') 'Contact function values after receive:'
7112         do i=nnt,nct-2
7113           write (iout,'(2i3,50(1x,i3,f5.2))')
7114      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7115      &    j=1,num_cont_hb(i))
7116         enddo
7117         call flush(iout)
7118       endif
7119    30 continue
7120 #endif
7121       if (lprn) then
7122         write (iout,'(a)') 'Contact function values:'
7123         do i=nnt,nct-2
7124           write (iout,'(2i3,50(1x,i3,f5.2))')
7125      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7126      &    j=1,num_cont_hb(i))
7127         enddo
7128       endif
7129       ecorr=0.0D0
7130 C Remove the loop below after debugging !!!
7131       do i=nnt,nct
7132         do j=1,3
7133           gradcorr(j,i)=0.0D0
7134           gradxorr(j,i)=0.0D0
7135         enddo
7136       enddo
7137 C Calculate the local-electrostatic correlation terms
7138       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
7139         i1=i+1
7140         num_conti=num_cont_hb(i)
7141         num_conti1=num_cont_hb(i+1)
7142         do jj=1,num_conti
7143           j=jcont_hb(jj,i)
7144           jp=iabs(j)
7145           do kk=1,num_conti1
7146             j1=jcont_hb(kk,i1)
7147             jp1=iabs(j1)
7148 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7149 c     &         ' jj=',jj,' kk=',kk
7150             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7151      &          .or. j.lt.0 .and. j1.gt.0) .and.
7152      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7153 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7154 C The system gains extra energy.
7155               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7156               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
7157      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
7158               n_corr=n_corr+1
7159             else if (j1.eq.j) then
7160 C Contacts I-J and I-(J+1) occur simultaneously.
7161 C The system loses extra energy.
7162 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7163             endif
7164           enddo ! kk
7165           do kk=1,num_conti
7166             j1=jcont_hb(kk,i)
7167 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7168 c    &         ' jj=',jj,' kk=',kk
7169             if (j1.eq.j+1) then
7170 C Contacts I-J and (I+1)-J occur simultaneously.
7171 C The system loses extra energy.
7172 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7173             endif ! j1==j+1
7174           enddo ! kk
7175         enddo ! jj
7176       enddo ! i
7177       return
7178       end
7179 c------------------------------------------------------------------------------
7180       subroutine add_hb_contact(ii,jj,itask)
7181       implicit real*8 (a-h,o-z)
7182       include "DIMENSIONS"
7183       include "COMMON.IOUNITS"
7184       integer max_cont
7185       integer max_dim
7186       parameter (max_cont=maxconts)
7187       parameter (max_dim=26)
7188       include "COMMON.CONTACTS"
7189       double precision zapas(max_dim,maxconts,max_fg_procs),
7190      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7191       common /przechowalnia/ zapas
7192       integer i,j,ii,jj,iproc,itask(4),nn
7193 c      write (iout,*) "itask",itask
7194       do i=1,2
7195         iproc=itask(i)
7196         if (iproc.gt.0) then
7197           do j=1,num_cont_hb(ii)
7198             jjc=jcont_hb(j,ii)
7199 c            write (iout,*) "i",ii," j",jj," jjc",jjc
7200             if (jjc.eq.jj) then
7201               ncont_sent(iproc)=ncont_sent(iproc)+1
7202               nn=ncont_sent(iproc)
7203               zapas(1,nn,iproc)=ii
7204               zapas(2,nn,iproc)=jjc
7205               zapas(3,nn,iproc)=facont_hb(j,ii)
7206               zapas(4,nn,iproc)=ees0p(j,ii)
7207               zapas(5,nn,iproc)=ees0m(j,ii)
7208               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
7209               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
7210               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
7211               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
7212               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
7213               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
7214               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
7215               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
7216               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
7217               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
7218               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
7219               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
7220               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
7221               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
7222               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
7223               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
7224               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
7225               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
7226               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
7227               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
7228               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
7229               exit
7230             endif
7231           enddo
7232         endif
7233       enddo
7234       return
7235       end
7236 c------------------------------------------------------------------------------
7237       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
7238      &  n_corr1)
7239 C This subroutine calculates multi-body contributions to hydrogen-bonding
7240       implicit real*8 (a-h,o-z)
7241       include 'DIMENSIONS'
7242       include 'COMMON.IOUNITS'
7243 #ifdef MPI
7244       include "mpif.h"
7245       parameter (max_cont=maxconts)
7246       parameter (max_dim=70)
7247       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7248       double precision zapas(max_dim,maxconts,max_fg_procs),
7249      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7250       common /przechowalnia/ zapas
7251       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7252      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7253 #endif
7254       include 'COMMON.SETUP'
7255       include 'COMMON.FFIELD'
7256       include 'COMMON.DERIV'
7257       include 'COMMON.LOCAL'
7258       include 'COMMON.INTERACT'
7259       include 'COMMON.CONTACTS'
7260       include 'COMMON.CHAIN'
7261       include 'COMMON.CONTROL'
7262       double precision gx(3),gx1(3)
7263       integer num_cont_hb_old(maxres)
7264       logical lprn,ldone
7265       double precision eello4,eello5,eelo6,eello_turn6
7266       external eello4,eello5,eello6,eello_turn6
7267 C Set lprn=.true. for debugging
7268       lprn=.false.
7269       eturn6=0.0d0
7270 #ifdef MPI
7271       do i=1,nres
7272         num_cont_hb_old(i)=num_cont_hb(i)
7273       enddo
7274       n_corr=0
7275       n_corr1=0
7276       if (nfgtasks.le.1) goto 30
7277       if (lprn) then
7278         write (iout,'(a)') 'Contact function values before RECEIVE:'
7279         do i=nnt,nct-2
7280           write (iout,'(2i3,50(1x,i2,f5.2))')
7281      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7282      &    j=1,num_cont_hb(i))
7283         enddo
7284       endif
7285       call flush(iout)
7286       do i=1,ntask_cont_from
7287         ncont_recv(i)=0
7288       enddo
7289       do i=1,ntask_cont_to
7290         ncont_sent(i)=0
7291       enddo
7292 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7293 c     & ntask_cont_to
7294 C Make the list of contacts to send to send to other procesors
7295       do i=iturn3_start,iturn3_end
7296 c        write (iout,*) "make contact list turn3",i," num_cont",
7297 c     &    num_cont_hb(i)
7298         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
7299       enddo
7300       do i=iturn4_start,iturn4_end
7301 c        write (iout,*) "make contact list turn4",i," num_cont",
7302 c     &   num_cont_hb(i)
7303         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
7304       enddo
7305       do ii=1,nat_sent
7306         i=iat_sent(ii)
7307 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7308 c     &    num_cont_hb(i)
7309         do j=1,num_cont_hb(i)
7310         do k=1,4
7311           jjc=jcont_hb(j,i)
7312           iproc=iint_sent_local(k,jjc,ii)
7313 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7314           if (iproc.ne.0) then
7315             ncont_sent(iproc)=ncont_sent(iproc)+1
7316             nn=ncont_sent(iproc)
7317             zapas(1,nn,iproc)=i
7318             zapas(2,nn,iproc)=jjc
7319             zapas(3,nn,iproc)=d_cont(j,i)
7320             ind=3
7321             do kk=1,3
7322               ind=ind+1
7323               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
7324             enddo
7325             do kk=1,2
7326               do ll=1,2
7327                 ind=ind+1
7328                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
7329               enddo
7330             enddo
7331             do jj=1,5
7332               do kk=1,3
7333                 do ll=1,2
7334                   do mm=1,2
7335                     ind=ind+1
7336                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
7337                   enddo
7338                 enddo
7339               enddo
7340             enddo
7341           endif
7342         enddo
7343         enddo
7344       enddo
7345       if (lprn) then
7346       write (iout,*)
7347      &  "Numbers of contacts to be sent to other processors",
7348      &  (ncont_sent(i),i=1,ntask_cont_to)
7349       write (iout,*) "Contacts sent"
7350       do ii=1,ntask_cont_to
7351         nn=ncont_sent(ii)
7352         iproc=itask_cont_to(ii)
7353         write (iout,*) nn," contacts to processor",iproc,
7354      &   " of CONT_TO_COMM group"
7355         do i=1,nn
7356           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
7357         enddo
7358       enddo
7359       call flush(iout)
7360       endif
7361       CorrelType=477
7362       CorrelID=fg_rank+1
7363       CorrelType1=478
7364       CorrelID1=nfgtasks+fg_rank+1
7365       ireq=0
7366 C Receive the numbers of needed contacts from other processors
7367       do ii=1,ntask_cont_from
7368         iproc=itask_cont_from(ii)
7369         ireq=ireq+1
7370         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7371      &    FG_COMM,req(ireq),IERR)
7372       enddo
7373 c      write (iout,*) "IRECV ended"
7374 c      call flush(iout)
7375 C Send the number of contacts needed by other processors
7376       do ii=1,ntask_cont_to
7377         iproc=itask_cont_to(ii)
7378         ireq=ireq+1
7379         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7380      &    FG_COMM,req(ireq),IERR)
7381       enddo
7382 c      write (iout,*) "ISEND ended"
7383 c      write (iout,*) "number of requests (nn)",ireq
7384       call flush(iout)
7385       if (ireq.gt.0)
7386      &  call MPI_Waitall(ireq,req,status_array,ierr)
7387 c      write (iout,*)
7388 c     &  "Numbers of contacts to be received from other processors",
7389 c     &  (ncont_recv(i),i=1,ntask_cont_from)
7390 c      call flush(iout)
7391 C Receive contacts
7392       ireq=0
7393       do ii=1,ntask_cont_from
7394         iproc=itask_cont_from(ii)
7395         nn=ncont_recv(ii)
7396 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7397 c     &   " of CONT_TO_COMM group"
7398         call flush(iout)
7399         if (nn.gt.0) then
7400           ireq=ireq+1
7401           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
7402      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7403 c          write (iout,*) "ireq,req",ireq,req(ireq)
7404         endif
7405       enddo
7406 C Send the contacts to processors that need them
7407       do ii=1,ntask_cont_to
7408         iproc=itask_cont_to(ii)
7409         nn=ncont_sent(ii)
7410 c        write (iout,*) nn," contacts to processor",iproc,
7411 c     &   " of CONT_TO_COMM group"
7412         if (nn.gt.0) then
7413           ireq=ireq+1
7414           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
7415      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7416 c          write (iout,*) "ireq,req",ireq,req(ireq)
7417 c          do i=1,nn
7418 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7419 c          enddo
7420         endif
7421       enddo
7422 c      write (iout,*) "number of requests (contacts)",ireq
7423 c      write (iout,*) "req",(req(i),i=1,4)
7424 c      call flush(iout)
7425       if (ireq.gt.0)
7426      & call MPI_Waitall(ireq,req,status_array,ierr)
7427       do iii=1,ntask_cont_from
7428         iproc=itask_cont_from(iii)
7429         nn=ncont_recv(iii)
7430         if (lprn) then
7431         write (iout,*) "Received",nn," contacts from processor",iproc,
7432      &   " of CONT_FROM_COMM group"
7433         call flush(iout)
7434         do i=1,nn
7435           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
7436         enddo
7437         call flush(iout)
7438         endif
7439         do i=1,nn
7440           ii=zapas_recv(1,i,iii)
7441 c Flag the received contacts to prevent double-counting
7442           jj=-zapas_recv(2,i,iii)
7443 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7444 c          call flush(iout)
7445           nnn=num_cont_hb(ii)+1
7446           num_cont_hb(ii)=nnn
7447           jcont_hb(nnn,ii)=jj
7448           d_cont(nnn,ii)=zapas_recv(3,i,iii)
7449           ind=3
7450           do kk=1,3
7451             ind=ind+1
7452             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
7453           enddo
7454           do kk=1,2
7455             do ll=1,2
7456               ind=ind+1
7457               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
7458             enddo
7459           enddo
7460           do jj=1,5
7461             do kk=1,3
7462               do ll=1,2
7463                 do mm=1,2
7464                   ind=ind+1
7465                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
7466                 enddo
7467               enddo
7468             enddo
7469           enddo
7470         enddo
7471       enddo
7472       call flush(iout)
7473       if (lprn) then
7474         write (iout,'(a)') 'Contact function values after receive:'
7475         do i=nnt,nct-2
7476           write (iout,'(2i3,50(1x,i3,5f6.3))')
7477      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7478      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7479         enddo
7480         call flush(iout)
7481       endif
7482    30 continue
7483 #endif
7484       if (lprn) then
7485         write (iout,'(a)') 'Contact function values:'
7486         do i=nnt,nct-2
7487           write (iout,'(2i3,50(1x,i2,5f6.3))')
7488      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7489      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7490         enddo
7491       endif
7492       ecorr=0.0D0
7493       ecorr5=0.0d0
7494       ecorr6=0.0d0
7495 C Remove the loop below after debugging !!!
7496       do i=nnt,nct
7497         do j=1,3
7498           gradcorr(j,i)=0.0D0
7499           gradxorr(j,i)=0.0D0
7500         enddo
7501       enddo
7502 C Calculate the dipole-dipole interaction energies
7503       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7504       do i=iatel_s,iatel_e+1
7505         num_conti=num_cont_hb(i)
7506         do jj=1,num_conti
7507           j=jcont_hb(jj,i)
7508 #ifdef MOMENT
7509           call dipole(i,j,jj)
7510 #endif
7511         enddo
7512       enddo
7513       endif
7514 C Calculate the local-electrostatic correlation terms
7515 c                write (iout,*) "gradcorr5 in eello5 before loop"
7516 c                do iii=1,nres
7517 c                  write (iout,'(i5,3f10.5)')
7518 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7519 c                enddo
7520       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7521 c        write (iout,*) "corr loop i",i
7522         i1=i+1
7523         num_conti=num_cont_hb(i)
7524         num_conti1=num_cont_hb(i+1)
7525         do jj=1,num_conti
7526           j=jcont_hb(jj,i)
7527           jp=iabs(j)
7528           do kk=1,num_conti1
7529             j1=jcont_hb(kk,i1)
7530             jp1=iabs(j1)
7531 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7532 c     &         ' jj=',jj,' kk=',kk
7533 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
7534             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7535      &          .or. j.lt.0 .and. j1.gt.0) .and.
7536      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7537 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7538 C The system gains extra energy.
7539               n_corr=n_corr+1
7540               sqd1=dsqrt(d_cont(jj,i))
7541               sqd2=dsqrt(d_cont(kk,i1))
7542               sred_geom = sqd1*sqd2
7543               IF (sred_geom.lt.cutoff_corr) THEN
7544                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
7545      &            ekont,fprimcont)
7546 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7547 cd     &         ' jj=',jj,' kk=',kk
7548                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7549                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7550                 do l=1,3
7551                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7552                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7553                 enddo
7554                 n_corr1=n_corr1+1
7555 cd               write (iout,*) 'sred_geom=',sred_geom,
7556 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
7557 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7558 cd               write (iout,*) "g_contij",g_contij
7559 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7560 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7561                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7562                 if (wcorr4.gt.0.0d0)
7563      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7564                   if (energy_dec.and.wcorr4.gt.0.0d0)
7565      1                 write (iout,'(a6,4i5,0pf7.3)')
7566      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7567 c                write (iout,*) "gradcorr5 before eello5"
7568 c                do iii=1,nres
7569 c                  write (iout,'(i5,3f10.5)')
7570 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7571 c                enddo
7572                 if (wcorr5.gt.0.0d0)
7573      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7574 c                write (iout,*) "gradcorr5 after eello5"
7575 c                do iii=1,nres
7576 c                  write (iout,'(i5,3f10.5)')
7577 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7578 c                enddo
7579                   if (energy_dec.and.wcorr5.gt.0.0d0)
7580      1                 write (iout,'(a6,4i5,0pf7.3)')
7581      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7582 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7583 cd                write(2,*)'ijkl',i,jp,i+1,jp1
7584                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
7585      &               .or. wturn6.eq.0.0d0))then
7586 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7587                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7588                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7589      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7590 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7591 cd     &            'ecorr6=',ecorr6
7592 cd                write (iout,'(4e15.5)') sred_geom,
7593 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7594 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7595 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7596                 else if (wturn6.gt.0.0d0
7597      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7598 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7599                   eturn6=eturn6+eello_turn6(i,jj,kk)
7600                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7601      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7602 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
7603                 endif
7604               ENDIF
7605 1111          continue
7606             endif
7607           enddo ! kk
7608         enddo ! jj
7609       enddo ! i
7610       do i=1,nres
7611         num_cont_hb(i)=num_cont_hb_old(i)
7612       enddo
7613 c                write (iout,*) "gradcorr5 in eello5"
7614 c                do iii=1,nres
7615 c                  write (iout,'(i5,3f10.5)')
7616 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7617 c                enddo
7618       return
7619       end
7620 c------------------------------------------------------------------------------
7621       subroutine add_hb_contact_eello(ii,jj,itask)
7622       implicit real*8 (a-h,o-z)
7623       include "DIMENSIONS"
7624       include "COMMON.IOUNITS"
7625       integer max_cont
7626       integer max_dim
7627       parameter (max_cont=maxconts)
7628       parameter (max_dim=70)
7629       include "COMMON.CONTACTS"
7630       double precision zapas(max_dim,maxconts,max_fg_procs),
7631      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7632       common /przechowalnia/ zapas
7633       integer i,j,ii,jj,iproc,itask(4),nn
7634 c      write (iout,*) "itask",itask
7635       do i=1,2
7636         iproc=itask(i)
7637         if (iproc.gt.0) then
7638           do j=1,num_cont_hb(ii)
7639             jjc=jcont_hb(j,ii)
7640 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
7641             if (jjc.eq.jj) then
7642               ncont_sent(iproc)=ncont_sent(iproc)+1
7643               nn=ncont_sent(iproc)
7644               zapas(1,nn,iproc)=ii
7645               zapas(2,nn,iproc)=jjc
7646               zapas(3,nn,iproc)=d_cont(j,ii)
7647               ind=3
7648               do kk=1,3
7649                 ind=ind+1
7650                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
7651               enddo
7652               do kk=1,2
7653                 do ll=1,2
7654                   ind=ind+1
7655                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
7656                 enddo
7657               enddo
7658               do jj=1,5
7659                 do kk=1,3
7660                   do ll=1,2
7661                     do mm=1,2
7662                       ind=ind+1
7663                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
7664                     enddo
7665                   enddo
7666                 enddo
7667               enddo
7668               exit
7669             endif
7670           enddo
7671         endif
7672       enddo
7673       return
7674       end
7675 c------------------------------------------------------------------------------
7676       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7677       implicit real*8 (a-h,o-z)
7678       include 'DIMENSIONS'
7679       include 'COMMON.IOUNITS'
7680       include 'COMMON.DERIV'
7681       include 'COMMON.INTERACT'
7682       include 'COMMON.CONTACTS'
7683       double precision gx(3),gx1(3)
7684       logical lprn
7685       lprn=.false.
7686       eij=facont_hb(jj,i)
7687       ekl=facont_hb(kk,k)
7688       ees0pij=ees0p(jj,i)
7689       ees0pkl=ees0p(kk,k)
7690       ees0mij=ees0m(jj,i)
7691       ees0mkl=ees0m(kk,k)
7692       ekont=eij*ekl
7693       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7694 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7695 C Following 4 lines for diagnostics.
7696 cd    ees0pkl=0.0D0
7697 cd    ees0pij=1.0D0
7698 cd    ees0mkl=0.0D0
7699 cd    ees0mij=1.0D0
7700 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7701 c     & 'Contacts ',i,j,
7702 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7703 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7704 c     & 'gradcorr_long'
7705 C Calculate the multi-body contribution to energy.
7706 c      ecorr=ecorr+ekont*ees
7707 C Calculate multi-body contributions to the gradient.
7708       coeffpees0pij=coeffp*ees0pij
7709       coeffmees0mij=coeffm*ees0mij
7710       coeffpees0pkl=coeffp*ees0pkl
7711       coeffmees0mkl=coeffm*ees0mkl
7712       do ll=1,3
7713 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7714         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
7715      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
7716      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
7717         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
7718      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
7719      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
7720 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7721         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
7722      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
7723      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
7724         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
7725      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
7726      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
7727         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
7728      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
7729      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
7730         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7731         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7732         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
7733      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
7734      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
7735         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7736         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7737 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7738       enddo
7739 c      write (iout,*)
7740 cgrad      do m=i+1,j-1
7741 cgrad        do ll=1,3
7742 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7743 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7744 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7745 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7746 cgrad        enddo
7747 cgrad      enddo
7748 cgrad      do m=k+1,l-1
7749 cgrad        do ll=1,3
7750 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7751 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7752 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7753 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7754 cgrad        enddo
7755 cgrad      enddo
7756 c      write (iout,*) "ehbcorr",ekont*ees
7757       ehbcorr=ekont*ees
7758       return
7759       end
7760 #ifdef MOMENT
7761 C---------------------------------------------------------------------------
7762       subroutine dipole(i,j,jj)
7763       implicit real*8 (a-h,o-z)
7764       include 'DIMENSIONS'
7765       include 'COMMON.IOUNITS'
7766       include 'COMMON.CHAIN'
7767       include 'COMMON.FFIELD'
7768       include 'COMMON.DERIV'
7769       include 'COMMON.INTERACT'
7770       include 'COMMON.CONTACTS'
7771       include 'COMMON.TORSION'
7772       include 'COMMON.VAR'
7773       include 'COMMON.GEO'
7774       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7775      &  auxmat(2,2)
7776       iti1 = itortyp(itype(i+1))
7777       if (j.lt.nres-1) then
7778         itj1 = itortyp(itype(j+1))
7779       else
7780         itj1=ntortyp+1
7781       endif
7782       do iii=1,2
7783         dipi(iii,1)=Ub2(iii,i)
7784         dipderi(iii)=Ub2der(iii,i)
7785         dipi(iii,2)=b1(iii,iti1)
7786         dipj(iii,1)=Ub2(iii,j)
7787         dipderj(iii)=Ub2der(iii,j)
7788         dipj(iii,2)=b1(iii,itj1)
7789       enddo
7790       kkk=0
7791       do iii=1,2
7792         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7793         do jjj=1,2
7794           kkk=kkk+1
7795           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7796         enddo
7797       enddo
7798       do kkk=1,5
7799         do lll=1,3
7800           mmm=0
7801           do iii=1,2
7802             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7803      &        auxvec(1))
7804             do jjj=1,2
7805               mmm=mmm+1
7806               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7807             enddo
7808           enddo
7809         enddo
7810       enddo
7811       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7812       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7813       do iii=1,2
7814         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7815       enddo
7816       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7817       do iii=1,2
7818         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7819       enddo
7820       return
7821       end
7822 #endif
7823 C---------------------------------------------------------------------------
7824       subroutine calc_eello(i,j,k,l,jj,kk)
7825 C
7826 C This subroutine computes matrices and vectors needed to calculate
7827 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7828 C
7829       implicit real*8 (a-h,o-z)
7830       include 'DIMENSIONS'
7831       include 'COMMON.IOUNITS'
7832       include 'COMMON.CHAIN'
7833       include 'COMMON.DERIV'
7834       include 'COMMON.INTERACT'
7835       include 'COMMON.CONTACTS'
7836       include 'COMMON.TORSION'
7837       include 'COMMON.VAR'
7838       include 'COMMON.GEO'
7839       include 'COMMON.FFIELD'
7840       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7841      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7842       logical lprn
7843       common /kutas/ lprn
7844 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7845 cd     & ' jj=',jj,' kk=',kk
7846 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7847 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7848 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7849       do iii=1,2
7850         do jjj=1,2
7851           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7852           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7853         enddo
7854       enddo
7855       call transpose2(aa1(1,1),aa1t(1,1))
7856       call transpose2(aa2(1,1),aa2t(1,1))
7857       do kkk=1,5
7858         do lll=1,3
7859           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7860      &      aa1tder(1,1,lll,kkk))
7861           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7862      &      aa2tder(1,1,lll,kkk))
7863         enddo
7864       enddo
7865       if (l.eq.j+1) then
7866 C parallel orientation of the two CA-CA-CA frames.
7867         if (i.gt.1) then
7868           iti=itortyp(itype(i))
7869         else
7870           iti=ntortyp+1
7871         endif
7872         itk1=itortyp(itype(k+1))
7873         itj=itortyp(itype(j))
7874         if (l.lt.nres-1) then
7875           itl1=itortyp(itype(l+1))
7876         else
7877           itl1=ntortyp+1
7878         endif
7879 C A1 kernel(j+1) A2T
7880 cd        do iii=1,2
7881 cd          write (iout,'(3f10.5,5x,3f10.5)')
7882 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7883 cd        enddo
7884         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7885      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7886      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7887 C Following matrices are needed only for 6-th order cumulants
7888         IF (wcorr6.gt.0.0d0) THEN
7889         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7890      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7891      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7892         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7893      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7894      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7895      &   ADtEAderx(1,1,1,1,1,1))
7896         lprn=.false.
7897         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7898      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7899      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7900      &   ADtEA1derx(1,1,1,1,1,1))
7901         ENDIF
7902 C End 6-th order cumulants
7903 cd        lprn=.false.
7904 cd        if (lprn) then
7905 cd        write (2,*) 'In calc_eello6'
7906 cd        do iii=1,2
7907 cd          write (2,*) 'iii=',iii
7908 cd          do kkk=1,5
7909 cd            write (2,*) 'kkk=',kkk
7910 cd            do jjj=1,2
7911 cd              write (2,'(3(2f10.5),5x)')
7912 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7913 cd            enddo
7914 cd          enddo
7915 cd        enddo
7916 cd        endif
7917         call transpose2(EUgder(1,1,k),auxmat(1,1))
7918         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7919         call transpose2(EUg(1,1,k),auxmat(1,1))
7920         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7921         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7922         do iii=1,2
7923           do kkk=1,5
7924             do lll=1,3
7925               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7926      &          EAEAderx(1,1,lll,kkk,iii,1))
7927             enddo
7928           enddo
7929         enddo
7930 C A1T kernel(i+1) A2
7931         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7932      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7933      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7934 C Following matrices are needed only for 6-th order cumulants
7935         IF (wcorr6.gt.0.0d0) THEN
7936         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7937      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7938      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7939         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7940      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7941      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7942      &   ADtEAderx(1,1,1,1,1,2))
7943         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7944      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7945      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7946      &   ADtEA1derx(1,1,1,1,1,2))
7947         ENDIF
7948 C End 6-th order cumulants
7949         call transpose2(EUgder(1,1,l),auxmat(1,1))
7950         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7951         call transpose2(EUg(1,1,l),auxmat(1,1))
7952         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7953         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7954         do iii=1,2
7955           do kkk=1,5
7956             do lll=1,3
7957               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7958      &          EAEAderx(1,1,lll,kkk,iii,2))
7959             enddo
7960           enddo
7961         enddo
7962 C AEAb1 and AEAb2
7963 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7964 C They are needed only when the fifth- or the sixth-order cumulants are
7965 C indluded.
7966         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7967         call transpose2(AEA(1,1,1),auxmat(1,1))
7968         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7969         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7970         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7971         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7972         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7973         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7974         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7975         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7976         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7977         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7978         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7979         call transpose2(AEA(1,1,2),auxmat(1,1))
7980         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7981         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7982         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7983         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7984         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7985         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7986         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7987         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7988         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7989         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7990         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7991 C Calculate the Cartesian derivatives of the vectors.
7992         do iii=1,2
7993           do kkk=1,5
7994             do lll=1,3
7995               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7996               call matvec2(auxmat(1,1),b1(1,iti),
7997      &          AEAb1derx(1,lll,kkk,iii,1,1))
7998               call matvec2(auxmat(1,1),Ub2(1,i),
7999      &          AEAb2derx(1,lll,kkk,iii,1,1))
8000               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8001      &          AEAb1derx(1,lll,kkk,iii,2,1))
8002               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8003      &          AEAb2derx(1,lll,kkk,iii,2,1))
8004               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8005               call matvec2(auxmat(1,1),b1(1,itj),
8006      &          AEAb1derx(1,lll,kkk,iii,1,2))
8007               call matvec2(auxmat(1,1),Ub2(1,j),
8008      &          AEAb2derx(1,lll,kkk,iii,1,2))
8009               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8010      &          AEAb1derx(1,lll,kkk,iii,2,2))
8011               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
8012      &          AEAb2derx(1,lll,kkk,iii,2,2))
8013             enddo
8014           enddo
8015         enddo
8016         ENDIF
8017 C End vectors
8018       else
8019 C Antiparallel orientation of the two CA-CA-CA frames.
8020         if (i.gt.1) then
8021           iti=itortyp(itype(i))
8022         else
8023           iti=ntortyp+1
8024         endif
8025         itk1=itortyp(itype(k+1))
8026         itl=itortyp(itype(l))
8027         itj=itortyp(itype(j))
8028         if (j.lt.nres-1) then
8029           itj1=itortyp(itype(j+1))
8030         else
8031           itj1=ntortyp+1
8032         endif
8033 C A2 kernel(j-1)T A1T
8034         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8035      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
8036      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8037 C Following matrices are needed only for 6-th order cumulants
8038         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8039      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8040         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8041      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
8042      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8043         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8044      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
8045      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8046      &   ADtEAderx(1,1,1,1,1,1))
8047         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8048      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
8049      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8050      &   ADtEA1derx(1,1,1,1,1,1))
8051         ENDIF
8052 C End 6-th order cumulants
8053         call transpose2(EUgder(1,1,k),auxmat(1,1))
8054         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8055         call transpose2(EUg(1,1,k),auxmat(1,1))
8056         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8057         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8058         do iii=1,2
8059           do kkk=1,5
8060             do lll=1,3
8061               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8062      &          EAEAderx(1,1,lll,kkk,iii,1))
8063             enddo
8064           enddo
8065         enddo
8066 C A2T kernel(i+1)T A1
8067         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8068      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
8069      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8070 C Following matrices are needed only for 6-th order cumulants
8071         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8072      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8073         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8074      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
8075      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8076         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8077      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
8078      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8079      &   ADtEAderx(1,1,1,1,1,2))
8080         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8081      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
8082      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8083      &   ADtEA1derx(1,1,1,1,1,2))
8084         ENDIF
8085 C End 6-th order cumulants
8086         call transpose2(EUgder(1,1,j),auxmat(1,1))
8087         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
8088         call transpose2(EUg(1,1,j),auxmat(1,1))
8089         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8090         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8091         do iii=1,2
8092           do kkk=1,5
8093             do lll=1,3
8094               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8095      &          EAEAderx(1,1,lll,kkk,iii,2))
8096             enddo
8097           enddo
8098         enddo
8099 C AEAb1 and AEAb2
8100 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8101 C They are needed only when the fifth- or the sixth-order cumulants are
8102 C indluded.
8103         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
8104      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
8105         call transpose2(AEA(1,1,1),auxmat(1,1))
8106         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
8107         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8108         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8109         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8110         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
8111         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8112         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
8113         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
8114         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8115         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8116         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8117         call transpose2(AEA(1,1,2),auxmat(1,1))
8118         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
8119         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
8120         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
8121         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8122         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
8123         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
8124         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
8125         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
8126         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
8127         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
8128         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
8129 C Calculate the Cartesian derivatives of the vectors.
8130         do iii=1,2
8131           do kkk=1,5
8132             do lll=1,3
8133               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8134               call matvec2(auxmat(1,1),b1(1,iti),
8135      &          AEAb1derx(1,lll,kkk,iii,1,1))
8136               call matvec2(auxmat(1,1),Ub2(1,i),
8137      &          AEAb2derx(1,lll,kkk,iii,1,1))
8138               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8139      &          AEAb1derx(1,lll,kkk,iii,2,1))
8140               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8141      &          AEAb2derx(1,lll,kkk,iii,2,1))
8142               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8143               call matvec2(auxmat(1,1),b1(1,itl),
8144      &          AEAb1derx(1,lll,kkk,iii,1,2))
8145               call matvec2(auxmat(1,1),Ub2(1,l),
8146      &          AEAb2derx(1,lll,kkk,iii,1,2))
8147               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
8148      &          AEAb1derx(1,lll,kkk,iii,2,2))
8149               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
8150      &          AEAb2derx(1,lll,kkk,iii,2,2))
8151             enddo
8152           enddo
8153         enddo
8154         ENDIF
8155 C End vectors
8156       endif
8157       return
8158       end
8159 C---------------------------------------------------------------------------
8160       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
8161      &  KK,KKderg,AKA,AKAderg,AKAderx)
8162       implicit none
8163       integer nderg
8164       logical transp
8165       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
8166      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
8167      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
8168       integer iii,kkk,lll
8169       integer jjj,mmm
8170       logical lprn
8171       common /kutas/ lprn
8172       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
8173       do iii=1,nderg
8174         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
8175      &    AKAderg(1,1,iii))
8176       enddo
8177 cd      if (lprn) write (2,*) 'In kernel'
8178       do kkk=1,5
8179 cd        if (lprn) write (2,*) 'kkk=',kkk
8180         do lll=1,3
8181           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
8182      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
8183 cd          if (lprn) then
8184 cd            write (2,*) 'lll=',lll
8185 cd            write (2,*) 'iii=1'
8186 cd            do jjj=1,2
8187 cd              write (2,'(3(2f10.5),5x)')
8188 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
8189 cd            enddo
8190 cd          endif
8191           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
8192      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
8193 cd          if (lprn) then
8194 cd            write (2,*) 'lll=',lll
8195 cd            write (2,*) 'iii=2'
8196 cd            do jjj=1,2
8197 cd              write (2,'(3(2f10.5),5x)')
8198 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
8199 cd            enddo
8200 cd          endif
8201         enddo
8202       enddo
8203       return
8204       end
8205 C---------------------------------------------------------------------------
8206       double precision function eello4(i,j,k,l,jj,kk)
8207       implicit real*8 (a-h,o-z)
8208       include 'DIMENSIONS'
8209       include 'COMMON.IOUNITS'
8210       include 'COMMON.CHAIN'
8211       include 'COMMON.DERIV'
8212       include 'COMMON.INTERACT'
8213       include 'COMMON.CONTACTS'
8214       include 'COMMON.TORSION'
8215       include 'COMMON.VAR'
8216       include 'COMMON.GEO'
8217       double precision pizda(2,2),ggg1(3),ggg2(3)
8218 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8219 cd        eello4=0.0d0
8220 cd        return
8221 cd      endif
8222 cd      print *,'eello4:',i,j,k,l,jj,kk
8223 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
8224 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
8225 cold      eij=facont_hb(jj,i)
8226 cold      ekl=facont_hb(kk,k)
8227 cold      ekont=eij*ekl
8228       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8229 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8230       gcorr_loc(k-1)=gcorr_loc(k-1)
8231      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8232       if (l.eq.j+1) then
8233         gcorr_loc(l-1)=gcorr_loc(l-1)
8234      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8235       else
8236         gcorr_loc(j-1)=gcorr_loc(j-1)
8237      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8238       endif
8239       do iii=1,2
8240         do kkk=1,5
8241           do lll=1,3
8242             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
8243      &                        -EAEAderx(2,2,lll,kkk,iii,1)
8244 cd            derx(lll,kkk,iii)=0.0d0
8245           enddo
8246         enddo
8247       enddo
8248 cd      gcorr_loc(l-1)=0.0d0
8249 cd      gcorr_loc(j-1)=0.0d0
8250 cd      gcorr_loc(k-1)=0.0d0
8251 cd      eel4=1.0d0
8252 cd      write (iout,*)'Contacts have occurred for peptide groups',
8253 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
8254 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8255       if (j.lt.nres-1) then
8256         j1=j+1
8257         j2=j-1
8258       else
8259         j1=j-1
8260         j2=j-2
8261       endif
8262       if (l.lt.nres-1) then
8263         l1=l+1
8264         l2=l-1
8265       else
8266         l1=l-1
8267         l2=l-2
8268       endif
8269       do ll=1,3
8270 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
8271 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
8272         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8273         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8274 cgrad        ghalf=0.5d0*ggg1(ll)
8275         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8276         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8277         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8278         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8279         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8280         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8281 cgrad        ghalf=0.5d0*ggg2(ll)
8282         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8283         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8284         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8285         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8286         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8287         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8288       enddo
8289 cgrad      do m=i+1,j-1
8290 cgrad        do ll=1,3
8291 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
8292 cgrad        enddo
8293 cgrad      enddo
8294 cgrad      do m=k+1,l-1
8295 cgrad        do ll=1,3
8296 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
8297 cgrad        enddo
8298 cgrad      enddo
8299 cgrad      do m=i+2,j2
8300 cgrad        do ll=1,3
8301 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8302 cgrad        enddo
8303 cgrad      enddo
8304 cgrad      do m=k+2,l2
8305 cgrad        do ll=1,3
8306 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8307 cgrad        enddo
8308 cgrad      enddo
8309 cd      do iii=1,nres-3
8310 cd        write (2,*) iii,gcorr_loc(iii)
8311 cd      enddo
8312       eello4=ekont*eel4
8313 cd      write (2,*) 'ekont',ekont
8314 cd      write (iout,*) 'eello4',ekont*eel4
8315       return
8316       end
8317 C---------------------------------------------------------------------------
8318       double precision function eello5(i,j,k,l,jj,kk)
8319       implicit real*8 (a-h,o-z)
8320       include 'DIMENSIONS'
8321       include 'COMMON.IOUNITS'
8322       include 'COMMON.CHAIN'
8323       include 'COMMON.DERIV'
8324       include 'COMMON.INTERACT'
8325       include 'COMMON.CONTACTS'
8326       include 'COMMON.TORSION'
8327       include 'COMMON.VAR'
8328       include 'COMMON.GEO'
8329       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
8330       double precision ggg1(3),ggg2(3)
8331 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8332 C                                                                              C
8333 C                            Parallel chains                                   C
8334 C                                                                              C
8335 C          o             o                   o             o                   C
8336 C         /l\           / \             \   / \           / \   /              C
8337 C        /   \         /   \             \ /   \         /   \ /               C
8338 C       j| o |l1       | o |              o| o |         | o |o                C
8339 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8340 C      \i/   \         /   \ /             /   \         /   \                 C
8341 C       o    k1             o                                                  C
8342 C         (I)          (II)                (III)          (IV)                 C
8343 C                                                                              C
8344 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8345 C                                                                              C
8346 C                            Antiparallel chains                               C
8347 C                                                                              C
8348 C          o             o                   o             o                   C
8349 C         /j\           / \             \   / \           / \   /              C
8350 C        /   \         /   \             \ /   \         /   \ /               C
8351 C      j1| o |l        | o |              o| o |         | o |o                C
8352 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8353 C      \i/   \         /   \ /             /   \         /   \                 C
8354 C       o     k1            o                                                  C
8355 C         (I)          (II)                (III)          (IV)                 C
8356 C                                                                              C
8357 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8358 C                                                                              C
8359 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
8360 C                                                                              C
8361 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8362 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8363 cd        eello5=0.0d0
8364 cd        return
8365 cd      endif
8366 cd      write (iout,*)
8367 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8368 cd     &   ' and',k,l
8369       itk=itortyp(itype(k))
8370       itl=itortyp(itype(l))
8371       itj=itortyp(itype(j))
8372       eello5_1=0.0d0
8373       eello5_2=0.0d0
8374       eello5_3=0.0d0
8375       eello5_4=0.0d0
8376 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8377 cd     &   eel5_3_num,eel5_4_num)
8378       do iii=1,2
8379         do kkk=1,5
8380           do lll=1,3
8381             derx(lll,kkk,iii)=0.0d0
8382           enddo
8383         enddo
8384       enddo
8385 cd      eij=facont_hb(jj,i)
8386 cd      ekl=facont_hb(kk,k)
8387 cd      ekont=eij*ekl
8388 cd      write (iout,*)'Contacts have occurred for peptide groups',
8389 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
8390 cd      goto 1111
8391 C Contribution from the graph I.
8392 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8393 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8394       call transpose2(EUg(1,1,k),auxmat(1,1))
8395       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8396       vv(1)=pizda(1,1)-pizda(2,2)
8397       vv(2)=pizda(1,2)+pizda(2,1)
8398       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
8399      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8400 C Explicit gradient in virtual-dihedral angles.
8401       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
8402      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
8403      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8404       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8405       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8406       vv(1)=pizda(1,1)-pizda(2,2)
8407       vv(2)=pizda(1,2)+pizda(2,1)
8408       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8409      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
8410      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8411       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8412       vv(1)=pizda(1,1)-pizda(2,2)
8413       vv(2)=pizda(1,2)+pizda(2,1)
8414       if (l.eq.j+1) then
8415         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
8416      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8417      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8418       else
8419         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
8420      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8421      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8422       endif
8423 C Cartesian gradient
8424       do iii=1,2
8425         do kkk=1,5
8426           do lll=1,3
8427             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
8428      &        pizda(1,1))
8429             vv(1)=pizda(1,1)-pizda(2,2)
8430             vv(2)=pizda(1,2)+pizda(2,1)
8431             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8432      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
8433      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8434           enddo
8435         enddo
8436       enddo
8437 c      goto 1112
8438 c1111  continue
8439 C Contribution from graph II
8440       call transpose2(EE(1,1,itk),auxmat(1,1))
8441       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8442       vv(1)=pizda(1,1)+pizda(2,2)
8443       vv(2)=pizda(2,1)-pizda(1,2)
8444       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
8445      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
8446 C Explicit gradient in virtual-dihedral angles.
8447       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8448      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8449       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8450       vv(1)=pizda(1,1)+pizda(2,2)
8451       vv(2)=pizda(2,1)-pizda(1,2)
8452       if (l.eq.j+1) then
8453         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8454      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
8455      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8456       else
8457         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8458      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
8459      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8460       endif
8461 C Cartesian gradient
8462       do iii=1,2
8463         do kkk=1,5
8464           do lll=1,3
8465             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8466      &        pizda(1,1))
8467             vv(1)=pizda(1,1)+pizda(2,2)
8468             vv(2)=pizda(2,1)-pizda(1,2)
8469             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8470      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
8471      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
8472           enddo
8473         enddo
8474       enddo
8475 cd      goto 1112
8476 cd1111  continue
8477       if (l.eq.j+1) then
8478 cd        goto 1110
8479 C Parallel orientation
8480 C Contribution from graph III
8481         call transpose2(EUg(1,1,l),auxmat(1,1))
8482         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8483         vv(1)=pizda(1,1)-pizda(2,2)
8484         vv(2)=pizda(1,2)+pizda(2,1)
8485         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
8486      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8487 C Explicit gradient in virtual-dihedral angles.
8488         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8489      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
8490      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8491         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8492         vv(1)=pizda(1,1)-pizda(2,2)
8493         vv(2)=pizda(1,2)+pizda(2,1)
8494         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8495      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
8496      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8497         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8498         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8499         vv(1)=pizda(1,1)-pizda(2,2)
8500         vv(2)=pizda(1,2)+pizda(2,1)
8501         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8502      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
8503      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8504 C Cartesian gradient
8505         do iii=1,2
8506           do kkk=1,5
8507             do lll=1,3
8508               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8509      &          pizda(1,1))
8510               vv(1)=pizda(1,1)-pizda(2,2)
8511               vv(2)=pizda(1,2)+pizda(2,1)
8512               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8513      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
8514      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8515             enddo
8516           enddo
8517         enddo
8518 cd        goto 1112
8519 C Contribution from graph IV
8520 cd1110    continue
8521         call transpose2(EE(1,1,itl),auxmat(1,1))
8522         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8523         vv(1)=pizda(1,1)+pizda(2,2)
8524         vv(2)=pizda(2,1)-pizda(1,2)
8525         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
8526      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
8527 C Explicit gradient in virtual-dihedral angles.
8528         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8529      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8530         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8531         vv(1)=pizda(1,1)+pizda(2,2)
8532         vv(2)=pizda(2,1)-pizda(1,2)
8533         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8534      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
8535      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8536 C Cartesian gradient
8537         do iii=1,2
8538           do kkk=1,5
8539             do lll=1,3
8540               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8541      &          pizda(1,1))
8542               vv(1)=pizda(1,1)+pizda(2,2)
8543               vv(2)=pizda(2,1)-pizda(1,2)
8544               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8545      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
8546      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
8547             enddo
8548           enddo
8549         enddo
8550       else
8551 C Antiparallel orientation
8552 C Contribution from graph III
8553 c        goto 1110
8554         call transpose2(EUg(1,1,j),auxmat(1,1))
8555         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8556         vv(1)=pizda(1,1)-pizda(2,2)
8557         vv(2)=pizda(1,2)+pizda(2,1)
8558         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
8559      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8560 C Explicit gradient in virtual-dihedral angles.
8561         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8562      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
8563      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8564         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8565         vv(1)=pizda(1,1)-pizda(2,2)
8566         vv(2)=pizda(1,2)+pizda(2,1)
8567         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8568      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
8569      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8570         call transpose2(EUgder(1,1,j),auxmat1(1,1))
8571         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8572         vv(1)=pizda(1,1)-pizda(2,2)
8573         vv(2)=pizda(1,2)+pizda(2,1)
8574         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8575      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
8576      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8577 C Cartesian gradient
8578         do iii=1,2
8579           do kkk=1,5
8580             do lll=1,3
8581               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8582      &          pizda(1,1))
8583               vv(1)=pizda(1,1)-pizda(2,2)
8584               vv(2)=pizda(1,2)+pizda(2,1)
8585               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8586      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
8587      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8588             enddo
8589           enddo
8590         enddo
8591 cd        goto 1112
8592 C Contribution from graph IV
8593 1110    continue
8594         call transpose2(EE(1,1,itj),auxmat(1,1))
8595         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8596         vv(1)=pizda(1,1)+pizda(2,2)
8597         vv(2)=pizda(2,1)-pizda(1,2)
8598         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
8599      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
8600 C Explicit gradient in virtual-dihedral angles.
8601         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8602      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
8603         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8604         vv(1)=pizda(1,1)+pizda(2,2)
8605         vv(2)=pizda(2,1)-pizda(1,2)
8606         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8607      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
8608      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
8609 C Cartesian gradient
8610         do iii=1,2
8611           do kkk=1,5
8612             do lll=1,3
8613               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8614      &          pizda(1,1))
8615               vv(1)=pizda(1,1)+pizda(2,2)
8616               vv(2)=pizda(2,1)-pizda(1,2)
8617               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8618      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
8619      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
8620             enddo
8621           enddo
8622         enddo
8623       endif
8624 1112  continue
8625       eel5=eello5_1+eello5_2+eello5_3+eello5_4
8626 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
8627 cd        write (2,*) 'ijkl',i,j,k,l
8628 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
8629 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
8630 cd      endif
8631 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
8632 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
8633 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
8634 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
8635       if (j.lt.nres-1) then
8636         j1=j+1
8637         j2=j-1
8638       else
8639         j1=j-1
8640         j2=j-2
8641       endif
8642       if (l.lt.nres-1) then
8643         l1=l+1
8644         l2=l-1
8645       else
8646         l1=l-1
8647         l2=l-2
8648       endif
8649 cd      eij=1.0d0
8650 cd      ekl=1.0d0
8651 cd      ekont=1.0d0
8652 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
8653 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
8654 C        summed up outside the subrouine as for the other subroutines
8655 C        handling long-range interactions. The old code is commented out
8656 C        with "cgrad" to keep track of changes.
8657       do ll=1,3
8658 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
8659 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
8660         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
8661         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
8662 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
8663 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
8664 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
8665 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
8666 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
8667 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
8668 c     &   gradcorr5ij,
8669 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
8670 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
8671 cgrad        ghalf=0.5d0*ggg1(ll)
8672 cd        ghalf=0.0d0
8673         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
8674         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
8675         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
8676         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
8677         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
8678         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
8679 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
8680 cgrad        ghalf=0.5d0*ggg2(ll)
8681 cd        ghalf=0.0d0
8682         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
8683         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
8684         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
8685         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
8686         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
8687         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
8688       enddo
8689 cd      goto 1112
8690 cgrad      do m=i+1,j-1
8691 cgrad        do ll=1,3
8692 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
8693 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
8694 cgrad        enddo
8695 cgrad      enddo
8696 cgrad      do m=k+1,l-1
8697 cgrad        do ll=1,3
8698 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
8699 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
8700 cgrad        enddo
8701 cgrad      enddo
8702 c1112  continue
8703 cgrad      do m=i+2,j2
8704 cgrad        do ll=1,3
8705 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
8706 cgrad        enddo
8707 cgrad      enddo
8708 cgrad      do m=k+2,l2
8709 cgrad        do ll=1,3
8710 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
8711 cgrad        enddo
8712 cgrad      enddo
8713 cd      do iii=1,nres-3
8714 cd        write (2,*) iii,g_corr5_loc(iii)
8715 cd      enddo
8716       eello5=ekont*eel5
8717 cd      write (2,*) 'ekont',ekont
8718 cd      write (iout,*) 'eello5',ekont*eel5
8719       return
8720       end
8721 c--------------------------------------------------------------------------
8722       double precision function eello6(i,j,k,l,jj,kk)
8723       implicit real*8 (a-h,o-z)
8724       include 'DIMENSIONS'
8725       include 'COMMON.IOUNITS'
8726       include 'COMMON.CHAIN'
8727       include 'COMMON.DERIV'
8728       include 'COMMON.INTERACT'
8729       include 'COMMON.CONTACTS'
8730       include 'COMMON.TORSION'
8731       include 'COMMON.VAR'
8732       include 'COMMON.GEO'
8733       include 'COMMON.FFIELD'
8734       double precision ggg1(3),ggg2(3)
8735 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8736 cd        eello6=0.0d0
8737 cd        return
8738 cd      endif
8739 cd      write (iout,*)
8740 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8741 cd     &   ' and',k,l
8742       eello6_1=0.0d0
8743       eello6_2=0.0d0
8744       eello6_3=0.0d0
8745       eello6_4=0.0d0
8746       eello6_5=0.0d0
8747       eello6_6=0.0d0
8748 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8749 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8750       do iii=1,2
8751         do kkk=1,5
8752           do lll=1,3
8753             derx(lll,kkk,iii)=0.0d0
8754           enddo
8755         enddo
8756       enddo
8757 cd      eij=facont_hb(jj,i)
8758 cd      ekl=facont_hb(kk,k)
8759 cd      ekont=eij*ekl
8760 cd      eij=1.0d0
8761 cd      ekl=1.0d0
8762 cd      ekont=1.0d0
8763       if (l.eq.j+1) then
8764         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8765         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8766         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8767         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8768         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8769         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8770       else
8771         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8772         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8773         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8774         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8775         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8776           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8777         else
8778           eello6_5=0.0d0
8779         endif
8780         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8781       endif
8782 C If turn contributions are considered, they will be handled separately.
8783       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8784 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8785 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8786 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8787 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8788 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8789 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8790 cd      goto 1112
8791       if (j.lt.nres-1) then
8792         j1=j+1
8793         j2=j-1
8794       else
8795         j1=j-1
8796         j2=j-2
8797       endif
8798       if (l.lt.nres-1) then
8799         l1=l+1
8800         l2=l-1
8801       else
8802         l1=l-1
8803         l2=l-2
8804       endif
8805       do ll=1,3
8806 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8807 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8808 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8809 cgrad        ghalf=0.5d0*ggg1(ll)
8810 cd        ghalf=0.0d0
8811         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8812         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8813         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8814         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8815         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8816         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8817         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8818         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8819 cgrad        ghalf=0.5d0*ggg2(ll)
8820 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8821 cd        ghalf=0.0d0
8822         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8823         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8824         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8825         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8826         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8827         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8828       enddo
8829 cd      goto 1112
8830 cgrad      do m=i+1,j-1
8831 cgrad        do ll=1,3
8832 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8833 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8834 cgrad        enddo
8835 cgrad      enddo
8836 cgrad      do m=k+1,l-1
8837 cgrad        do ll=1,3
8838 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8839 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8840 cgrad        enddo
8841 cgrad      enddo
8842 cgrad1112  continue
8843 cgrad      do m=i+2,j2
8844 cgrad        do ll=1,3
8845 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8846 cgrad        enddo
8847 cgrad      enddo
8848 cgrad      do m=k+2,l2
8849 cgrad        do ll=1,3
8850 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8851 cgrad        enddo
8852 cgrad      enddo
8853 cd      do iii=1,nres-3
8854 cd        write (2,*) iii,g_corr6_loc(iii)
8855 cd      enddo
8856       eello6=ekont*eel6
8857 cd      write (2,*) 'ekont',ekont
8858 cd      write (iout,*) 'eello6',ekont*eel6
8859       return
8860       end
8861 c--------------------------------------------------------------------------
8862       double precision function eello6_graph1(i,j,k,l,imat,swap)
8863       implicit real*8 (a-h,o-z)
8864       include 'DIMENSIONS'
8865       include 'COMMON.IOUNITS'
8866       include 'COMMON.CHAIN'
8867       include 'COMMON.DERIV'
8868       include 'COMMON.INTERACT'
8869       include 'COMMON.CONTACTS'
8870       include 'COMMON.TORSION'
8871       include 'COMMON.VAR'
8872       include 'COMMON.GEO'
8873       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8874       logical swap
8875       logical lprn
8876       common /kutas/ lprn
8877 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8878 C
8879 C      Parallel       Antiparallel
8880 C
8881 C          o             o
8882 C         /l\           /j\
8883 C        /   \         /   \
8884 C       /| o |         | o |\
8885 C     \ j|/k\|  /   \  |/k\|l /
8886 C      \ /   \ /     \ /   \ /
8887 C       o     o       o     o
8888 C       i             i
8889 C
8890 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8891       itk=itortyp(itype(k))
8892       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8893       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8894       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8895       call transpose2(EUgC(1,1,k),auxmat(1,1))
8896       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8897       vv1(1)=pizda1(1,1)-pizda1(2,2)
8898       vv1(2)=pizda1(1,2)+pizda1(2,1)
8899       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8900       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8901       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8902       s5=scalar2(vv(1),Dtobr2(1,i))
8903 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8904       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8905       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8906      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8907      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8908      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8909      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8910      & +scalar2(vv(1),Dtobr2der(1,i)))
8911       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8912       vv1(1)=pizda1(1,1)-pizda1(2,2)
8913       vv1(2)=pizda1(1,2)+pizda1(2,1)
8914       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8915       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8916       if (l.eq.j+1) then
8917         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8918      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8919      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8920      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8921      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8922       else
8923         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8924      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8925      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8926      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8927      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8928       endif
8929       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8930       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8931       vv1(1)=pizda1(1,1)-pizda1(2,2)
8932       vv1(2)=pizda1(1,2)+pizda1(2,1)
8933       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8934      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8935      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8936      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8937       do iii=1,2
8938         if (swap) then
8939           ind=3-iii
8940         else
8941           ind=iii
8942         endif
8943         do kkk=1,5
8944           do lll=1,3
8945             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8946             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8947             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8948             call transpose2(EUgC(1,1,k),auxmat(1,1))
8949             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8950      &        pizda1(1,1))
8951             vv1(1)=pizda1(1,1)-pizda1(2,2)
8952             vv1(2)=pizda1(1,2)+pizda1(2,1)
8953             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8954             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8955      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8956             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8957      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8958             s5=scalar2(vv(1),Dtobr2(1,i))
8959             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8960           enddo
8961         enddo
8962       enddo
8963       return
8964       end
8965 c----------------------------------------------------------------------------
8966       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8967       implicit real*8 (a-h,o-z)
8968       include 'DIMENSIONS'
8969       include 'COMMON.IOUNITS'
8970       include 'COMMON.CHAIN'
8971       include 'COMMON.DERIV'
8972       include 'COMMON.INTERACT'
8973       include 'COMMON.CONTACTS'
8974       include 'COMMON.TORSION'
8975       include 'COMMON.VAR'
8976       include 'COMMON.GEO'
8977       logical swap
8978       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8979      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8980       logical lprn
8981       common /kutas/ lprn
8982 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8983 C                                                                              C
8984 C      Parallel       Antiparallel                                             C
8985 C                                                                              C
8986 C          o             o                                                     C
8987 C     \   /l\           /j\   /                                                C
8988 C      \ /   \         /   \ /                                                 C
8989 C       o| o |         | o |o                                                  C
8990 C     \ j|/k\|      \  |/k\|l                                                  C
8991 C      \ /   \       \ /   \                                                   C
8992 C       o             o                                                        C
8993 C       i             i                                                        C
8994 C                                                                              C
8995 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8996 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8997 C AL 7/4/01 s1 would occur in the sixth-order moment,
8998 C           but not in a cluster cumulant
8999 #ifdef MOMENT
9000       s1=dip(1,jj,i)*dip(1,kk,k)
9001 #endif
9002       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
9003       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9004       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
9005       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
9006       call transpose2(EUg(1,1,k),auxmat(1,1))
9007       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
9008       vv(1)=pizda(1,1)-pizda(2,2)
9009       vv(2)=pizda(1,2)+pizda(2,1)
9010       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9011 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9012 #ifdef MOMENT
9013       eello6_graph2=-(s1+s2+s3+s4)
9014 #else
9015       eello6_graph2=-(s2+s3+s4)
9016 #endif
9017 c      eello6_graph2=-s3
9018 C Derivatives in gamma(i-1)
9019       if (i.gt.1) then
9020 #ifdef MOMENT
9021         s1=dipderg(1,jj,i)*dip(1,kk,k)
9022 #endif
9023         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9024         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
9025         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9026         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9027 #ifdef MOMENT
9028         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9029 #else
9030         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9031 #endif
9032 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
9033       endif
9034 C Derivatives in gamma(k-1)
9035 #ifdef MOMENT
9036       s1=dip(1,jj,i)*dipderg(1,kk,k)
9037 #endif
9038       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
9039       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9040       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
9041       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9042       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9043       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
9044       vv(1)=pizda(1,1)-pizda(2,2)
9045       vv(2)=pizda(1,2)+pizda(2,1)
9046       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9047 #ifdef MOMENT
9048       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9049 #else
9050       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9051 #endif
9052 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
9053 C Derivatives in gamma(j-1) or gamma(l-1)
9054       if (j.gt.1) then
9055 #ifdef MOMENT
9056         s1=dipderg(3,jj,i)*dip(1,kk,k)
9057 #endif
9058         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
9059         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9060         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
9061         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
9062         vv(1)=pizda(1,1)-pizda(2,2)
9063         vv(2)=pizda(1,2)+pizda(2,1)
9064         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9065 #ifdef MOMENT
9066         if (swap) then
9067           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9068         else
9069           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9070         endif
9071 #endif
9072         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
9073 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
9074       endif
9075 C Derivatives in gamma(l-1) or gamma(j-1)
9076       if (l.gt.1) then
9077 #ifdef MOMENT
9078         s1=dip(1,jj,i)*dipderg(3,kk,k)
9079 #endif
9080         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
9081         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9082         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
9083         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9084         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
9085         vv(1)=pizda(1,1)-pizda(2,2)
9086         vv(2)=pizda(1,2)+pizda(2,1)
9087         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9088 #ifdef MOMENT
9089         if (swap) then
9090           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9091         else
9092           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9093         endif
9094 #endif
9095         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
9096 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
9097       endif
9098 C Cartesian derivatives.
9099       if (lprn) then
9100         write (2,*) 'In eello6_graph2'
9101         do iii=1,2
9102           write (2,*) 'iii=',iii
9103           do kkk=1,5
9104             write (2,*) 'kkk=',kkk
9105             do jjj=1,2
9106               write (2,'(3(2f10.5),5x)')
9107      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9108             enddo
9109           enddo
9110         enddo
9111       endif
9112       do iii=1,2
9113         do kkk=1,5
9114           do lll=1,3
9115 #ifdef MOMENT
9116             if (iii.eq.1) then
9117               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
9118             else
9119               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
9120             endif
9121 #endif
9122             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
9123      &        auxvec(1))
9124             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9125             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
9126      &        auxvec(1))
9127             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
9128             call transpose2(EUg(1,1,k),auxmat(1,1))
9129             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
9130      &        pizda(1,1))
9131             vv(1)=pizda(1,1)-pizda(2,2)
9132             vv(2)=pizda(1,2)+pizda(2,1)
9133             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9134 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
9135 #ifdef MOMENT
9136             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9137 #else
9138             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9139 #endif
9140             if (swap) then
9141               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9142             else
9143               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9144             endif
9145           enddo
9146         enddo
9147       enddo
9148       return
9149       end
9150 c----------------------------------------------------------------------------
9151       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
9152       implicit real*8 (a-h,o-z)
9153       include 'DIMENSIONS'
9154       include 'COMMON.IOUNITS'
9155       include 'COMMON.CHAIN'
9156       include 'COMMON.DERIV'
9157       include 'COMMON.INTERACT'
9158       include 'COMMON.CONTACTS'
9159       include 'COMMON.TORSION'
9160       include 'COMMON.VAR'
9161       include 'COMMON.GEO'
9162       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
9163       logical swap
9164 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9165 C                                                                              C
9166 C      Parallel       Antiparallel                                             C
9167 C                                                                              C
9168 C          o             o                                                     C
9169 C         /l\   /   \   /j\                                                    C
9170 C        /   \ /     \ /   \                                                   C
9171 C       /| o |o       o| o |\                                                  C
9172 C       j|/k\|  /      |/k\|l /                                                C
9173 C        /   \ /       /   \ /                                                 C
9174 C       /     o       /     o                                                  C
9175 C       i             i                                                        C
9176 C                                                                              C
9177 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9178 C
9179 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9180 C           energy moment and not to the cluster cumulant.
9181       iti=itortyp(itype(i))
9182       if (j.lt.nres-1) then
9183         itj1=itortyp(itype(j+1))
9184       else
9185         itj1=ntortyp+1
9186       endif
9187       itk=itortyp(itype(k))
9188       itk1=itortyp(itype(k+1))
9189       if (l.lt.nres-1) then
9190         itl1=itortyp(itype(l+1))
9191       else
9192         itl1=ntortyp+1
9193       endif
9194 #ifdef MOMENT
9195       s1=dip(4,jj,i)*dip(4,kk,k)
9196 #endif
9197       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
9198       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9199       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
9200       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9201       call transpose2(EE(1,1,itk),auxmat(1,1))
9202       call matmat2(auxmat(1,1),AECA(1,1,1),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 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9207 cd     & "sum",-(s2+s3+s4)
9208 #ifdef MOMENT
9209       eello6_graph3=-(s1+s2+s3+s4)
9210 #else
9211       eello6_graph3=-(s2+s3+s4)
9212 #endif
9213 c      eello6_graph3=-s4
9214 C Derivatives in gamma(k-1)
9215       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
9216       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9217       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9218       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9219 C Derivatives in gamma(l-1)
9220       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
9221       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9222       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9223       vv(1)=pizda(1,1)+pizda(2,2)
9224       vv(2)=pizda(2,1)-pizda(1,2)
9225       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9226       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9227 C Cartesian derivatives.
9228       do iii=1,2
9229         do kkk=1,5
9230           do lll=1,3
9231 #ifdef MOMENT
9232             if (iii.eq.1) then
9233               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9234             else
9235               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9236             endif
9237 #endif
9238             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
9239      &        auxvec(1))
9240             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9241             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
9242      &        auxvec(1))
9243             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9244             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
9245      &        pizda(1,1))
9246             vv(1)=pizda(1,1)+pizda(2,2)
9247             vv(2)=pizda(2,1)-pizda(1,2)
9248             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9249 #ifdef MOMENT
9250             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9251 #else
9252             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9253 #endif
9254             if (swap) then
9255               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9256             else
9257               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9258             endif
9259 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9260           enddo
9261         enddo
9262       enddo
9263       return
9264       end
9265 c----------------------------------------------------------------------------
9266       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
9267       implicit real*8 (a-h,o-z)
9268       include 'DIMENSIONS'
9269       include 'COMMON.IOUNITS'
9270       include 'COMMON.CHAIN'
9271       include 'COMMON.DERIV'
9272       include 'COMMON.INTERACT'
9273       include 'COMMON.CONTACTS'
9274       include 'COMMON.TORSION'
9275       include 'COMMON.VAR'
9276       include 'COMMON.GEO'
9277       include 'COMMON.FFIELD'
9278       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9279      & auxvec1(2),auxmat1(2,2)
9280       logical swap
9281 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9282 C                                                                              C
9283 C      Parallel       Antiparallel                                             C
9284 C                                                                              C
9285 C          o             o                                                     C
9286 C         /l\   /   \   /j\                                                    C
9287 C        /   \ /     \ /   \                                                   C
9288 C       /| o |o       o| o |\                                                  C
9289 C     \ j|/k\|      \  |/k\|l                                                  C
9290 C      \ /   \       \ /   \                                                   C
9291 C       o     \       o     \                                                  C
9292 C       i             i                                                        C
9293 C                                                                              C
9294 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9295 C
9296 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9297 C           energy moment and not to the cluster cumulant.
9298 cd      write (2,*) 'eello_graph4: wturn6',wturn6
9299       iti=itortyp(itype(i))
9300       itj=itortyp(itype(j))
9301       if (j.lt.nres-1) then
9302         itj1=itortyp(itype(j+1))
9303       else
9304         itj1=ntortyp+1
9305       endif
9306       itk=itortyp(itype(k))
9307       if (k.lt.nres-1) then
9308         itk1=itortyp(itype(k+1))
9309       else
9310         itk1=ntortyp+1
9311       endif
9312       itl=itortyp(itype(l))
9313       if (l.lt.nres-1) then
9314         itl1=itortyp(itype(l+1))
9315       else
9316         itl1=ntortyp+1
9317       endif
9318 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9319 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9320 cd     & ' itl',itl,' itl1',itl1
9321 #ifdef MOMENT
9322       if (imat.eq.1) then
9323         s1=dip(3,jj,i)*dip(3,kk,k)
9324       else
9325         s1=dip(2,jj,j)*dip(2,kk,l)
9326       endif
9327 #endif
9328       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9329       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9330       if (j.eq.l+1) then
9331         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
9332         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9333       else
9334         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
9335         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9336       endif
9337       call transpose2(EUg(1,1,k),auxmat(1,1))
9338       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9339       vv(1)=pizda(1,1)-pizda(2,2)
9340       vv(2)=pizda(2,1)+pizda(1,2)
9341       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9342 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9343 #ifdef MOMENT
9344       eello6_graph4=-(s1+s2+s3+s4)
9345 #else
9346       eello6_graph4=-(s2+s3+s4)
9347 #endif
9348 C Derivatives in gamma(i-1)
9349       if (i.gt.1) then
9350 #ifdef MOMENT
9351         if (imat.eq.1) then
9352           s1=dipderg(2,jj,i)*dip(3,kk,k)
9353         else
9354           s1=dipderg(4,jj,j)*dip(2,kk,l)
9355         endif
9356 #endif
9357         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9358         if (j.eq.l+1) then
9359           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
9360           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9361         else
9362           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
9363           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9364         endif
9365         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9366         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9367 cd          write (2,*) 'turn6 derivatives'
9368 #ifdef MOMENT
9369           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9370 #else
9371           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9372 #endif
9373         else
9374 #ifdef MOMENT
9375           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9376 #else
9377           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9378 #endif
9379         endif
9380       endif
9381 C Derivatives in gamma(k-1)
9382 #ifdef MOMENT
9383       if (imat.eq.1) then
9384         s1=dip(3,jj,i)*dipderg(2,kk,k)
9385       else
9386         s1=dip(2,jj,j)*dipderg(4,kk,l)
9387       endif
9388 #endif
9389       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9390       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9391       if (j.eq.l+1) then
9392         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
9393         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9394       else
9395         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
9396         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9397       endif
9398       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9399       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9400       vv(1)=pizda(1,1)-pizda(2,2)
9401       vv(2)=pizda(2,1)+pizda(1,2)
9402       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9403       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9404 #ifdef MOMENT
9405         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9406 #else
9407         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9408 #endif
9409       else
9410 #ifdef MOMENT
9411         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9412 #else
9413         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9414 #endif
9415       endif
9416 C Derivatives in gamma(j-1) or gamma(l-1)
9417       if (l.eq.j+1 .and. l.gt.1) then
9418         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9419         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9420         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9421         vv(1)=pizda(1,1)-pizda(2,2)
9422         vv(2)=pizda(2,1)+pizda(1,2)
9423         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9424         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9425       else if (j.gt.1) then
9426         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9427         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9428         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9429         vv(1)=pizda(1,1)-pizda(2,2)
9430         vv(2)=pizda(2,1)+pizda(1,2)
9431         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9432         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9433           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9434         else
9435           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9436         endif
9437       endif
9438 C Cartesian derivatives.
9439       do iii=1,2
9440         do kkk=1,5
9441           do lll=1,3
9442 #ifdef MOMENT
9443             if (iii.eq.1) then
9444               if (imat.eq.1) then
9445                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9446               else
9447                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9448               endif
9449             else
9450               if (imat.eq.1) then
9451                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9452               else
9453                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9454               endif
9455             endif
9456 #endif
9457             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
9458      &        auxvec(1))
9459             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9460             if (j.eq.l+1) then
9461               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9462      &          b1(1,itj1),auxvec(1))
9463               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
9464             else
9465               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9466      &          b1(1,itl1),auxvec(1))
9467               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
9468             endif
9469             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9470      &        pizda(1,1))
9471             vv(1)=pizda(1,1)-pizda(2,2)
9472             vv(2)=pizda(2,1)+pizda(1,2)
9473             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9474             if (swap) then
9475               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9476 #ifdef MOMENT
9477                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9478      &             -(s1+s2+s4)
9479 #else
9480                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9481      &             -(s2+s4)
9482 #endif
9483                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9484               else
9485 #ifdef MOMENT
9486                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9487 #else
9488                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9489 #endif
9490                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9491               endif
9492             else
9493 #ifdef MOMENT
9494               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9495 #else
9496               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9497 #endif
9498               if (l.eq.j+1) then
9499                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9500               else
9501                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9502               endif
9503             endif
9504           enddo
9505         enddo
9506       enddo
9507       return
9508       end
9509 c----------------------------------------------------------------------------
9510       double precision function eello_turn6(i,jj,kk)
9511       implicit real*8 (a-h,o-z)
9512       include 'DIMENSIONS'
9513       include 'COMMON.IOUNITS'
9514       include 'COMMON.CHAIN'
9515       include 'COMMON.DERIV'
9516       include 'COMMON.INTERACT'
9517       include 'COMMON.CONTACTS'
9518       include 'COMMON.TORSION'
9519       include 'COMMON.VAR'
9520       include 'COMMON.GEO'
9521       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
9522      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
9523      &  ggg1(3),ggg2(3)
9524       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
9525      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
9526 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9527 C           the respective energy moment and not to the cluster cumulant.
9528       s1=0.0d0
9529       s8=0.0d0
9530       s13=0.0d0
9531 c
9532       eello_turn6=0.0d0
9533       j=i+4
9534       k=i+1
9535       l=i+3
9536       iti=itortyp(itype(i))
9537       itk=itortyp(itype(k))
9538       itk1=itortyp(itype(k+1))
9539       itl=itortyp(itype(l))
9540       itj=itortyp(itype(j))
9541 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9542 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
9543 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9544 cd        eello6=0.0d0
9545 cd        return
9546 cd      endif
9547 cd      write (iout,*)
9548 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9549 cd     &   ' and',k,l
9550 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
9551       do iii=1,2
9552         do kkk=1,5
9553           do lll=1,3
9554             derx_turn(lll,kkk,iii)=0.0d0
9555           enddo
9556         enddo
9557       enddo
9558 cd      eij=1.0d0
9559 cd      ekl=1.0d0
9560 cd      ekont=1.0d0
9561       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9562 cd      eello6_5=0.0d0
9563 cd      write (2,*) 'eello6_5',eello6_5
9564 #ifdef MOMENT
9565       call transpose2(AEA(1,1,1),auxmat(1,1))
9566       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
9567       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
9568       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
9569 #endif
9570       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9571       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
9572       s2 = scalar2(b1(1,itk),vtemp1(1))
9573 #ifdef MOMENT
9574       call transpose2(AEA(1,1,2),atemp(1,1))
9575       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
9576       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
9577       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9578 #endif
9579       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
9580       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
9581       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
9582 #ifdef MOMENT
9583       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
9584       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
9585       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
9586       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
9587       ss13 = scalar2(b1(1,itk),vtemp4(1))
9588       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
9589 #endif
9590 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
9591 c      s1=0.0d0
9592 c      s2=0.0d0
9593 c      s8=0.0d0
9594 c      s12=0.0d0
9595 c      s13=0.0d0
9596       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
9597 C Derivatives in gamma(i+2)
9598       s1d =0.0d0
9599       s8d =0.0d0
9600 #ifdef MOMENT
9601       call transpose2(AEA(1,1,1),auxmatd(1,1))
9602       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9603       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9604       call transpose2(AEAderg(1,1,2),atempd(1,1))
9605       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9606       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9607 #endif
9608       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
9609       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9610       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9611 c      s1d=0.0d0
9612 c      s2d=0.0d0
9613 c      s8d=0.0d0
9614 c      s12d=0.0d0
9615 c      s13d=0.0d0
9616       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
9617 C Derivatives in gamma(i+3)
9618 #ifdef MOMENT
9619       call transpose2(AEA(1,1,1),auxmatd(1,1))
9620       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9621       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
9622       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
9623 #endif
9624       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
9625       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
9626       s2d = scalar2(b1(1,itk),vtemp1d(1))
9627 #ifdef MOMENT
9628       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
9629       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
9630 #endif
9631       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
9632 #ifdef MOMENT
9633       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
9634       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9635       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9636 #endif
9637 c      s1d=0.0d0
9638 c      s2d=0.0d0
9639 c      s8d=0.0d0
9640 c      s12d=0.0d0
9641 c      s13d=0.0d0
9642 #ifdef MOMENT
9643       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9644      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9645 #else
9646       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9647      &               -0.5d0*ekont*(s2d+s12d)
9648 #endif
9649 C Derivatives in gamma(i+4)
9650       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
9651       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9652       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9653 #ifdef MOMENT
9654       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
9655       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
9656       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9657 #endif
9658 c      s1d=0.0d0
9659 c      s2d=0.0d0
9660 c      s8d=0.0d0
9661 C      s12d=0.0d0
9662 c      s13d=0.0d0
9663 #ifdef MOMENT
9664       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
9665 #else
9666       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
9667 #endif
9668 C Derivatives in gamma(i+5)
9669 #ifdef MOMENT
9670       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
9671       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9672       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9673 #endif
9674       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
9675       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
9676       s2d = scalar2(b1(1,itk),vtemp1d(1))
9677 #ifdef MOMENT
9678       call transpose2(AEA(1,1,2),atempd(1,1))
9679       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
9680       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9681 #endif
9682       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
9683       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9684 #ifdef MOMENT
9685       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
9686       ss13d = scalar2(b1(1,itk),vtemp4d(1))
9687       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9688 #endif
9689 c      s1d=0.0d0
9690 c      s2d=0.0d0
9691 c      s8d=0.0d0
9692 c      s12d=0.0d0
9693 c      s13d=0.0d0
9694 #ifdef MOMENT
9695       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9696      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9697 #else
9698       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9699      &               -0.5d0*ekont*(s2d+s12d)
9700 #endif
9701 C Cartesian derivatives
9702       do iii=1,2
9703         do kkk=1,5
9704           do lll=1,3
9705 #ifdef MOMENT
9706             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
9707             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9708             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9709 #endif
9710             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9711             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
9712      &          vtemp1d(1))
9713             s2d = scalar2(b1(1,itk),vtemp1d(1))
9714 #ifdef MOMENT
9715             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
9716             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9717             s8d = -(atempd(1,1)+atempd(2,2))*
9718      &           scalar2(cc(1,1,itl),vtemp2(1))
9719 #endif
9720             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
9721      &           auxmatd(1,1))
9722             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9723             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9724 c      s1d=0.0d0
9725 c      s2d=0.0d0
9726 c      s8d=0.0d0
9727 c      s12d=0.0d0
9728 c      s13d=0.0d0
9729 #ifdef MOMENT
9730             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9731      &        - 0.5d0*(s1d+s2d)
9732 #else
9733             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9734      &        - 0.5d0*s2d
9735 #endif
9736 #ifdef MOMENT
9737             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9738      &        - 0.5d0*(s8d+s12d)
9739 #else
9740             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9741      &        - 0.5d0*s12d
9742 #endif
9743           enddo
9744         enddo
9745       enddo
9746 #ifdef MOMENT
9747       do kkk=1,5
9748         do lll=1,3
9749           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9750      &      achuj_tempd(1,1))
9751           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9752           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9753           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9754           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9755           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9756      &      vtemp4d(1))
9757           ss13d = scalar2(b1(1,itk),vtemp4d(1))
9758           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9759           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9760         enddo
9761       enddo
9762 #endif
9763 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9764 cd     &  16*eel_turn6_num
9765 cd      goto 1112
9766       if (j.lt.nres-1) then
9767         j1=j+1
9768         j2=j-1
9769       else
9770         j1=j-1
9771         j2=j-2
9772       endif
9773       if (l.lt.nres-1) then
9774         l1=l+1
9775         l2=l-1
9776       else
9777         l1=l-1
9778         l2=l-2
9779       endif
9780       do ll=1,3
9781 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9782 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9783 cgrad        ghalf=0.5d0*ggg1(ll)
9784 cd        ghalf=0.0d0
9785         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9786         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9787         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9788      &    +ekont*derx_turn(ll,2,1)
9789         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9790         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9791      &    +ekont*derx_turn(ll,4,1)
9792         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9793         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9794         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9795 cgrad        ghalf=0.5d0*ggg2(ll)
9796 cd        ghalf=0.0d0
9797         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9798      &    +ekont*derx_turn(ll,2,2)
9799         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9800         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9801      &    +ekont*derx_turn(ll,4,2)
9802         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9803         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9804         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9805       enddo
9806 cd      goto 1112
9807 cgrad      do m=i+1,j-1
9808 cgrad        do ll=1,3
9809 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9810 cgrad        enddo
9811 cgrad      enddo
9812 cgrad      do m=k+1,l-1
9813 cgrad        do ll=1,3
9814 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9815 cgrad        enddo
9816 cgrad      enddo
9817 cgrad1112  continue
9818 cgrad      do m=i+2,j2
9819 cgrad        do ll=1,3
9820 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9821 cgrad        enddo
9822 cgrad      enddo
9823 cgrad      do m=k+2,l2
9824 cgrad        do ll=1,3
9825 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9826 cgrad        enddo
9827 cgrad      enddo
9828 cd      do iii=1,nres-3
9829 cd        write (2,*) iii,g_corr6_loc(iii)
9830 cd      enddo
9831       eello_turn6=ekont*eel_turn6
9832 cd      write (2,*) 'ekont',ekont
9833 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9834       return
9835       end
9836
9837 C-----------------------------------------------------------------------------
9838       double precision function scalar(u,v)
9839 !DIR$ INLINEALWAYS scalar
9840 #ifndef OSF
9841 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9842 #endif
9843       implicit none
9844       double precision u(3),v(3)
9845 cd      double precision sc
9846 cd      integer i
9847 cd      sc=0.0d0
9848 cd      do i=1,3
9849 cd        sc=sc+u(i)*v(i)
9850 cd      enddo
9851 cd      scalar=sc
9852
9853       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9854       return
9855       end
9856 crc-------------------------------------------------
9857       SUBROUTINE MATVEC2(A1,V1,V2)
9858 !DIR$ INLINEALWAYS MATVEC2
9859 #ifndef OSF
9860 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9861 #endif
9862       implicit real*8 (a-h,o-z)
9863       include 'DIMENSIONS'
9864       DIMENSION A1(2,2),V1(2),V2(2)
9865 c      DO 1 I=1,2
9866 c        VI=0.0
9867 c        DO 3 K=1,2
9868 c    3     VI=VI+A1(I,K)*V1(K)
9869 c        Vaux(I)=VI
9870 c    1 CONTINUE
9871
9872       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9873       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9874
9875       v2(1)=vaux1
9876       v2(2)=vaux2
9877       END
9878 C---------------------------------------
9879       SUBROUTINE MATMAT2(A1,A2,A3)
9880 #ifndef OSF
9881 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9882 #endif
9883       implicit real*8 (a-h,o-z)
9884       include 'DIMENSIONS'
9885       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9886 c      DIMENSION AI3(2,2)
9887 c        DO  J=1,2
9888 c          A3IJ=0.0
9889 c          DO K=1,2
9890 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9891 c          enddo
9892 c          A3(I,J)=A3IJ
9893 c       enddo
9894 c      enddo
9895
9896       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9897       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9898       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9899       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9900
9901       A3(1,1)=AI3_11
9902       A3(2,1)=AI3_21
9903       A3(1,2)=AI3_12
9904       A3(2,2)=AI3_22
9905       END
9906
9907 c-------------------------------------------------------------------------
9908       double precision function scalar2(u,v)
9909 !DIR$ INLINEALWAYS scalar2
9910       implicit none
9911       double precision u(2),v(2)
9912       double precision sc
9913       integer i
9914       scalar2=u(1)*v(1)+u(2)*v(2)
9915       return
9916       end
9917
9918 C-----------------------------------------------------------------------------
9919
9920       subroutine transpose2(a,at)
9921 !DIR$ INLINEALWAYS transpose2
9922 #ifndef OSF
9923 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9924 #endif
9925       implicit none
9926       double precision a(2,2),at(2,2)
9927       at(1,1)=a(1,1)
9928       at(1,2)=a(2,1)
9929       at(2,1)=a(1,2)
9930       at(2,2)=a(2,2)
9931       return
9932       end
9933 c--------------------------------------------------------------------------
9934       subroutine transpose(n,a,at)
9935       implicit none
9936       integer n,i,j
9937       double precision a(n,n),at(n,n)
9938       do i=1,n
9939         do j=1,n
9940           at(j,i)=a(i,j)
9941         enddo
9942       enddo
9943       return
9944       end
9945 C---------------------------------------------------------------------------
9946       subroutine prodmat3(a1,a2,kk,transp,prod)
9947 !DIR$ INLINEALWAYS prodmat3
9948 #ifndef OSF
9949 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9950 #endif
9951       implicit none
9952       integer i,j
9953       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9954       logical transp
9955 crc      double precision auxmat(2,2),prod_(2,2)
9956
9957       if (transp) then
9958 crc        call transpose2(kk(1,1),auxmat(1,1))
9959 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9960 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9961
9962            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9963      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9964            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9965      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9966            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9967      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9968            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9969      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9970
9971       else
9972 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9973 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9974
9975            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9976      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9977            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9978      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9979            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9980      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9981            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9982      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9983
9984       endif
9985 c      call transpose2(a2(1,1),a2t(1,1))
9986
9987 crc      print *,transp
9988 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9989 crc      print *,((prod(i,j),i=1,2),j=1,2)
9990
9991       return
9992       end
9993